1 ;;; mh-seq.el --- MH-E sequences support
3 ;; Copyright (C) 1993, 1995,
4 ;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
6 ;; Author: Bill Wohler <wohler@newt.com>
7 ;; Maintainer: Bill Wohler <wohler@newt.com>
11 ;; This file is part of GNU Emacs.
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)
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.
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.
30 ;; Sequences are stored in the alist `mh-seq-list' in the form:
31 ;; ((seq-name msgs ...) (seq-name msgs ...) ...)
45 (defvar mh-last-seq-used nil
46 "Name of seq to which a msg was last added.")
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
)
52 (defvar mh-internal-seqs
'(answered cur deleted forwarded printed
))
56 (defmacro mh-make-seq
(name msgs
)
57 "Create sequence NAME with the given MSGS."
58 (list 'cons name msgs
))
60 (defmacro mh-seq-name
(sequence)
61 "Extract sequence name from the given SEQUENCE."
66 ;;; MH-Folder Commands
71 (defun mh-catchup (range)
72 "Delete RANGE from the \"unseen\" sequence.
74 Check the documentation of `mh-interactive-range' to see how
75 RANGE 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
))
81 (defun mh-delete-msg-from-seq (range sequence
&optional internal-flag
)
82 "Delete RANGE from SEQUENCE.
84 Check the documentation of `mh-interactive-range' to see how
85 RANGE is read in interactive use.
87 In a program, non-nil INTERNAL-FLAG means do not inform MH of the
89 (interactive (list (mh-interactive-range "Delete")
90 (mh-read-seq-default "Delete from" t
)
92 (let ((entry (mh-find-seq sequence
))
93 (user-sequence-flag (not (mh-internal-seq sequence
)))
94 (folders-changed (list mh-current-folder
))
97 (mh-iterate-on-range msg range
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
)))))
114 (defun mh-delete-seq (sequence)
117 You are prompted for the sequence to delete. Note that this
118 deletes only the sequence, not the messages in the sequence. If
119 you 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
)
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
))))
137 (eval-when-compile (defvar view-exit-action
))
140 (defun mh-list-sequences ()
141 "List all sequences in folder.
143 The list appears in a buffer named \"*MH-E Sequences*\"."
145 (let ((folder mh-current-folder
)
146 (temp-buffer mh-sequences-buffer
)
147 (seq-list mh-seq-list
)
149 (with-output-to-temp-buffer temp-buffer
151 (set-buffer temp-buffer
)
153 (message "Listing sequences ...")
154 (insert "Sequences in folder " folder
":\n")
155 (let ((seq-list seq-list
))
158 (max (length (symbol-name (mh-seq-name (pop seq-list
))))
160 (setq max-len
(+ 2 max-len
)))
162 (let ((name (mh-seq-name (car seq-list
)))
164 (mh-coalesce-msg-list
165 (sort (copy-sequence (mh-seq-msgs (car seq-list
))) '<)))
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
))
173 (insert (format (format "%%%ss" (length name-spec
)) "")))
174 (insert next-element
)))
176 (setq seq-list
(cdr seq-list
)))
177 (goto-char (point-min))
179 (setq view-exit-action
'kill-buffer
)
180 (message "Listing sequences...done")))))
183 (defun mh-msg-is-in-seq (message)
184 "Display the sequences in which the current message appears.
186 Use a prefix argument to display the sequences in which another
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
)
194 (deleted-flag (unless dest-folder
(member message mh-delete-list
))))
195 (message "Message %d%s is in sequences: %s"
197 (cond (dest-folder (format " (to be refiled to %s)" dest-folder
))
198 (deleted-flag (format " (to be deleted)"))
201 (mh-list-to-string (mh-seq-containing-msg message t
))
205 (eval-when-compile (mh-do-in-xemacs (defvar tool-bar-mode
)))
208 (defun mh-narrow-to-seq (sequence)
209 "Restrict display to messages in SEQUENCE.
211 You are prompted for the name of the sequence. What this command
212 does is show only those messages that are in the selected
213 sequence in the MH-Folder buffer. In addition, it limits further
214 MH-E searches to just those messages.
216 When you want to widen the view to all your messages again, use
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)
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)
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
))
242 (set-buffer (get-buffer mh-show-buffer
))
243 (set (make-local-variable 'tool-bar-map
)
244 mh-show-seq-tool-bar-map
))))
245 (push 'widen mh-view-ops
)))
247 (error "No messages in sequence %s" (symbol-name sequence
))))))
250 (defun mh-narrow-to-tick ()
251 "Limit to ticked messages.
253 What this command does is show only those messages that are in
254 the \"tick\" sequence (which you can customize via the
255 `mh-tick-seq' option) in the MH-Folder buffer. In addition, it
256 limits further MH-E searches to just those messages. When you
257 want to widen the view to all your messages again, use
260 (cond ((not mh-tick-seq
)
261 (error "Enable ticking by customizing `mh-tick-seq'"))
262 ((null (mh-seq-msgs (mh-find-seq mh-tick-seq
)))
263 (message "No messages in %s sequence" mh-tick-seq
))
264 (t (mh-narrow-to-seq mh-tick-seq
))))
267 (defun mh-put-msg-in-seq (range sequence
)
268 "Add RANGE to SEQUENCE\\<mh-folder-mode-map>.
270 Give this command a RANGE and you can add all the messages in a
271 sequence to another sequence (for example,
272 \"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET
273 DestSequence RET\"). Check the documentation of
274 `mh-interactive-range' to see how RANGE is read in interactive
276 (interactive (list (mh-interactive-range "Add messages from")
277 (mh-read-seq-default "Add to" nil
)))
278 (unless (mh-valid-seq-p sequence
)
279 (error "Can't put message in invalid sequence %s" sequence
))
280 (let* ((internal-seq-flag (mh-internal-seq sequence
))
281 (original-msgs (mh-seq-msgs (mh-find-seq sequence
)))
282 (folders (list mh-current-folder
))
283 (msg-list (mh-range-to-msg-list range
)))
284 (mh-add-msgs-to-seq msg-list sequence nil t
)
285 (mh-iterate-on-range m range
286 (unless (memq m original-msgs
)
287 (mh-add-sequence-notation m internal-seq-flag
)))
288 (if (not internal-seq-flag
)
289 (setq mh-last-seq-used sequence
))
292 (append folders
(mh-index-add-to-sequence sequence msg-list
))))
293 (when (and (eq sequence mh-unseen-seq
) (mh-speed-flists-active-p))
294 (apply #'mh-speed-flists t folders
))))
297 (defun mh-toggle-tick (range)
298 "Toggle tick mark of RANGE.
300 This command adds messages to the \"tick\" sequence (which you can customize
301 via the option `mh-tick-seq'). This sequence can be viewed later with the
302 \\[mh-index-ticked-messages] command.
304 Check the documentation of `mh-interactive-range' to see how RANGE is read in
306 (interactive (list (mh-interactive-range "Tick")))
308 (error "Enable ticking by customizing `mh-tick-seq'"))
309 (let* ((tick-seq (mh-find-seq mh-tick-seq
))
310 (tick-seq-msgs (mh-seq-msgs tick-seq
))
313 (mh-iterate-on-range msg range
314 (cond ((member msg tick-seq-msgs
)
316 (setcdr tick-seq
(delq msg
(cdr tick-seq
)))
317 (when (null (cdr tick-seq
)) (setq mh-last-seq-used nil
))
318 (mh-remove-sequence-notation msg
(mh-colors-in-use-p)))
321 (setq mh-last-seq-used mh-tick-seq
)
322 (let ((mh-seq-list (cons `(,mh-tick-seq
,msg
) mh-seq-list
)))
323 (mh-add-sequence-notation msg
(mh-colors-in-use-p))))))
324 (mh-add-msgs-to-seq ticked mh-tick-seq nil t
)
325 (mh-undefine-sequence mh-tick-seq unticked
)
327 (mh-index-add-to-sequence mh-tick-seq ticked
)
328 (mh-index-delete-from-sequence mh-tick-seq unticked
))))
331 (defun mh-widen (&optional all-flag
)
332 "Remove last restriction.
334 Each limit or sequence restriction can be undone in turn with
335 this command. Give this command a prefix argument ALL-FLAG to
336 remove all limits and sequence restrictions."
338 (let ((msg (mh-get-msg-num nil
)))
339 (when mh-folder-view-stack
341 (while (cdr mh-view-ops
)
342 (setq mh-view-ops
(cdr mh-view-ops
)))
343 (when (eq (car mh-view-ops
) 'widen
)
344 (setq mh-view-ops
(cdr mh-view-ops
))))
345 ((mh-valid-view-change-operation-p 'widen
) nil
)
346 ((memq 'widen mh-view-ops
)
347 (while (not (eq (car mh-view-ops
) 'widen
))
348 (setq mh-view-ops
(cdr mh-view-ops
)))
349 (setq mh-view-ops
(cdr mh-view-ops
)))
350 (t (error "Widening is not applicable")))
351 ;; If ALL-FLAG is non-nil then rewind stacks
353 (while (cdr mh-thread-scan-line-map-stack
)
354 (setq mh-thread-scan-line-map-stack
355 (cdr mh-thread-scan-line-map-stack
)))
356 (while (cdr mh-folder-view-stack
)
357 (setq mh-folder-view-stack
(cdr mh-folder-view-stack
))))
358 (setq mh-thread-scan-line-map
(pop mh-thread-scan-line-map-stack
))
359 (with-mh-folder-updating (t)
360 (delete-region (point-min) (point-max))
361 (insert (pop mh-folder-view-stack
))
362 (mh-remove-all-notation)
363 (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation
)
364 (mh-make-folder-mode-line))
366 (mh-goto-msg msg t t
))
367 (mh-notate-deleted-and-refiled)
368 (mh-notate-user-sequences)
371 (when (and (null mh-folder-view-stack
) (boundp 'tool-bar-mode
) tool-bar-mode
)
372 (set (make-local-variable 'tool-bar-map
) mh-folder-tool-bar-map
)
373 (when (buffer-live-p (get-buffer mh-show-buffer
))
375 (set-buffer (get-buffer mh-show-buffer
))
376 (set (make-local-variable 'tool-bar-map
) mh-show-tool-bar-map
)))))
382 (defvar mh-sequence-history
())
385 (defun mh-read-seq-default (prompt not-empty
)
386 "Read and return sequence name with default narrowed or previous sequence.
387 PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil
388 then a non-empty sequence is read."
389 (mh-read-seq prompt not-empty
391 (car (mh-seq-containing-msg (mh-get-msg-num nil
) nil
)))))
393 (defun mh-read-seq (prompt not-empty
&optional default
)
394 "Read and return a sequence name.
395 Prompt with PROMPT, raise an error if the sequence is empty and
396 the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
397 sequence. A reply of '%' defaults to the first sequence
398 containing the current message."
399 (let* ((input (completing-read (format "%s sequence%s: " prompt
401 (format " (default %s)" default
)
403 (mh-seq-names mh-seq-list
)
404 nil nil nil
'mh-sequence-history
))
405 (seq (cond ((equal input
"%")
406 (car (mh-seq-containing-msg (mh-get-msg-num t
) nil
)))
407 ((equal input
"") default
)
409 (msgs (mh-seq-to-msgs seq
)))
410 (if (and (null msgs
) not-empty
)
411 (error "No messages in sequence %s" seq
))
414 (defun mh-internal-seq (name)
415 "Return non-nil if NAME is the name of an internal MH-E sequence."
416 (or (memq name mh-internal-seqs
)
417 (eq name mh-unseen-seq
)
418 (and (mh-colors-in-use-p) mh-tick-seq
(eq name mh-tick-seq
))
419 (eq name mh-previous-seq
)
420 (mh-folder-name-p name
)))
423 (defun mh-valid-seq-p (name)
424 "Return non-nil if NAME is a valid MH sequence name."
426 (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name
))))
429 (defun mh-find-seq (name)
430 "Return sequence NAME."
431 (assoc name mh-seq-list
))
434 (defun mh-seq-to-msgs (seq)
435 "Return a list of the messages in SEQ."
436 (mh-seq-msgs (mh-find-seq seq
)))
438 (defun mh-seq-containing-msg (msg &optional include-internal-flag
)
439 "Return a list of the sequences containing MSG.
440 If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences
442 (let ((l mh-seq-list
)
445 (and (memq msg
(mh-seq-msgs (car l
)))
446 (or include-internal-flag
447 (not (mh-internal-seq (mh-seq-name (car l
)))))
448 (setq seqs
(cons (mh-seq-name (car l
)) seqs
)))
453 (defun mh-define-sequence (seq msgs
)
454 "Define the SEQ to contain the list of MSGS.
455 Do not mark pseudo-sequences or empty sequences.
456 Signals an error if SEQ is an invalid name."
459 (not (mh-folder-name-p seq
)))
461 (mh-exec-cmd-error nil
"mark" mh-current-folder
"-add" "-zero"
462 "-sequence" (symbol-name seq
)
463 (mh-coalesce-msg-list msgs
)))))
466 (defun mh-undefine-sequence (seq msgs
)
467 "Remove from the SEQ the list of MSGS."
468 (when (and (mh-valid-seq-p seq
) msgs
)
469 (apply #'mh-exec-cmd
"mark" mh-current-folder
"-delete"
470 "-sequence" (symbol-name seq
) (mh-coalesce-msg-list msgs
))))
473 (defun mh-add-msgs-to-seq (msgs seq
&optional internal-flag dont-annotate-flag
)
476 Remove duplicates and keep sequence sorted. If optional
477 INTERNAL-FLAG is non-nil, do not mark the message in the scan
478 listing or inform MH of the addition.
480 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the
481 folder buffer are not updated."
482 (let ((entry (mh-find-seq seq
))
483 (internal-seq-flag (mh-internal-seq seq
)))
484 (if (and msgs
(atom msgs
)) (setq msgs
(list msgs
)))
487 (cons (mh-make-seq seq
(mh-canonicalize-sequence msgs
))
489 (if msgs
(setcdr entry
(mh-canonicalize-sequence
490 (append msgs
(mh-seq-msgs entry
))))))
491 (unless internal-flag
492 (mh-add-to-sequence seq msgs
)
493 (when (not dont-annotate-flag
)
494 (mh-iterate-on-range msg msgs
495 (unless (memq msg
(cdr entry
))
496 (mh-add-sequence-notation msg internal-seq-flag
)))))))
498 (defun mh-add-to-sequence (seq msgs
)
499 "The sequence SEQ is augmented with the messages in MSGS."
500 ;; Add to a SEQUENCE each message the list of MSGS.
501 (if (and (mh-valid-seq-p seq
) (not (mh-folder-name-p seq
)))
503 (apply 'mh-exec-cmd
"mark" mh-current-folder
"-add"
504 "-sequence" (symbol-name seq
)
505 (mh-coalesce-msg-list msgs
)))))
507 (defun mh-canonicalize-sequence (msgs)
508 "Sort MSGS in decreasing order and remove duplicates."
509 (let* ((sorted-msgs (sort (copy-sequence msgs
) '>))
512 (if (= (car head
) (cadr head
))
513 (setcdr head
(cddr head
))
514 (setq head
(cdr head
))))
517 (defun mh-delete-a-msg-from-seq (msg sequence internal-flag
)
518 "Delete MSG from SEQUENCE.
519 If INTERNAL-FLAG is non-nil, then do not inform MH of the
521 (let ((entry (mh-find-seq sequence
)))
522 (when (and entry
(memq msg
(mh-seq-msgs entry
)))
523 (if (not internal-flag
)
524 (mh-undefine-sequence sequence
(list msg
)))
525 (setcdr entry
(delq msg
(mh-seq-msgs entry
))))))
527 (defun mh-delete-seq-locally (seq)
528 "Remove MH-E's record of SEQ."
529 (let ((entry (mh-find-seq seq
)))
530 (setq mh-seq-list
(delq entry mh-seq-list
))))
532 (defun mh-copy-seq-to-eob (seq)
533 "Copy SEQ to the end of the buffer."
534 ;; It is quite involved to write something which will work at any place in
535 ;; the buffer, so we will write something which works only at the end of
536 ;; the buffer. If we ever need to insert sequences in the middle of the
537 ;; buffer, this will need to be fixed.
539 (let* ((msgs (mh-seq-to-msgs seq
))
540 (coalesced-msgs (mh-coalesce-msg-list msgs
)))
541 (goto-char (point-max))
543 (narrow-to-region (point) (point))
544 (mh-regenerate-headers coalesced-msgs t
)
545 (cond ((memq 'unthread mh-view-ops
)
546 ;; Populate restricted scan-line map
547 (mh-remove-all-notation)
548 (mh-iterate-on-range msg
(cons (point-min) (point-max))
549 (setf (gethash msg mh-thread-scan-line-map
)
550 (mh-thread-parse-scan-line)))
551 ;; Remove scan lines and read results from pre-computed tree
552 (delete-region (point-min) (point-max))
553 (mh-thread-print-scan-lines
554 (mh-thread-generate mh-current-folder
()))
555 (mh-notate-user-sequences))
557 (mh-index-insert-folder-headers)))))))
560 (defun mh-valid-view-change-operation-p (op)
561 "Check if the view change operation can be performed.
562 OP is one of 'widen and 'unthread."
563 (cond ((eq (car mh-view-ops
) op
)
571 (defvar mh-range-seq-names
)
572 (defvar mh-range-history
())
573 (defvar mh-range-completion-map
(copy-keymap minibuffer-local-completion-map
))
574 (define-key mh-range-completion-map
" " 'self-insert-command
)
577 (defun mh-interactive-range (range-prompt &optional default
)
578 "Return interactive specification for message, sequence, range or region.
579 By convention, the name of this argument is RANGE.
581 If variable `transient-mark-mode' is non-nil and the mark is active,
582 then this function returns a cons-cell of the region.
584 If optional prefix argument is provided, then prompt for message range
585 with RANGE-PROMPT. A list of messages in that range is returned.
587 If a MH range is given, say something like last:20, then a list
588 containing the messages in that range is returned.
590 If DEFAULT non-nil then it is returned.
592 Otherwise, the message number at point is returned.
594 This function is usually used with `mh-iterate-on-range' in order to
595 provide a uniform interface to MH-E functions."
596 (cond ((mh-mark-active-p t
) (cons (region-beginning) (region-end)))
597 (current-prefix-arg (mh-read-range range-prompt nil nil t t
))
599 (t (mh-get-msg-num t
))))
602 (defun mh-read-range (prompt &optional folder default
603 expand-flag ask-flag number-as-range-flag
)
604 "Read a message range with PROMPT.
606 If FOLDER is non-nil then a range is read from that folder, otherwise
607 use `mh-current-folder'.
609 If DEFAULT is a string then use that as default range to return. If
610 DEFAULT is nil then ask user with default answer a range based on the
611 sequences that seem relevant. Finally if DEFAULT is t, try to avoid
612 prompting the user. Unseen messages, if present, are returned. If the
613 folder has fewer than `mh-large-folder' messages then \"all\" messages
614 are returned. Finally as a last resort prompt the user.
616 If EXPAND-FLAG is non-nil then a list of message numbers corresponding
617 to the input is returned. If this list is empty then an error is
618 raised. If EXPAND-FLAG is nil just return the input string. In this
619 case we don't check if the range is empty.
621 If ASK-FLAG is non-nil, then the user is always queried for a range of
622 messages. If ASK-FLAG is nil, then the function checks if the unseen
623 sequence is non-empty. If that is the case, `mh-unseen-seq', or the
624 list of messages in it depending on the value of EXPAND, is returned.
625 Otherwise if the folder has fewer than `mh-large-folder' messages then
626 the list of messages corresponding to \"all\" is returned. If neither
627 of the above holds then as a last resort the user is queried for a
630 If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as
631 input, it is interpreted as the range \"last:N\".
633 This function replaces the existing function `mh-read-msg-range'.
636 (mh-read-msg-range folder flag)
638 should be replaced with:
640 (mh-read-range \"Suitable prompt\" folder t nil flag
641 mh-interpret-number-as-range-flag)"
642 (setq default
(or default mh-last-seq-used
643 (car (mh-seq-containing-msg (mh-get-msg-num nil
) t
)))
644 prompt
(format "%s range" prompt
))
645 (let* ((folder (or folder mh-current-folder
))
646 (guess (eq default t
))
647 (counts (and guess
(mh-folder-size folder
)))
648 (unseen (and counts
(> (cadr counts
) 0)))
649 (large (and counts mh-large-folder
(> (car counts
) mh-large-folder
)))
650 (default (cond ((and guess large
) (format "last:%s" mh-large-folder
))
651 ((and guess
(not large
)) "all")
652 ((stringp default
) default
)
653 ((symbolp default
) (symbol-name default
))))
654 (prompt (cond ((and guess large default
)
655 (format "%s (folder has %s messages, default %s)"
656 prompt
(car counts
) default
))
658 (format "%s (folder has %s messages)"
659 prompt
(car counts
)))
661 (format "%s (default %s)" prompt default
))))
662 (minibuffer-local-completion-map mh-range-completion-map
)
663 (seq-list (if (eq folder mh-current-folder
)
665 (mh-read-folder-sequences folder nil
)))
667 (append '(("first") ("last") ("all") ("prev") ("next"))
668 (mh-seq-names seq-list
)))
669 (input (cond ((and (not ask-flag
) unseen
) (symbol-name mh-unseen-seq
))
670 ((and (not ask-flag
) (not large
)) "all")
671 (t (completing-read (format "%s: " prompt
)
672 'mh-range-completion-function nil nil
673 nil
'mh-range-history default
))))
675 (when (and number-as-range-flag
676 (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input
))
677 (setq input
(concat "last:" (match-string 1 input
))))
678 (cond ((not expand-flag
) input
)
679 ((assoc (intern input
) seq-list
)
680 (cdr (assoc (intern input
) seq-list
)))
681 ((setq msg-list
(mh-translate-range folder input
)) msg-list
)
682 (t (error "No messages in range %s" input
)))))
685 (defun mh-range-to-msg-list (range)
686 "Return a list of messages for RANGE.
688 Check the documentation of `mh-interactive-range' to see how
689 RANGE is read in interactive use."
691 (mh-iterate-on-range msg range
693 (nreverse msg-list
)))
696 (defun mh-translate-range (folder expr
)
697 "In FOLDER, translate the string EXPR to a list of messages numbers."
699 (let ((strings (delete "" (split-string expr
"[ \t\n]")))
702 (apply #'mh-exec-cmd-quiet nil
"mhpath" folder strings
)
703 (set-buffer mh-temp-buffer
)
704 (goto-char (point-min))
705 (while (re-search-forward "/\\([0-9]*\\)$" nil t
)
706 (push (string-to-number (match-string 1)) result
))
707 (nreverse result
)))))
709 (defun mh-range-completion-function (string predicate flag
)
710 "Programmable completion of message ranges.
711 STRING is the user input that is to be completed. PREDICATE if non-nil is a
712 function used to filter the possible choices and FLAG determines whether the
714 (let* ((candidates mh-range-seq-names
)
715 (last-char (and (not (equal string
""))
716 (aref string
(1- (length string
)))))
717 (last-word (cond ((null last-char
) "")
718 ((memq last-char
'(? ?- ?
:)) "")
719 (t (car (last (split-string string
"[ -:]+"))))))
720 (prefix (substring string
0 (- (length string
) (length last-word
)))))
722 (let ((res (try-completion last-word candidates predicate
)))
723 (cond ((null res
) nil
)
725 (t (concat prefix res
)))))
727 (all-completions last-word candidates predicate
))
729 (loop for x in candidates
730 when
(equal x last-word
) return t
731 finally return nil
)))))
733 (defun mh-seq-names (seq-list)
734 "Return an alist containing the names of the SEQ-LIST."
735 (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry
))))
738 (defun mh-folder-size (folder)
739 "Find size of FOLDER."
740 (if mh-flists-present-flag
741 (mh-folder-size-flist folder
)
742 (mh-folder-size-folder folder
)))
744 (defun mh-folder-size-flist (folder)
745 "Find size of FOLDER using \"flist\"."
747 (call-process (expand-file-name "flist" mh-progs
) nil t nil
"-showzero"
748 "-norecurse" folder
"-sequence" (symbol-name mh-unseen-seq
))
749 (goto-char (point-min))
750 (multiple-value-bind (folder unseen total
)
751 (mh-parse-flist-output-line
752 (buffer-substring (point) (mh-line-end-position)))
753 (values total unseen folder
))))
755 (defun mh-folder-size-folder (folder)
756 "Find size of FOLDER using \"folder\"."
758 (let ((u (length (cdr (assoc mh-unseen-seq
759 (mh-read-folder-sequences folder nil
))))))
760 (call-process (expand-file-name "folder" mh-progs
) nil t nil
762 (goto-char (point-min))
763 (if (re-search-forward " has \\([0-9]+\\) " nil t
)
764 (values (string-to-number (match-string 1)) u folder
)
765 (values 0 u folder
)))))
768 (defun mh-parse-flist-output-line (line &optional current-folder
)
769 "Parse LINE to generate folder name, unseen messages and total messages.
770 If CURRENT-FOLDER is non-nil then it contains the current folder
771 name and it is used to avoid problems in corner cases involving
772 folders whose names end with a '+' character."
775 (goto-char (point-max))
776 (let (folder unseen total p
)
777 (when (search-backward " out of " (point-min) t
)
778 (setq total
(string-to-number
779 (buffer-substring-no-properties
780 (match-end 0) (mh-line-end-position))))
781 (when (search-backward " in sequence " (point-min) t
)
783 (when (search-backward " has " (point-min) t
)
784 (setq unseen
(string-to-number (buffer-substring-no-properties
786 (while (eq (char-after) ?
)
788 (setq folder
(buffer-substring-no-properties
789 (point-min) (1+ (point))))
790 (when (and (equal (aref folder
(1- (length folder
))) ?
+)
791 (equal current-folder folder
))
792 (setq folder
(substring folder
0 (1- (length folder
)))))
793 (values (format "+%s" folder
) unseen total
)))))))
796 (defun mh-read-folder-sequences (folder save-refiles
)
797 "Read and return the predefined sequences for a FOLDER.
798 If SAVE-REFILES is non-nil, then keep the sequences
799 that note messages to be refiled."
802 (mh-mapc (function (lambda (seq) ; Save the refiling sequences
803 (if (mh-folder-name-p (mh-seq-name seq
))
804 (setq seqs
(cons seq seqs
)))))
807 (if (eq 0 (mh-exec-cmd-quiet nil
"mark" folder
"-list"))
809 ;; look for name in line of form "cur: 4" or "myseq (private): 23"
810 (while (re-search-forward "^[^: ]+" nil t
)
811 (setq seqs
(cons (mh-make-seq (intern (buffer-substring
816 (delete-region (point-min) (point))))) ; avoid race with
820 (defun mh-read-msg-list ()
821 "Return a list of message numbers from point to the end of the line.
822 Expands ranges into set of individual numbers."
824 (end-of-line (save-excursion (end-of-line) (point)))
826 (while (re-search-forward "[0-9]+" end-of-line t
)
827 (setq num
(string-to-number (buffer-substring (match-beginning 0)
829 (cond ((looking-at "-") ; Message range
831 (re-search-forward "[0-9]+" end-of-line t
)
832 (let ((num2 (string-to-number
833 (buffer-substring (match-beginning 0)
836 (error "Bad message range: %d-%d" num num2
))
838 (setq msgs
(cons num msgs
))
839 (setq num
(1+ num
)))))
840 ((not (zerop num
)) ;"pick" outputs "0" to mean no match
841 (setq msgs
(cons num msgs
)))))
849 (defun mh-notate (msg notation offset
)
850 "Mark MSG with the character NOTATION at position OFFSET.
851 Null MSG means the message at cursor.
852 If NOTATION is nil then no change in the buffer occurs."
855 (mh-goto-msg msg t t
))
856 (with-mh-folder-updating (t)
858 (forward-char offset
)
859 (let* ((change-stack-flag
861 (+ mh-cmd-note mh-scan-field-destination-offset
))
862 (not (eq notation mh-note-seq
))))
863 (msg (and change-stack-flag
(or msg
(mh-get-msg-num nil
))))
864 (stack (and msg
(gethash msg mh-sequence-notation-history
)))
865 (notation (or notation
(char-after))))
867 ;; The presence of the stack tells us that we don't need to
868 ;; notate the message, since the notation would be replaced
869 ;; by a sequence notation. So we will just put the notation
870 ;; at the bottom of the stack. If the sequence is deleted,
871 ;; the correct notation will be shown.
872 (setf (gethash msg mh-sequence-notation-history
)
873 (reverse (cons notation
(cdr (reverse stack
)))))
874 ;; Since we don't have any sequence notations in the way, just
875 ;; notate the scan line.
878 (when change-stack-flag
879 (mh-thread-update-scan-line-map msg notation offset
)))))))
882 (defun mh-notate-cur ()
883 "Mark the MH sequence cur.
884 In addition to notating the current message with `mh-note-cur'
885 the function uses `overlay-arrow-position' to put a marker in the
887 (let ((cur (car (mh-seq-to-msgs 'cur
))))
888 (when (and cur
(mh-goto-msg cur t t
))
890 (when (looking-at mh-scan-good-msg-regexp
)
891 (mh-notate nil mh-note-cur mh-cmd-note
))
892 (setq mh-arrow-marker
(set-marker mh-arrow-marker
(point)))
893 (setq overlay-arrow-position mh-arrow-marker
))))
896 (defun mh-remove-cur-notation ()
897 "Remove old cur notation."
898 (let ((cur-msg (car (mh-seq-to-msgs 'cur
))))
901 (mh-goto-msg cur-msg t t
)
902 (looking-at mh-scan-cur-msg-number-regexp
))
903 (mh-notate nil ? mh-cmd-note
)
904 (setq overlay-arrow-position nil
)))))
906 ;; FIXME? We may want to clear all notations and add one for current-message
907 ;; and process user sequences.
909 (defun mh-notate-deleted-and-refiled ()
910 "Notate messages marked for deletion or refiling.
911 Messages to be deleted are given by `mh-delete-list' while
912 messages to be refiled are present in `mh-refile-list'."
913 (let ((refiled-hash (make-hash-table))
914 (deleted-hash (make-hash-table)))
915 (dolist (msg mh-delete-list
)
916 (setf (gethash msg deleted-hash
) t
))
917 (dolist (dest-msg-list mh-refile-list
)
918 (dolist (msg (cdr dest-msg-list
))
919 (setf (gethash msg refiled-hash
) t
)))
920 (mh-iterate-on-messages-in-region msg
(point-min) (point-max)
921 (cond ((gethash msg refiled-hash
)
922 (mh-notate nil mh-note-refiled mh-cmd-note
))
923 ((gethash msg deleted-hash
)
924 (mh-notate nil mh-note-deleted mh-cmd-note
))))))
927 (defun mh-notate-user-sequences (&optional range
)
928 "Mark user-defined sequences in RANGE.
930 Check the documentation of `mh-interactive-range' to see how
931 RANGE is read in interactive use; if nil all messages are
934 (setq range
(cons (point-min) (point-max))))
935 (let ((seqs mh-seq-list
)
936 (msg-hash (make-hash-table)))
938 (dolist (msg (mh-seq-msgs seq
))
939 (push (car seq
) (gethash msg msg-hash
))))
940 (mh-iterate-on-range msg range
941 (loop for seq in
(gethash msg msg-hash
)
942 do
(mh-add-sequence-notation msg
(mh-internal-seq seq
))))))
944 (defun mh-add-sequence-notation (msg internal-seq-flag
)
945 "Add sequence notation to the MSG on the current line.
946 If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if
947 font-lock is turned on."
948 (with-mh-folder-updating (t)
951 (if internal-seq-flag
953 ;; Change the buffer so that if transient-mark-mode is active
954 ;; and there is an active region it will get deactivated as in
955 ;; the case of user sequences.
956 (mh-notate nil nil mh-cmd-note
)
958 (font-lock-fontify-region (point) (mh-line-end-position))))
959 (forward-char (+ mh-cmd-note mh-scan-field-destination-offset
))
960 (let ((stack (gethash msg mh-sequence-notation-history
)))
961 (setf (gethash msg mh-sequence-notation-history
)
962 (cons (char-after) stack
)))
963 (mh-notate nil mh-note-seq
964 (+ mh-cmd-note mh-scan-field-destination-offset
))))))
966 (defun mh-remove-sequence-notation (msg internal-seq-flag
&optional all
)
967 "Remove sequence notation from the MSG on the current line.
968 If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to
969 highlight the sequence. In that case, no notation needs to be removed.
970 Otherwise the effect of inserting `mh-note-seq' needs to be reversed.
971 If ALL is non-nil, then all sequence marks on the scan line are
973 (with-mh-folder-updating (t)
974 ;; This takes care of internal sequences...
975 (mh-notate nil nil mh-cmd-note
)
976 (unless internal-seq-flag
977 ;; ... and this takes care of user sequences.
978 (let ((stack (gethash msg mh-sequence-notation-history
)))
979 (while (and all
(cdr stack
))
980 (setq stack
(cdr stack
)))
984 (forward-char (+ mh-cmd-note mh-scan-field-destination-offset
))
986 (insert (car stack
))))
987 (setf (gethash msg mh-sequence-notation-history
) (cdr stack
))))))
990 (defun mh-remove-all-notation ()
991 "Remove all notations on all scan lines that MH-E introduces."
993 (setq overlay-arrow-position nil
)
994 (goto-char (point-min))
995 (mh-iterate-on-range msg
(cons (point-min) (point-max))
996 (mh-notate nil ? mh-cmd-note
)
997 (mh-remove-sequence-notation msg nil t
))
998 (clrhash mh-sequence-notation-history
)))
1002 ;; XXX Unused, delete, or create bind key?
1003 (defun mh-rename-seq (sequence new-name
)
1004 "Rename SEQUENCE to have NEW-NAME."
1005 (interactive (list (mh-read-seq "Old" t
)
1006 (intern (read-string "New sequence name: "))))
1007 (let ((old-seq (mh-find-seq sequence
)))
1009 (error "Sequence %s does not exist" sequence
))
1010 ;; Create new sequence first, since it might raise an error.
1011 (mh-define-sequence new-name
(mh-seq-msgs old-seq
))
1012 (mh-undefine-sequence sequence
(mh-seq-msgs old-seq
))
1013 (rplaca old-seq new-name
)))
1018 ;; indent-tabs-mode: nil
1019 ;; sentence-end-double-space: nil
1022 ;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942
1023 ;;; mh-seq.el ends here