1;;; mh-seq.el --- MH-E sequences support
2
3;; Copyright (C) 1993, 1995,
4;;  2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Bill Wohler <wohler@newt.com>
7;; Maintainer: Bill Wohler <wohler@newt.com>
8;; Keywords: mail
9;; See: mh-e.el
10
11;; This file is part of GNU Emacs.
12
13;; GNU Emacs is free software; you can redistribute it and/or modify
14;; it under the terms of the GNU General Public License as published by
15;; the Free Software Foundation; either version 2, or (at your option)
16;; any later version.
17
18;; GNU Emacs is distributed in the hope that it will be useful,
19;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21;; GNU General Public License for more details.
22
23;; You should have received a copy of the GNU General Public License
24;; along with GNU Emacs; see the file COPYING.  If not, write to the
25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26;; Boston, MA 02110-1301, USA.
27
28;;; Commentary:
29
30;; Sequences are stored in the alist `mh-seq-list' in the form:
31;;     ((seq-name msgs ...) (seq-name msgs ...) ...)
32
33;;; Change Log:
34
35;;; Code:
36
37(require 'mh-e)
38(mh-require-cl)
39(require 'mh-scan)
40
41(require 'font-lock)
42
43;;; Variables
44
45(defvar mh-last-seq-used nil
46  "Name of seq to which a msg was last added.")
47
48(defvar mh-non-seq-mode-line-annotation nil
49  "Saved value of `mh-mode-line-annotation' when narrowed to a seq.")
50(make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
51
52(defvar mh-internal-seqs '(answered cur deleted forwarded printed))
53
54;;; Macros
55
56(defmacro mh-make-seq (name msgs)
57  "Create sequence NAME with the given MSGS."
58  (list 'cons name msgs))
59
60(defmacro mh-seq-name (sequence)
61  "Extract sequence name from the given SEQUENCE."
62  (list 'car sequence))
63
64
65
66;;; MH-Folder Commands
67
68;; Alphabetical.
69
70;;;###mh-autoload
71(defun mh-catchup (range)
72  "Delete RANGE from the \"unseen\" sequence.
73
74Check the documentation of `mh-interactive-range' to see how
75RANGE is read in interactive use."
76  (interactive (list (mh-interactive-range "Catchup"
77                                           (cons (point-min) (point-max)))))
78  (mh-delete-msg-from-seq range mh-unseen-seq))
79
80;;;###mh-autoload
81(defun mh-delete-msg-from-seq (range sequence &optional internal-flag)
82  "Delete RANGE from SEQUENCE.
83
84Check the documentation of `mh-interactive-range' to see how
85RANGE is read in interactive use.
86
87In a program, non-nil INTERNAL-FLAG means do not inform MH of the
88change."
89  (interactive (list (mh-interactive-range "Delete")
90                     (mh-read-seq-default "Delete from" t)
91                     nil))
92  (let ((entry (mh-find-seq sequence))
93        (user-sequence-flag (not (mh-internal-seq sequence)))
94        (folders-changed (list mh-current-folder))
95        (msg-list ()))
96    (when entry
97      (mh-iterate-on-range msg range
98        (push msg msg-list)
99        ;; Calling "mark" repeatedly takes too long. So we will pretend here
100        ;; that we are just modifying an internal sequence...
101        (when (memq msg (cdr entry))
102          (mh-remove-sequence-notation msg (not user-sequence-flag)))
103        (mh-delete-a-msg-from-seq msg sequence t))
104      ;; ... and here we will "mark" all the messages at one go.
105      (unless internal-flag (mh-undefine-sequence sequence msg-list))
106      (when (and mh-index-data (not internal-flag))
107        (setq folders-changed
108              (append folders-changed
109                      (mh-index-delete-from-sequence sequence msg-list))))
110      (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
111        (apply #'mh-speed-flists t folders-changed)))))
112
113;;;###mh-autoload
114(defun mh-delete-seq (sequence)
115  "Delete SEQUENCE.
116
117You are prompted for the sequence to delete. Note that this
118deletes only the sequence, not the messages in the sequence. If
119you want to delete the messages, use \"\\[universal-argument]
120\\[mh-delete-msg]\"."
121  (interactive (list (mh-read-seq-default "Delete" t)))
122  (let ((msg-list (mh-seq-to-msgs sequence))
123        (internal-flag (mh-internal-seq sequence))
124        (folders-changed (list mh-current-folder)))
125    (mh-iterate-on-range msg sequence
126      (mh-remove-sequence-notation msg internal-flag))
127    (mh-undefine-sequence sequence '("all"))
128    (mh-delete-seq-locally sequence)
129    (when mh-index-data
130      (setq folders-changed
131            (append folders-changed
132                    (mh-index-delete-from-sequence sequence msg-list))))
133    (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
134      (apply #'mh-speed-flists t folders-changed))))
135
136;; Shush compiler.
137(defvar view-exit-action)
138
139;;;###mh-autoload
140(defun mh-list-sequences ()
141  "List all sequences in folder.
142
143The list appears in a buffer named \"*MH-E Sequences*\"."
144  (interactive)
145  (let ((folder mh-current-folder)
146        (temp-buffer mh-sequences-buffer)
147        (seq-list mh-seq-list)
148        (max-len 0))
149    (with-output-to-temp-buffer temp-buffer
150      (save-excursion
151        (set-buffer temp-buffer)
152        (erase-buffer)
153        (message "Listing sequences ...")
154        (insert "Sequences in folder " folder ":\n")
155        (let ((seq-list seq-list))
156          (while seq-list
157            (setq max-len
158                  (max (length (symbol-name (mh-seq-name (pop seq-list))))
159                       max-len)))
160          (setq max-len (+ 2 max-len)))
161        (while seq-list
162          (let ((name (mh-seq-name (car seq-list)))
163                (sorted-seq-msgs
164                 (mh-coalesce-msg-list
165                  (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<)))
166                name-spec)
167            (insert (setq name-spec (format (format "%%%ss:" max-len) name)))
168            (while sorted-seq-msgs
169              (let ((next-element (format " %s" (pop sorted-seq-msgs))))
170                (when (>= (+ (current-column) (length next-element))
171                          (window-width))
172                  (insert "\n")
173                  (insert (format (format "%%%ss" (length name-spec)) "")))
174                (insert next-element)))
175            (insert "\n"))
176          (setq seq-list (cdr seq-list)))
177        (goto-char (point-min))
178        (mh-view-mode-enter)
179        (setq view-exit-action 'kill-buffer)
180        (message "Listing sequences...done")))))
181
182;;;###mh-autoload
183(defun mh-msg-is-in-seq (message)
184  "Display the sequences in which the current message appears.
185
186Use a prefix argument to display the sequences in which another
187MESSAGE appears."
188  (interactive "P")
189  (if (not message)
190      (setq message (mh-get-msg-num t)))
191  (let* ((dest-folder (loop for seq in mh-refile-list
192                            when (member message (cdr seq)) return (car seq)
193                            finally return nil))
194         (deleted-flag (unless dest-folder (member message mh-delete-list))))
195    (message "Message %d%s is in sequences: %s"
196             message
197             (cond (dest-folder (format " (to be refiled to %s)" dest-folder))
198                   (deleted-flag (format " (to be deleted)"))
199                   (t ""))
200             (mapconcat 'concat
201                        (mh-list-to-string (mh-seq-containing-msg message t))
202                        " "))))
203
204;; Shush compiler.
205(defvar tool-bar-mode)                  ; XEmacs
206
207;;;###mh-autoload
208(defun mh-narrow-to-seq (sequence)
209  "Restrict display to messages in SEQUENCE.
210
211You are prompted for the name of the sequence. What this command
212does is show only those messages that are in the selected
213sequence in the MH-Folder buffer. In addition, it limits further
214MH-E searches to just those messages.
215
216When you want to widen the view to all your messages again, use
217\\[mh-widen]."
218  (interactive (list (mh-read-seq "Narrow to" t)))
219  (with-mh-folder-updating (t)
220    (cond ((mh-seq-to-msgs sequence)
221           (mh-remove-all-notation)
222           (let ((eob (point-max))
223                 (msg-at-cursor (mh-get-msg-num nil)))
224             (push mh-thread-scan-line-map mh-thread-scan-line-map-stack)
225             (setq mh-thread-scan-line-map (make-hash-table :test #'eql))
226             (mh-copy-seq-to-eob sequence)
227             (push (buffer-substring-no-properties (point-min) eob)
228                   mh-folder-view-stack)
229             (delete-region (point-min) eob)
230             (mh-notate-deleted-and-refiled)
231             (mh-notate-cur)
232             (when msg-at-cursor (mh-goto-msg msg-at-cursor t t))
233             (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation)
234             (setq mh-mode-line-annotation (symbol-name sequence))
235             (mh-make-folder-mode-line)
236             (mh-recenter nil)
237             (when (and (boundp 'tool-bar-mode) tool-bar-mode)
238               (set (make-local-variable 'tool-bar-map)
239                    mh-folder-seq-tool-bar-map)
240               (when (buffer-live-p (get-buffer mh-show-buffer))
241                 (with-current-buffer mh-show-buffer
242                   (set (make-local-variable 'tool-bar-map)
243                        mh-show-seq-tool-bar-map))))
244             (push 'widen mh-view-ops)))
245          (t
246           (error "No messages in sequence %s" (symbol-name sequence))))))
247
248;;;###mh-autoload
249(defun mh-narrow-to-tick ()
250  "Limit to ticked messages.
251
252What this command does is show only those messages that are in
253the \"tick\" sequence (which you can customize via the
254`mh-tick-seq' option) in the MH-Folder buffer. In addition, it
255limits further MH-E searches to just those messages. When you
256want to widen the view to all your messages again, use
257\\[mh-widen]."
258  (interactive)
259  (cond ((not mh-tick-seq)
260         (error "Enable ticking by customizing `mh-tick-seq'"))
261        ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
262         (message "No messages in %s sequence" mh-tick-seq))
263        (t (mh-narrow-to-seq mh-tick-seq))))
264
265;;;###mh-autoload
266(defun mh-put-msg-in-seq (range sequence)
267  "Add RANGE to SEQUENCE\\<mh-folder-mode-map>.
268
269Give this command a RANGE and you can add all the messages in a
270sequence to another sequence (for example,
271\"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET
272DestSequence RET\"). Check the documentation of
273`mh-interactive-range' to see how RANGE is read in interactive
274use."
275  (interactive (list (mh-interactive-range "Add messages from")
276                     (mh-read-seq-default "Add to" nil)))
277  (unless (mh-valid-seq-p sequence)
278    (error "Can't put message in invalid sequence %s" sequence))
279  (let* ((internal-seq-flag (mh-internal-seq sequence))
280         (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
281         (folders (list mh-current-folder))
282         (msg-list (mh-range-to-msg-list range)))
283    (mh-add-msgs-to-seq msg-list sequence nil t)
284    (mh-iterate-on-range m range
285      (unless (memq m original-msgs)
286        (mh-add-sequence-notation m internal-seq-flag)))
287    (if (not internal-seq-flag)
288        (setq mh-last-seq-used sequence))
289    (when mh-index-data
290      (setq folders
291            (append folders (mh-index-add-to-sequence sequence msg-list))))
292    (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
293      (apply #'mh-speed-flists t folders))))
294
295;;;###mh-autoload
296(defun mh-toggle-tick (range)
297  "Toggle tick mark of RANGE.
298
299This command adds messages to the \"tick\" sequence (which you can customize
300via the option `mh-tick-seq'). This sequence can be viewed later with the
301\\[mh-index-ticked-messages] command.
302
303Check the documentation of `mh-interactive-range' to see how RANGE is read in
304interactive use."
305  (interactive (list (mh-interactive-range "Tick")))
306  (unless mh-tick-seq
307    (error "Enable ticking by customizing `mh-tick-seq'"))
308  (let* ((tick-seq (mh-find-seq mh-tick-seq))
309         (tick-seq-msgs (mh-seq-msgs tick-seq))
310         (ticked ())
311         (unticked ()))
312    (mh-iterate-on-range msg range
313      (cond ((member msg tick-seq-msgs)
314             (push msg unticked)
315             (setcdr tick-seq (delq msg (cdr tick-seq)))
316             (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
317             (mh-remove-sequence-notation msg (mh-colors-in-use-p)))
318            (t
319             (push msg ticked)
320             (setq mh-last-seq-used mh-tick-seq)
321             (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list)))
322               (mh-add-sequence-notation msg (mh-colors-in-use-p))))))
323    (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
324    (mh-undefine-sequence mh-tick-seq unticked)
325    (when mh-index-data
326      (mh-index-add-to-sequence mh-tick-seq ticked)
327      (mh-index-delete-from-sequence mh-tick-seq unticked))))
328
329;;;###mh-autoload
330(defun mh-widen (&optional all-flag)
331  "Remove last restriction.
332
333Each limit or sequence restriction can be undone in turn with
334this command. Give this command a prefix argument ALL-FLAG to
335remove all limits and sequence restrictions."
336  (interactive "P")
337  (let ((msg (mh-get-msg-num nil)))
338    (when mh-folder-view-stack
339      (cond (all-flag
340             (while (cdr mh-view-ops)
341               (setq mh-view-ops (cdr mh-view-ops)))
342             (when (eq (car mh-view-ops) 'widen)
343               (setq mh-view-ops (cdr mh-view-ops))))
344            ((mh-valid-view-change-operation-p 'widen) nil)
345            ((memq 'widen mh-view-ops)
346             (while (not (eq (car mh-view-ops) 'widen))
347               (setq mh-view-ops (cdr mh-view-ops)))
348             (setq mh-view-ops (cdr mh-view-ops)))
349            (t (error "Widening is not applicable")))
350      ;; If ALL-FLAG is non-nil then rewind stacks
351      (when all-flag
352        (while (cdr mh-thread-scan-line-map-stack)
353          (setq mh-thread-scan-line-map-stack
354                (cdr mh-thread-scan-line-map-stack)))
355        (while (cdr mh-folder-view-stack)
356          (setq mh-folder-view-stack (cdr mh-folder-view-stack))))
357      (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack))
358      (with-mh-folder-updating (t)
359        (delete-region (point-min) (point-max))
360        (insert (pop mh-folder-view-stack))
361        (mh-remove-all-notation)
362        (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
363        (mh-make-folder-mode-line))
364      (if msg
365          (mh-goto-msg msg t t))
366      (mh-notate-deleted-and-refiled)
367      (mh-notate-user-sequences)
368      (mh-notate-cur)
369      (mh-recenter nil)))
370  (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
371    (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
372    (when (buffer-live-p (get-buffer mh-show-buffer))
373      (with-current-buffer mh-show-buffer
374        (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
375
376
377
378;;; Support Routines
379
380(defvar mh-sequence-history ())
381
382;;;###mh-autoload
383(defun mh-read-seq-default (prompt not-empty)
384  "Read and return sequence name with default narrowed or previous sequence.
385PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil
386then a non-empty sequence is read."
387  (mh-read-seq prompt not-empty
388               (or mh-last-seq-used
389                   (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
390
391(defun mh-read-seq (prompt not-empty &optional default)
392  "Read and return a sequence name.
393Prompt with PROMPT, raise an error if the sequence is empty and
394the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
395sequence. A reply of '%' defaults to the first sequence
396containing the current message."
397  (let* ((input (completing-read (format "%s sequence%s: " prompt
398                                         (if default
399                                             (format " (default %s)" default)
400                                           ""))
401                                 (mh-seq-names mh-seq-list)
402                                 nil nil nil 'mh-sequence-history))
403         (seq (cond ((equal input "%")
404                     (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
405                    ((equal input "") default)
406                    (t (intern input))))
407         (msgs (mh-seq-to-msgs seq)))
408    (if (and (null msgs) not-empty)
409        (error "No messages in sequence %s" seq))
410    seq))
411
412(defun mh-internal-seq (name)
413  "Return non-nil if NAME is the name of an internal MH-E sequence."
414  (or (memq name mh-internal-seqs)
415      (eq name mh-unseen-seq)
416      (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq))
417      (eq name mh-previous-seq)
418      (mh-folder-name-p name)))
419
420;;;###mh-autoload
421(defun mh-valid-seq-p (name)
422  "Return non-nil if NAME is a valid MH sequence name."
423  (and (symbolp name)
424       (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name))))
425
426;;;###mh-autoload
427(defun mh-find-seq (name)
428  "Return sequence NAME."
429  (assoc name mh-seq-list))
430
431;;;###mh-autoload
432(defun mh-seq-to-msgs (seq)
433  "Return a list of the messages in SEQ."
434  (mh-seq-msgs (mh-find-seq seq)))
435
436(defun mh-seq-containing-msg (msg &optional include-internal-flag)
437  "Return a list of the sequences containing MSG.
438If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences
439in list."
440  (let ((l mh-seq-list)
441        (seqs ()))
442    (while l
443      (and (memq msg (mh-seq-msgs (car l)))
444           (or include-internal-flag
445               (not (mh-internal-seq (mh-seq-name (car l)))))
446           (setq seqs (cons (mh-seq-name (car l)) seqs)))
447      (setq l (cdr l)))
448    seqs))
449
450;;;###mh-autoload
451(defun mh-define-sequence (seq msgs)
452  "Define the SEQ to contain the list of MSGS.
453Do not mark pseudo-sequences or empty sequences.
454Signals an error if SEQ is an invalid name."
455  (if (and msgs
456           (mh-valid-seq-p seq)
457           (not (mh-folder-name-p seq)))
458      (save-excursion
459        (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero"
460                           "-sequence" (symbol-name seq)
461                           (mh-coalesce-msg-list msgs)))))
462
463;;;###mh-autoload
464(defun mh-undefine-sequence (seq msgs)
465  "Remove from the SEQ the list of MSGS."
466  (when (and (mh-valid-seq-p seq) msgs)
467    (apply #'mh-exec-cmd "mark" mh-current-folder "-delete"
468           "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))
469
470;;;###mh-autoload
471(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag)
472  "Add MSGS to SEQ.
473
474Remove duplicates and keep sequence sorted. If optional
475INTERNAL-FLAG is non-nil, do not mark the message in the scan
476listing or inform MH of the addition.
477
478If DONT-ANNOTATE-FLAG is non-nil then the annotations in the
479folder buffer are not updated."
480  (let ((entry (mh-find-seq seq))
481        (internal-seq-flag (mh-internal-seq seq)))
482    (if (and msgs (atom msgs)) (setq msgs (list msgs)))
483    (if (null entry)
484        (setq mh-seq-list
485              (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
486                    mh-seq-list))
487      (if msgs (setcdr entry (mh-canonicalize-sequence
488                              (append msgs (mh-seq-msgs entry))))))
489    (unless internal-flag
490      (mh-add-to-sequence seq msgs)
491      (when (not dont-annotate-flag)
492        (mh-iterate-on-range msg msgs
493          (unless (memq msg (cdr entry))
494            (mh-add-sequence-notation msg internal-seq-flag)))))))
495
496(defun mh-add-to-sequence (seq msgs)
497  "The sequence SEQ is augmented with the messages in MSGS."
498  ;; Add to a SEQUENCE each message the list of MSGS.
499  (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
500      (if msgs
501          (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
502                 "-sequence" (symbol-name seq)
503                 (mh-coalesce-msg-list msgs)))))
504
505(defun mh-canonicalize-sequence (msgs)
506  "Sort MSGS in decreasing order and remove duplicates."
507  (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
508         (head sorted-msgs))
509    (while (cdr head)
510      (if (= (car head) (cadr head))
511          (setcdr head (cddr head))
512        (setq head (cdr head))))
513    sorted-msgs))
514
515(defun mh-delete-a-msg-from-seq (msg sequence internal-flag)
516  "Delete MSG from SEQUENCE.
517If INTERNAL-FLAG is non-nil, then do not inform MH of the
518change."
519  (let ((entry (mh-find-seq sequence)))
520    (when (and entry (memq msg (mh-seq-msgs entry)))
521      (if (not internal-flag)
522          (mh-undefine-sequence sequence (list msg)))
523      (setcdr entry (delq msg (mh-seq-msgs entry))))))
524
525(defun mh-delete-seq-locally (seq)
526  "Remove MH-E's record of SEQ."
527  (let ((entry (mh-find-seq seq)))
528    (setq mh-seq-list (delq entry mh-seq-list))))
529
530(defun mh-copy-seq-to-eob (seq)
531  "Copy SEQ to the end of the buffer."
532  ;; It is quite involved to write something which will work at any place in
533  ;; the buffer, so we will write something which works only at the end of
534  ;; the buffer. If we ever need to insert sequences in the middle of the
535  ;; buffer, this will need to be fixed.
536  (save-excursion
537    (let* ((msgs (mh-seq-to-msgs seq))
538           (coalesced-msgs (mh-coalesce-msg-list msgs)))
539      (goto-char (point-max))
540      (save-restriction
541        (narrow-to-region (point) (point))
542        (mh-regenerate-headers coalesced-msgs t)
543        (cond ((memq 'unthread mh-view-ops)
544               ;; Populate restricted scan-line map
545               (mh-remove-all-notation)
546               (mh-iterate-on-range msg (cons (point-min) (point-max))
547                 (setf (gethash msg mh-thread-scan-line-map)
548                       (mh-thread-parse-scan-line)))
549               ;; Remove scan lines and read results from pre-computed tree
550               (delete-region (point-min) (point-max))
551               (mh-thread-print-scan-lines
552                (mh-thread-generate mh-current-folder ()))
553               (mh-notate-user-sequences))
554              (mh-index-data
555               (mh-index-insert-folder-headers)))))))
556
557;;;###mh-autoload
558(defun mh-valid-view-change-operation-p (op)
559  "Check if the view change operation can be performed.
560OP is one of 'widen and 'unthread."
561  (cond ((eq (car mh-view-ops) op)
562         (pop mh-view-ops))
563        (t nil)))
564
565
566
567;;; Ranges
568
569(defvar mh-range-seq-names)
570(defvar mh-range-history ())
571(defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
572(define-key mh-range-completion-map " " 'self-insert-command)
573
574;;;###mh-autoload
575(defun mh-interactive-range (range-prompt &optional default)
576  "Return interactive specification for message, sequence, range or region.
577By convention, the name of this argument is RANGE.
578
579If variable `transient-mark-mode' is non-nil and the mark is active,
580then this function returns a cons-cell of the region.
581
582If optional prefix argument is provided, then prompt for message range
583with RANGE-PROMPT. A list of messages in that range is returned.
584
585If a MH range is given, say something like last:20, then a list
586containing the messages in that range is returned.
587
588If DEFAULT non-nil then it is returned.
589
590Otherwise, the message number at point is returned.
591
592This function is usually used with `mh-iterate-on-range' in order to
593provide a uniform interface to MH-E functions."
594  (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
595        (current-prefix-arg (mh-read-range range-prompt nil nil t t))
596        (default default)
597        (t (mh-get-msg-num t))))
598
599;;;###mh-autoload
600(defun mh-read-range (prompt &optional folder default
601                             expand-flag ask-flag number-as-range-flag)
602  "Read a message range with PROMPT.
603
604If FOLDER is non-nil then a range is read from that folder, otherwise
605use `mh-current-folder'.
606
607If DEFAULT is a string then use that as default range to return. If
608DEFAULT is nil then ask user with default answer a range based on the
609sequences that seem relevant. Finally if DEFAULT is t, try to avoid
610prompting the user. Unseen messages, if present, are returned. If the
611folder has fewer than `mh-large-folder' messages then \"all\" messages
612are returned. Finally as a last resort prompt the user.
613
614If EXPAND-FLAG is non-nil then a list of message numbers corresponding
615to the input is returned. If this list is empty then an error is
616raised. If EXPAND-FLAG is nil just return the input string. In this
617case we don't check if the range is empty.
618
619If ASK-FLAG is non-nil, then the user is always queried for a range of
620messages. If ASK-FLAG is nil, then the function checks if the unseen
621sequence is non-empty. If that is the case, `mh-unseen-seq', or the
622list of messages in it depending on the value of EXPAND, is returned.
623Otherwise if the folder has fewer than `mh-large-folder' messages then
624the list of messages corresponding to \"all\" is returned. If neither
625of the above holds then as a last resort the user is queried for a
626range of messages.
627
628If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as
629input, it is interpreted as the range \"last:N\".
630
631This function replaces the existing function `mh-read-msg-range'.
632Calls to:
633
634  (mh-read-msg-range folder flag)
635
636should be replaced with:
637
638  (mh-read-range \"Suitable prompt\" folder t nil flag
639                 mh-interpret-number-as-range-flag)"
640  (setq default (or default mh-last-seq-used
641                    (car (mh-seq-containing-msg (mh-get-msg-num nil) t)))
642        prompt (format "%s range" prompt))
643  (let* ((folder (or folder mh-current-folder))
644         (guess (eq default t))
645         (counts (and guess (mh-folder-size folder)))
646         (unseen (and counts (> (cadr counts) 0)))
647         (large (and counts mh-large-folder (> (car counts) mh-large-folder)))
648         (default (cond ((and guess large) (format "last:%s" mh-large-folder))
649                        ((and guess (not large)) "all")
650                        ((stringp default) default)
651                        ((symbolp default) (symbol-name default))))
652         (prompt (cond ((and guess large default)
653                        (format "%s (folder has %s messages, default %s)"
654                                prompt (car counts) default))
655                       ((and guess large)
656                        (format "%s (folder has %s messages)"
657                                prompt (car counts)))
658                       (default
659                         (format "%s (default %s)" prompt default))))
660         (minibuffer-local-completion-map mh-range-completion-map)
661         (seq-list (if (eq folder mh-current-folder)
662                       mh-seq-list
663                     (mh-read-folder-sequences folder nil)))
664         (mh-range-seq-names
665          (append '(("first") ("last") ("all") ("prev") ("next"))
666                  (mh-seq-names seq-list)))
667         (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
668                      ((and (not ask-flag) (not large)) "all")
669                      (t (completing-read (format "%s: " prompt)
670                                          'mh-range-completion-function nil nil
671                                          nil 'mh-range-history default))))
672         msg-list)
673    (when (and number-as-range-flag
674               (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input))
675      (setq input (concat "last:" (match-string 1 input))))
676    (cond ((not expand-flag) input)
677          ((assoc (intern input) seq-list)
678           (cdr (assoc (intern input) seq-list)))
679          ((setq msg-list (mh-translate-range folder input)) msg-list)
680          (t (error "No messages in range %s" input)))))
681
682;;;###mh-autoload
683(defun mh-range-to-msg-list (range)
684  "Return a list of messages for RANGE.
685
686Check the documentation of `mh-interactive-range' to see how
687RANGE is read in interactive use."
688  (let (msg-list)
689    (mh-iterate-on-range msg range
690      (push msg msg-list))
691    (nreverse msg-list)))
692
693;;;###mh-autoload
694(defun mh-translate-range (folder expr)
695  "In FOLDER, translate the string EXPR to a list of messages numbers."
696  (save-excursion
697    (let ((strings (delete "" (split-string expr "[ \t\n]")))
698          (result ()))
699      (ignore-errors
700        (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings)
701        (set-buffer mh-temp-buffer)
702        (goto-char (point-min))
703        (while (re-search-forward "/\\([0-9]*\\)$" nil t)
704          (push (string-to-number (match-string 1)) result))
705        (nreverse result)))))
706
707(defun mh-range-completion-function (string predicate flag)
708  "Programmable completion of message ranges.
709STRING is the user input that is to be completed. PREDICATE if non-nil is a
710function used to filter the possible choices and FLAG determines whether the
711completion is over."
712  (let* ((candidates mh-range-seq-names)
713         (last-char (and (not (equal string ""))
714                         (aref string (1- (length string)))))
715         (last-word (cond ((null last-char) "")
716                          ((memq last-char '(?  ?- ?:)) "")
717                          (t (car (last (split-string string "[ -:]+"))))))
718         (prefix (substring string 0 (- (length string) (length last-word)))))
719    (cond ((eq flag nil)
720           (let ((res (try-completion last-word candidates predicate)))
721             (cond ((null res) nil)
722                   ((eq res t) t)
723                   (t (concat prefix res)))))
724          ((eq flag t)
725           (all-completions last-word candidates predicate))
726          ((eq flag 'lambda)
727           (loop for x in candidates
728                 when (equal x last-word) return t
729                 finally return nil)))))
730
731(defun mh-seq-names (seq-list)
732  "Return an alist containing the names of the SEQ-LIST."
733  (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))
734          seq-list))
735
736(defun mh-folder-size (folder)
737  "Find size of FOLDER."
738  (if mh-flists-present-flag
739      (mh-folder-size-flist folder)
740    (mh-folder-size-folder folder)))
741
742(defun mh-folder-size-flist (folder)
743  "Find size of FOLDER using \"flist\"."
744  (with-temp-buffer
745    (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero"
746                  "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq))
747    (goto-char (point-min))
748    (multiple-value-bind (folder unseen total)
749        (mh-parse-flist-output-line
750         (buffer-substring (point) (mh-line-end-position)))
751      (values total unseen folder))))
752
753(defun mh-folder-size-folder (folder)
754  "Find size of FOLDER using \"folder\"."
755  (with-temp-buffer
756    (let ((u (length (cdr (assoc mh-unseen-seq
757                                 (mh-read-folder-sequences folder nil))))))
758      (call-process (expand-file-name "folder" mh-progs) nil t nil
759                    "-norecurse" folder)
760      (goto-char (point-min))
761      (if (re-search-forward " has \\([0-9]+\\) " nil t)
762          (values (string-to-number (match-string 1)) u folder)
763        (values 0 u folder)))))
764
765;;;###mh-autoload
766(defun mh-parse-flist-output-line (line &optional current-folder)
767  "Parse LINE to generate folder name, unseen messages and total messages.
768If CURRENT-FOLDER is non-nil then it contains the current folder
769name and it is used to avoid problems in corner cases involving
770folders whose names end with a '+' character."
771  (with-temp-buffer
772    (insert line)
773    (goto-char (point-max))
774    (let (folder unseen total p)
775      (when (search-backward " out of " (point-min) t)
776        (setq total (string-to-number
777                     (buffer-substring-no-properties
778                      (match-end 0) (mh-line-end-position))))
779        (when (search-backward " in sequence " (point-min) t)
780          (setq p (point))
781          (when (search-backward " has " (point-min) t)
782            (setq unseen (string-to-number (buffer-substring-no-properties
783                                            (match-end 0) p)))
784            (while (eq (char-after) ? )
785              (backward-char))
786            (setq folder (buffer-substring-no-properties
787                          (point-min) (1+ (point))))
788            (when (and (equal (aref folder (1- (length folder))) ?+)
789                       (equal current-folder folder))
790              (setq folder (substring folder 0 (1- (length folder)))))
791            (values (format "+%s" folder) unseen total)))))))
792
793;;;###mh-autoload
794(defun mh-read-folder-sequences (folder save-refiles)
795  "Read and return the predefined sequences for a FOLDER.
796If SAVE-REFILES is non-nil, then keep the sequences
797that note messages to be refiled."
798  (let ((seqs ()))
799    (cond (save-refiles
800           (mh-mapc (function (lambda (seq) ; Save the refiling sequences
801                                (if (mh-folder-name-p (mh-seq-name seq))
802                                    (setq seqs (cons seq seqs)))))
803                    mh-seq-list)))
804    (save-excursion
805      (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list"))
806          (progn
807            ;; look for name in line of form "cur: 4" or "myseq (private): 23"
808            (while (re-search-forward "^[^: ]+" nil t)
809              (setq seqs (cons (mh-make-seq (intern (buffer-substring
810                                                     (match-beginning 0)
811                                                     (match-end 0)))
812                                            (mh-read-msg-list))
813                               seqs)))
814            (delete-region (point-min) (point))))) ; avoid race with
815                                        ; mh-process-daemon
816    seqs))
817
818(defun mh-read-msg-list ()
819  "Return a list of message numbers from point to the end of the line.
820Expands ranges into set of individual numbers."
821  (let ((msgs ())
822        (end-of-line (save-excursion (end-of-line) (point)))
823        num)
824    (while (re-search-forward "[0-9]+" end-of-line t)
825      (setq num (string-to-number (buffer-substring (match-beginning 0)
826                                                    (match-end 0))))
827      (cond ((looking-at "-")           ; Message range
828             (forward-char 1)
829             (re-search-forward "[0-9]+" end-of-line t)
830             (let ((num2 (string-to-number
831                          (buffer-substring (match-beginning 0)
832                                            (match-end 0)))))
833               (if (< num2 num)
834                   (error "Bad message range: %d-%d" num num2))
835               (while (<= num num2)
836                 (setq msgs (cons num msgs))
837                 (setq num (1+ num)))))
838            ((not (zerop num))          ;"pick" outputs "0" to mean no match
839             (setq msgs (cons num msgs)))))
840    msgs))
841
842
843
844;;; Notation
845
846;;;###mh-autoload
847(defun mh-notate (msg notation offset)
848  "Mark MSG with the character NOTATION at position OFFSET.
849Null MSG means the message at cursor.
850If NOTATION is nil then no change in the buffer occurs."
851  (save-excursion
852    (if (or (null msg)
853            (mh-goto-msg msg t t))
854        (with-mh-folder-updating (t)
855          (beginning-of-line)
856          (forward-char offset)
857          (let* ((change-stack-flag
858                  (and (equal offset
859                              (+ mh-cmd-note mh-scan-field-destination-offset))
860                       (not (eq notation mh-note-seq))))
861                 (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
862                 (stack (and msg (gethash msg mh-sequence-notation-history)))
863                 (notation (or notation (char-after))))
864            (if stack
865                ;; The presence of the stack tells us that we don't need to
866                ;; notate the message, since the notation would be replaced
867                ;; by a sequence notation. So we will just put the notation
868                ;; at the bottom of the stack. If the sequence is deleted,
869                ;; the correct notation will be shown.
870                (setf (gethash msg mh-sequence-notation-history)
871                      (reverse (cons notation (cdr (reverse stack)))))
872              ;; Since we don't have any sequence notations in the way, just
873              ;; notate the scan line.
874              (delete-char 1)
875              (insert notation))
876            (when change-stack-flag
877              (mh-thread-update-scan-line-map msg notation offset)))))))
878
879;;;###mh-autoload
880(defun mh-notate-cur ()
881  "Mark the MH sequence cur.
882In addition to notating the current message with `mh-note-cur'
883the function uses `overlay-arrow-position' to put a marker in the
884fringe."
885  (let ((cur (car (mh-seq-to-msgs 'cur))))
886    (when (and cur (mh-goto-msg cur t t))
887      (beginning-of-line)
888      (when (looking-at mh-scan-good-msg-regexp)
889        (mh-notate nil mh-note-cur mh-cmd-note))
890      (setq mh-arrow-marker (set-marker mh-arrow-marker (point)))
891      (setq overlay-arrow-position mh-arrow-marker))))
892
893;;;###mh-autoload
894(defun mh-remove-cur-notation ()
895  "Remove old cur notation."
896  (let ((cur-msg (car (mh-seq-to-msgs 'cur))))
897    (save-excursion
898      (when (and cur-msg
899                 (mh-goto-msg cur-msg t t)
900                 (looking-at mh-scan-cur-msg-number-regexp))
901        (mh-notate nil ?  mh-cmd-note)
902        (setq overlay-arrow-position nil)))))
903
904;; FIXME?  We may want to clear all notations and add one for current-message
905;;         and process user sequences.
906;;;###mh-autoload
907(defun mh-notate-deleted-and-refiled ()
908  "Notate messages marked for deletion or refiling.
909Messages to be deleted are given by `mh-delete-list' while
910messages to be refiled are present in `mh-refile-list'."
911  (let ((refiled-hash (make-hash-table))
912        (deleted-hash (make-hash-table)))
913    (dolist (msg mh-delete-list)
914      (setf (gethash msg deleted-hash) t))
915    (dolist (dest-msg-list mh-refile-list)
916      (dolist (msg (cdr dest-msg-list))
917        (setf (gethash msg refiled-hash) t)))
918    (mh-iterate-on-messages-in-region msg (point-min) (point-max)
919      (cond ((gethash msg refiled-hash)
920             (mh-notate nil mh-note-refiled mh-cmd-note))
921            ((gethash msg deleted-hash)
922             (mh-notate nil mh-note-deleted mh-cmd-note))))))
923
924;;;###mh-autoload
925(defun mh-notate-user-sequences (&optional range)
926  "Mark user-defined sequences in RANGE.
927
928Check the documentation of `mh-interactive-range' to see how
929RANGE is read in interactive use; if nil all messages are
930notated."
931  (unless range
932    (setq range (cons (point-min) (point-max))))
933  (let ((seqs mh-seq-list)
934        (msg-hash (make-hash-table)))
935    (dolist (seq seqs)
936      (dolist (msg (mh-seq-msgs seq))
937        (push (car seq) (gethash msg msg-hash))))
938    (mh-iterate-on-range msg range
939      (loop for seq in (gethash msg msg-hash)
940            do (mh-add-sequence-notation msg (mh-internal-seq seq))))))
941
942(defun mh-add-sequence-notation (msg internal-seq-flag)
943  "Add sequence notation to the MSG on the current line.
944If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if
945font-lock is turned on."
946  (with-mh-folder-updating (t)
947    (save-excursion
948      (beginning-of-line)
949      (if internal-seq-flag
950          (progn
951            ;; Change the buffer so that if transient-mark-mode is active
952            ;; and there is an active region it will get deactivated as in
953            ;; the case of user sequences.
954            (mh-notate nil nil mh-cmd-note)
955            (when font-lock-mode
956              (font-lock-fontify-region (point) (mh-line-end-position))))
957        (forward-char (+ mh-cmd-note mh-scan-field-destination-offset))
958        (let ((stack (gethash msg mh-sequence-notation-history)))
959          (setf (gethash msg mh-sequence-notation-history)
960                (cons (char-after) stack)))
961        (mh-notate nil mh-note-seq
962                   (+ mh-cmd-note mh-scan-field-destination-offset))))))
963
964(defun mh-remove-sequence-notation (msg internal-seq-flag &optional all)
965  "Remove sequence notation from the MSG on the current line.
966If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to
967highlight the sequence. In that case, no notation needs to be removed.
968Otherwise the effect of inserting `mh-note-seq' needs to be reversed.
969If ALL is non-nil, then all sequence marks on the scan line are
970removed."
971  (with-mh-folder-updating (t)
972    ;; This takes care of internal sequences...
973    (mh-notate nil nil mh-cmd-note)
974    (unless internal-seq-flag
975      ;; ... and this takes care of user sequences.
976      (let ((stack (gethash msg mh-sequence-notation-history)))
977        (while (and all (cdr stack))
978          (setq stack (cdr stack)))
979        (when stack
980          (save-excursion
981            (beginning-of-line)
982            (forward-char (+ mh-cmd-note mh-scan-field-destination-offset))
983            (delete-char 1)
984            (insert (car stack))))
985        (setf (gethash msg mh-sequence-notation-history) (cdr stack))))))
986
987;;;###mh-autoload
988(defun mh-remove-all-notation ()
989  "Remove all notations on all scan lines that MH-E introduces."
990  (save-excursion
991    (setq overlay-arrow-position nil)
992    (goto-char (point-min))
993    (mh-iterate-on-range msg (cons (point-min) (point-max))
994      (mh-notate nil ?  mh-cmd-note)
995      (mh-remove-sequence-notation msg nil t))
996    (clrhash mh-sequence-notation-history)))
997
998
999
1000;; XXX Unused, delete, or create bind key?
1001(defun mh-rename-seq (sequence new-name)
1002  "Rename SEQUENCE to have NEW-NAME."
1003  (interactive (list (mh-read-seq "Old" t)
1004                     (intern (read-string "New sequence name: "))))
1005  (let ((old-seq (mh-find-seq sequence)))
1006    (or old-seq
1007        (error "Sequence %s does not exist" sequence))
1008    ;; Create new sequence first, since it might raise an error.
1009    (mh-define-sequence new-name (mh-seq-msgs old-seq))
1010    (mh-undefine-sequence sequence (mh-seq-msgs old-seq))
1011    (rplaca old-seq new-name)))
1012
1013(provide 'mh-seq)
1014
1015;; Local Variables:
1016;; indent-tabs-mode: nil
1017;; sentence-end-double-space: nil
1018;; End:
1019
1020;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942
1021;;; mh-seq.el ends here
1022