/[emacs]/emacs/lisp/mh-e/mh-seq.el
ViewVC logotype

Diff of /emacs/lisp/mh-e/mh-seq.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2.4.2 by miles, Tue Oct 14 23:39:26 2003 UTC revision 1.2.4.3 by miles, Sat Jul 17 02:51:49 2004 UTC
# Line 1  Line 1 
1  ;;; mh-seq.el --- MH-E sequences support  ;;; mh-seq.el --- MH-E sequences support
2    
3  ;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc.  ;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004 Free Software Foundation, Inc.
4    
5  ;; Author: Bill Wohler <wohler@newt.com>  ;; Author: Bill Wohler <wohler@newt.com>
6  ;; Maintainer: Bill Wohler <wohler@newt.com>  ;; Maintainer: Bill Wohler <wohler@newt.com>
# Line 70  Line 70 
70    
71  ;;; Code:  ;;; Code:
72    
73  (require 'cl)  (require 'mh-utils)
74    (mh-require-cl)
75  (require 'mh-e)  (require 'mh-e)
76    
77  ;; Shush the byte-compiler  ;; Shush the byte-compiler
# Line 110  Line 111 
111    "Table to look up message identifier from message index.")    "Table to look up message identifier from message index.")
112  (defvar mh-thread-scan-line-map nil  (defvar mh-thread-scan-line-map nil
113    "Map of message index to various parts of the scan line.")    "Map of message index to various parts of the scan line.")
114  (defvar mh-thread-old-scan-line-map nil  (defvar mh-thread-scan-line-map-stack nil
115    "Old map of message index to various parts of the scan line.    "Old map of message index to various parts of the scan line.
116  This is the original map that is stored when the folder is narrowed.")  This is the original map that is stored when the folder is narrowed.")
117  (defvar mh-thread-subject-container-hash nil  (defvar mh-thread-subject-container-hash nil
# Line 131  redone to get the new thread tree. This Line 132  redone to get the new thread tree. This
132  (make-variable-buffer-local 'mh-thread-id-index-map)  (make-variable-buffer-local 'mh-thread-id-index-map)
133  (make-variable-buffer-local 'mh-thread-index-id-map)  (make-variable-buffer-local 'mh-thread-index-id-map)
134  (make-variable-buffer-local 'mh-thread-scan-line-map)  (make-variable-buffer-local 'mh-thread-scan-line-map)
135  (make-variable-buffer-local 'mh-thread-old-scan-line-map)  (make-variable-buffer-local 'mh-thread-scan-line-map-stack)
136  (make-variable-buffer-local 'mh-thread-subject-container-hash)  (make-variable-buffer-local 'mh-thread-subject-container-hash)
137  (make-variable-buffer-local 'mh-thread-duplicates)  (make-variable-buffer-local 'mh-thread-duplicates)
138  (make-variable-buffer-local 'mh-thread-history)  (make-variable-buffer-local 'mh-thread-history)
# Line 140  redone to get the new thread tree. This Line 141  redone to get the new thread tree. This
141  (defun mh-delete-seq (sequence)  (defun mh-delete-seq (sequence)
142    "Delete the SEQUENCE."    "Delete the SEQUENCE."
143    (interactive (list (mh-read-seq-default "Delete" t)))    (interactive (list (mh-read-seq-default "Delete" t)))
144    (let ((msg-list (mh-seq-to-msgs sequence)))    (let ((msg-list (mh-seq-to-msgs sequence))
145            (internal-flag (mh-internal-seq sequence))
146            (folders-changed (list mh-current-folder)))
147        (mh-iterate-on-range msg sequence
148          (mh-remove-sequence-notation msg internal-flag))
149      (mh-undefine-sequence sequence '("all"))      (mh-undefine-sequence sequence '("all"))
150      (mh-delete-seq-locally sequence)      (mh-delete-seq-locally sequence)
151      (mh-iterate-on-messages-in-region msg (point-min) (point-max)      (when mh-index-data
152        (cond ((and mh-tick-seq (eq sequence mh-tick-seq))        (setq folders-changed
153               (mh-notate-tick msg ()))              (append folders-changed
154              ((and (member msg msg-list) (not (mh-seq-containing-msg msg nil)))                      (mh-index-delete-from-sequence sequence msg-list))))
155               (mh-notate nil ?  (1+ mh-cmd-note)))))))      (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
156          (apply #'mh-speed-flists t folders-changed))))
157    
158  ;; Avoid compiler warnings  ;; Avoid compiler warnings
159  (defvar view-exit-action)  (defvar view-exit-action)
# Line 221  Use \\<mh-folder-mode-map>\\[mh-widen] t Line 227  Use \\<mh-folder-mode-map>\\[mh-widen] t
227    (interactive (list (mh-read-seq "Narrow to" t)))    (interactive (list (mh-read-seq "Narrow to" t)))
228    (with-mh-folder-updating (t)    (with-mh-folder-updating (t)
229      (cond ((mh-seq-to-msgs sequence)      (cond ((mh-seq-to-msgs sequence)
            (mh-widen)  
230             (mh-remove-all-notation)             (mh-remove-all-notation)
231             (let ((eob (point-max))             (let ((eob (point-max))
232                   (msg-at-cursor (mh-get-msg-num nil)))                   (msg-at-cursor (mh-get-msg-num nil)))
233               (setq mh-thread-old-scan-line-map mh-thread-scan-line-map)               (push mh-thread-scan-line-map mh-thread-scan-line-map-stack)
234               (setq mh-thread-scan-line-map (make-hash-table :test #'eql))               (setq mh-thread-scan-line-map (make-hash-table :test #'eql))
235               (mh-copy-seq-to-eob sequence)               (mh-copy-seq-to-eob sequence)
236               (narrow-to-region eob (point-max))               (push (buffer-substring-no-properties (point-min) eob)
237               (setq mh-narrowed-to-seq sequence)                     mh-folder-view-stack)
238               (mh-notate-user-sequences)               (delete-region (point-min) eob)
239               (mh-notate-deleted-and-refiled)               (mh-notate-deleted-and-refiled)
240               (mh-notate-cur)               (mh-notate-cur)
241               (when msg-at-cursor (mh-goto-msg msg-at-cursor t t))               (when msg-at-cursor (mh-goto-msg msg-at-cursor t t))
# Line 252  Use \\<mh-folder-mode-map>\\[mh-widen] t Line 257  Use \\<mh-folder-mode-map>\\[mh-widen] t
257             (error "No messages in sequence `%s'" (symbol-name sequence))))))             (error "No messages in sequence `%s'" (symbol-name sequence))))))
258    
259  ;;;###mh-autoload  ;;;###mh-autoload
260  (defun mh-put-msg-in-seq (msg-or-seq sequence)  (defun mh-put-msg-in-seq (range sequence)
261    "Add MSG-OR-SEQ to SEQUENCE.    "Add RANGE to SEQUENCE.
262  Default is the displayed message.  
263  If optional prefix argument is provided, then prompt for the message sequence.  Check the documentation of `mh-interactive-range' to see how RANGE is read in
264  If variable `transient-mark-mode' is non-nil and the mark is active, then the  interactive use."
265  selected region is added to the sequence.    (interactive (list (mh-interactive-range "Add messages from")
 In a program, MSG-OR-SEQ can be a message number, a list of message numbers, a  
 region in a cons cell, or a sequence."  
   (interactive (list (mh-interactive-msg-or-seq "Add messages from")  
266                       (mh-read-seq-default "Add to" nil)))                       (mh-read-seq-default "Add to" nil)))
267    (when (and (interactive-p) mh-tick-seq (eq sequence mh-tick-seq))    (unless (mh-valid-seq-p sequence)
268      (error "Use `mh-toggle-tick' to add messages to %s" mh-tick-seq))      (error "Can't put message in invalid sequence `%s'" sequence))
269    (let* ((internal-seq-flag (mh-internal-seq sequence))    (let* ((internal-seq-flag (mh-internal-seq sequence))
270           (note-seq (if internal-seq-flag nil mh-note-seq))           (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
271             (folders (list mh-current-folder))
272           (msg-list ()))           (msg-list ()))
273      (mh-iterate-on-msg-or-seq m msg-or-seq      (mh-iterate-on-range m range
274        (push m msg-list)        (push m msg-list)
275        (mh-notate nil note-seq (1+ mh-cmd-note)))        (unless (memq m original-msgs)
276            (mh-add-sequence-notation m internal-seq-flag)))
277      (mh-add-msgs-to-seq msg-list sequence nil t)      (mh-add-msgs-to-seq msg-list sequence nil t)
278      (if (not internal-seq-flag)      (if (not internal-seq-flag)
279          (setq mh-last-seq-used sequence))          (setq mh-last-seq-used sequence))
280        (when mh-index-data
281          (setq folders
282                (append folders (mh-index-add-to-sequence sequence msg-list))))
283      (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))      (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
284        (mh-speed-flists t mh-current-folder))))        (apply #'mh-speed-flists t folders))))
285    
286  (defun mh-valid-view-change-operation-p (op)  (defun mh-valid-view-change-operation-p (op)
287    "Check if the view change operation can be performed.    "Check if the view change operation can be performed.
# Line 284  OP is one of 'widen and 'unthread." Line 291  OP is one of 'widen and 'unthread."
291          (t nil)))          (t nil)))
292    
293  ;;;###mh-autoload  ;;;###mh-autoload
294  (defun mh-widen ()  (defun mh-widen (&optional all-flag)
295    "Remove restrictions from current folder, thereby showing all messages."    "Remove last restriction from current folder.
296    (interactive)  If optional prefix argument ALL-FLAG is non-nil, then unwind to the beginning
297    of the view stack thereby showing all messages that the buffer originally
298    contained."
299      (interactive "P")
300    (let ((msg (mh-get-msg-num nil)))    (let ((msg (mh-get-msg-num nil)))
301      (when mh-narrowed-to-seq      (when mh-folder-view-stack
302        (cond ((mh-valid-view-change-operation-p 'widen) nil)        (cond (all-flag
303                 (while (cdr mh-view-ops)
304                   (setq mh-view-ops (cdr mh-view-ops)))
305                 (when (eq (car mh-view-ops) 'widen)
306                   (setq mh-view-ops (cdr mh-view-ops))))
307                ((mh-valid-view-change-operation-p 'widen) nil)
308              ((memq 'widen mh-view-ops)              ((memq 'widen mh-view-ops)
309               (while (not (eq (car mh-view-ops) 'widen))               (while (not (eq (car mh-view-ops) 'widen))
310                 (setq mh-view-ops (cdr mh-view-ops)))                 (setq mh-view-ops (cdr mh-view-ops)))
311               (pop mh-view-ops))               (setq mh-view-ops (cdr mh-view-ops)))
312              (t (error "Widening is not applicable")))              (t (error "Widening is not applicable")))
313        (when (memq 'unthread mh-view-ops)        ;; If ALL-FLAG is non-nil then rewind stacks
314          (setq mh-thread-scan-line-map mh-thread-old-scan-line-map))        (when all-flag
315            (while (cdr mh-thread-scan-line-map-stack)
316              (setq mh-thread-scan-line-map-stack
317                    (cdr mh-thread-scan-line-map-stack)))
318            (while (cdr mh-folder-view-stack)
319              (setq mh-folder-view-stack (cdr mh-folder-view-stack))))
320          (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack))
321        (with-mh-folder-updating (t)        (with-mh-folder-updating (t)
322          (delete-region (point-min) (point-max))          (delete-region (point-min) (point-max))
323          (widen)          (insert (pop mh-folder-view-stack))
324            (mh-remove-all-notation)
325          (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)          (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
326          (mh-make-folder-mode-line))          (mh-make-folder-mode-line))
327        (if msg        (if msg
328            (mh-goto-msg msg t t))            (mh-goto-msg msg t t))
       (setq mh-narrowed-to-seq nil)  
       (setq mh-tick-seq-changed-when-narrowed-flag nil)  
329        (mh-notate-deleted-and-refiled)        (mh-notate-deleted-and-refiled)
330        (mh-notate-user-sequences)        (mh-notate-user-sequences)
331        (mh-notate-cur)        (mh-notate-cur)
332        (mh-recenter nil)))        (mh-recenter nil)))
333    (when (and (boundp 'tool-bar-mode) tool-bar-mode)    (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
334      (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)      (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
335      (when (buffer-live-p (get-buffer mh-show-buffer))      (when (buffer-live-p (get-buffer mh-show-buffer))
336        (save-excursion        (save-excursion
# Line 319  OP is one of 'widen and 'unthread." Line 339  OP is one of 'widen and 'unthread."
339    
340  ;; FIXME?  We may want to clear all notations and add one for current-message  ;; FIXME?  We may want to clear all notations and add one for current-message
341  ;;         and process user sequences.  ;;         and process user sequences.
342    ;;;###mh-autoload
343  (defun mh-notate-deleted-and-refiled ()  (defun mh-notate-deleted-and-refiled ()
344    "Notate messages marked for deletion or refiling.    "Notate messages marked for deletion or refiling.
345  Messages to be deleted are given by `mh-delete-list' while messages to be  Messages to be deleted are given by `mh-delete-list' while messages to be
# Line 342  refiled are present in `mh-refile-list'. Line 363  refiled are present in `mh-refile-list'.
363  ;;; of the form:  ;;; of the form:
364  ;;;     ((seq-name msgs ...) (seq-name msgs ...) ...)  ;;;     ((seq-name msgs ...) (seq-name msgs ...) ...)
365    
366    (defvar mh-sequence-history ())
367    
368    ;;;###mh-autoload
369  (defun mh-read-seq-default (prompt not-empty)  (defun mh-read-seq-default (prompt not-empty)
370    "Read and return sequence name with default narrowed or previous sequence.    "Read and return sequence name with default narrowed or previous sequence.
371  PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a  PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a
372  non-empty sequence is read."  non-empty sequence is read."
373    (mh-read-seq prompt not-empty    (mh-read-seq prompt not-empty
374                 (or mh-narrowed-to-seq                 (or mh-last-seq-used
                    mh-last-seq-used  
375                     (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))                     (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
376    
377  (defun mh-read-seq (prompt not-empty &optional default)  (defun mh-read-seq (prompt not-empty &optional default)
# Line 360  defaults to the first sequence containin Line 383  defaults to the first sequence containin
383                                           (if default                                           (if default
384                                               (format "[%s] " default)                                               (format "[%s] " default)
385                                             ""))                                             ""))
386                                   (mh-seq-names mh-seq-list)))                                   (mh-seq-names mh-seq-list)
387                                     nil nil nil 'mh-sequence-history))
388           (seq (cond ((equal input "%")           (seq (cond ((equal input "%")
389                       (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))                       (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
390                      ((equal input "") default)                      ((equal input "") default)
# Line 370  defaults to the first sequence containin Line 394  defaults to the first sequence containin
394          (error "No messages in sequence `%s'" seq))          (error "No messages in sequence `%s'" seq))
395      seq))      seq))
396    
397    ;;; Functions to read ranges with completion...
398    (defvar mh-range-seq-names)
399    (defvar mh-range-history ())
400    (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
401    (define-key mh-range-completion-map " " 'self-insert-command)
402    
403    (defun mh-range-completion-function (string predicate flag)
404      "Programmable completion of message ranges.
405    STRING is the user input that is to be completed. PREDICATE if non-nil is a
406    function used to filter the possible choices and FLAG determines whether the
407    completion is over."
408      (let* ((candidates mh-range-seq-names)
409             (last-char (and (not (equal string ""))
410                             (aref string (1- (length string)))))
411             (last-word (cond ((null last-char) "")
412                              ((memq last-char '(?  ?- ?:)) "")
413                              (t (car (last (split-string string "[ -:]+"))))))
414             (prefix (substring string 0 (- (length string) (length last-word)))))
415        (cond ((eq flag nil)
416               (let ((res (try-completion last-word candidates predicate)))
417                 (cond ((null res) nil)
418                       ((eq res t) t)
419                       (t (concat prefix res)))))
420              ((eq flag t)
421               (all-completions last-word candidates predicate))
422              ((eq flag 'lambda)
423               (loop for x in candidates
424                     when (equal x last-word) return t
425                     finally return nil)))))
426    
427    ;;;###mh-autoload
428    (defun mh-read-range (prompt &optional folder default
429                                 expand-flag ask-flag number-as-range-flag)
430      "Read a message range with PROMPT.
431    
432    If FOLDER is non-nil then a range is read from that folder, otherwise use
433    `mh-current-folder'.
434    
435    If DEFAULT is a string then use that as default range to return. If DEFAULT is
436    nil then ask user with default answer a range based on the sequences that seem
437    relevant. Finally if DEFAULT is t, try to avoid prompting the user. Unseen
438    messages, if present, are returned. If the folder has fewer than
439    `mh-large-folder' messages then \"all\" messages are returned. Finally as a
440    last resort prompt the user.
441    
442    If EXPAND-FLAG is non-nil then a list of message numbers corresponding to the
443    input is returned. If this list is empty then an error is raised. If
444    EXPAND-FLAG is nil just return the input string. In this case we don't check
445    if the range is empty.
446    
447    If ASK-FLAG is non-nil, then the user is always queried for a range of
448    messages. If ASK-FLAG is nil, then the function checks if the unseen sequence
449    is non-empty. If that is the case, `mh-unseen-seq', or the list of messages in
450    it depending on the value of EXPAND, is returned. Otherwise if the folder has
451    fewer than `mh-large-folder' messages then the list of messages corresponding
452    to \"all\" is returned. If neither of the above holds then as a last resort
453    the user is queried for a range of messages.
454    
455    If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as input, it
456    is interpreted as the range \"last:N\".
457    
458    This function replaces the existing function `mh-read-msg-range'. Calls to:
459      (mh-read-msg-range folder flag)
460    should be replaced with:
461      (mh-read-range \"Suitable prompt\" folder t nil flag
462                     mh-interpret-number-as-range-flag)"
463      (setq default (or default mh-last-seq-used
464                        (car (mh-seq-containing-msg (mh-get-msg-num nil) t)))
465            prompt (format "%s range" prompt))
466      (let* ((folder (or folder mh-current-folder))
467             (default (cond ((or (eq default t) (stringp default)) default)
468                            ((symbolp default) (symbol-name default))))
469             (guess (eq default t))
470             (counts (and guess (mh-folder-size folder)))
471             (unseen (and counts (> (cadr counts) 0)))
472             (large (and counts mh-large-folder (> (car counts) mh-large-folder)))
473             (str (cond ((and guess large
474                              (setq default (format "last:%s" mh-large-folder)
475                                    prompt (format "%s (folder has %s messages)"
476                                                   prompt (car counts)))
477                              nil))
478                        ((and guess (not large) (setq default "all") nil))
479                        ((eq default nil) "")
480                        (t (format "[%s] " default))))
481             (minibuffer-local-completion-map mh-range-completion-map)
482             (seq-list (if (eq folder mh-current-folder)
483                           mh-seq-list
484                         (mh-read-folder-sequences folder nil)))
485             (mh-range-seq-names
486              (append '(("first") ("last") ("all") ("prev") ("next"))
487                      (mh-seq-names seq-list)))
488             (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
489                          ((and (not ask-flag) (not large)) "all")
490                          (t (completing-read (format "%s: %s" prompt str)
491                                              'mh-range-completion-function nil nil
492                                              nil 'mh-range-history default))))
493             msg-list)
494        (when (and number-as-range-flag
495                   (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input))
496          (setq input (concat "last:" (match-string 1 input))))
497        (cond ((not expand-flag) input)
498              ((assoc (intern input) seq-list)
499               (cdr (assoc (intern input) seq-list)))
500              ((setq msg-list (mh-translate-range folder input)) msg-list)
501              (t (error "No messages in range `%s'" input)))))
502    
503    ;;;###mh-autoload
504    (defun mh-translate-range (folder expr)
505      "In FOLDER, translate the string EXPR to a list of messages numbers."
506      (save-excursion
507        (let ((strings (delete "" (split-string expr "[ \t\n]")))
508              (result ()))
509          (ignore-errors
510            (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings)
511            (set-buffer mh-temp-buffer)
512            (goto-char (point-min))
513            (while (re-search-forward "/\\([0-9]*\\)$" nil t)
514              (push (car (read-from-string (match-string 1))) result))
515            (nreverse result)))))
516    
517  (defun mh-seq-names (seq-list)  (defun mh-seq-names (seq-list)
518    "Return an alist containing the names of the SEQ-LIST."    "Return an alist containing the names of the SEQ-LIST."
519    (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))    (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))
# Line 427  uses `overlay-arrow-position' to put a m Line 571  uses `overlay-arrow-position' to put a m
571  (defun mh-add-to-sequence (seq msgs)  (defun mh-add-to-sequence (seq msgs)
572    "The sequence SEQ is augmented with the messages in MSGS."    "The sequence SEQ is augmented with the messages in MSGS."
573    ;; Add to a SEQUENCE each message the list of MSGS.    ;; Add to a SEQUENCE each message the list of MSGS.
574    (if (not (mh-folder-name-p seq))    (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
575        (if msgs        (if msgs
576            (apply 'mh-exec-cmd "mark" mh-current-folder "-add"            (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
577                   "-sequence" (symbol-name seq)                   "-sequence" (symbol-name seq)
# Line 458  uses `overlay-arrow-position' to put a m Line 602  uses `overlay-arrow-position' to put a m
602          (mh-regenerate-headers coalesced-msgs t)          (mh-regenerate-headers coalesced-msgs t)
603          (cond ((memq 'unthread mh-view-ops)          (cond ((memq 'unthread mh-view-ops)
604                 ;; Populate restricted scan-line map                 ;; Populate restricted scan-line map
605                 (goto-char (point-min))                 (mh-remove-all-notation)
606                 (while (not (eobp))                 (mh-iterate-on-range msg (cons (point-min) (point-max))
607                   (let ((msg (mh-get-msg-num nil)))                   (setf (gethash msg mh-thread-scan-line-map)
608                     (when (numberp msg)                         (mh-thread-parse-scan-line)))
                      (setf (gethash msg mh-thread-scan-line-map)  
                            (mh-thread-parse-scan-line))))  
                  (forward-line))  
609                 ;; Remove scan lines and read results from pre-computed tree                 ;; Remove scan lines and read results from pre-computed tree
610                 (delete-region (point-min) (point-max))                 (delete-region (point-min) (point-max))
611                 (mh-thread-print-scan-lines                 (mh-thread-print-scan-lines
612                  (mh-thread-generate mh-current-folder ())))                  (mh-thread-generate mh-current-folder ()))
613                   (mh-notate-user-sequences))
614                (mh-index-data                (mh-index-data
615                 (mh-index-insert-folder-headers)))))))                 (mh-index-insert-folder-headers)))))))
616    
# Line 509  If VAR is nil then the loop is executed Line 651  If VAR is nil then the loop is executed
651  (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)  (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
652    
653  ;;;###mh-autoload  ;;;###mh-autoload
654  (defmacro mh-iterate-on-msg-or-seq (var msg-or-seq &rest body)  (defmacro mh-iterate-on-range (var range &rest body)
655    "Iterate an operation over a region or sequence.    "Iterate an operation over a region or sequence.
656    
657  VAR is bound to each message in turn in a loop over MSG-OR-SEQ, which can be a  VAR is bound to each message in turn in a loop over RANGE, which can be a
658  message number, a list of message numbers, a sequence, or a region in a cons  message number, a list of message numbers, a sequence, a region in a cons
659  cell. In each iteration, BODY is executed.  cell, or a MH range (something like last:20) in a string. In each iteration,
660    BODY is executed.
661    
662  The parameter MSG-OR-SEQ is usually created with `mh-interactive-msg-or-seq'  The parameter RANGE is usually created with `mh-interactive-range'
663  in order to provide a uniform interface to MH-E functions."  in order to provide a uniform interface to MH-E functions."
664    (unless (symbolp var)    (unless (symbolp var)
665      (error "Can not bind the non-symbol %s" var))      (error "Can not bind the non-symbol %s" var))
666    (let ((binding-needed-flag var)    (let ((binding-needed-flag var)
667          (msgs (make-symbol "msgs"))          (msgs (make-symbol "msgs"))
668          (seq-hash-table (make-symbol "seq-hash-table")))          (seq-hash-table (make-symbol "seq-hash-table")))
669      `(cond ((numberp ,msg-or-seq)      `(cond ((numberp ,range)
670              (when (mh-goto-msg ,msg-or-seq t t)              (when (mh-goto-msg ,range t t)
671                (let ,(if binding-needed-flag `((,var ,msg-or-seq)) ())                (let ,(if binding-needed-flag `((,var ,range)) ())
672                  ,@body)))                  ,@body)))
673             ((and (consp ,msg-or-seq)             ((and (consp ,range)
674                   (numberp (car ,msg-or-seq)) (numberp (cdr ,msg-or-seq)))                   (numberp (car ,range)) (numberp (cdr ,range)))
675              (mh-iterate-on-messages-in-region ,var              (mh-iterate-on-messages-in-region ,var
676                (car ,msg-or-seq) (cdr ,msg-or-seq)                (car ,range) (cdr ,range)
677                ,@body))                ,@body))
678             (t (let ((,msgs (if (and ,msg-or-seq (symbolp ,msg-or-seq))             (t (let ((,msgs (cond ((and ,range (symbolp ,range))
679                                 (mh-seq-to-msgs ,msg-or-seq)                                    (mh-seq-to-msgs ,range))
680                               ,msg-or-seq))                                   ((stringp ,range)
681                                      (mh-translate-range mh-current-folder
682                                                          ,range))
683                                     (t ,range)))
684                      (,seq-hash-table (make-hash-table)))                      (,seq-hash-table (make-hash-table)))
685                  (dolist (msg ,msgs)                  (dolist (msg ,msgs)
686                    (setf (gethash msg ,seq-hash-table) t))                    (setf (gethash msg ,seq-hash-table) t))
# Line 543  in order to provide a uniform interface Line 689  in order to provide a uniform interface
689                      (let ,(if binding-needed-flag `((,var v)) ())                      (let ,(if binding-needed-flag `((,var v)) ())
690                        ,@body))))))))                        ,@body))))))))
691    
692  (put 'mh-iterate-on-msg-or-seq 'lisp-indent-hook 'defun)  (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
693    
694  ;;;###mh-autoload  ;;;###mh-autoload
695  (defun mh-msg-or-seq-to-msg-list (msg-or-seq)  (defun mh-range-to-msg-list (range)
696    "Return a list of messages for MSG-OR-SEQ.    "Return a list of messages for RANGE.
697  MSG-OR-SEQ can be a message number, a list of message numbers, a sequence, or  RANGE can be a message number, a list of message numbers, a sequence, or
698  a region in a cons cell."  a region in a cons cell."
699    (let (msg-list)    (let (msg-list)
700      (mh-iterate-on-msg-or-seq msg msg-or-seq      (mh-iterate-on-range msg range
701        (push msg msg-list))        (push msg msg-list))
702      (nreverse msg-list)))      (nreverse msg-list)))
703    
704  ;;;###mh-autoload  ;;;###mh-autoload
705  (defun mh-interactive-msg-or-seq (sequence-prompt)  (defun mh-interactive-range (range-prompt)
706    "Return interactive specification for message, sequence, or region.    "Return interactive specification for message, sequence, range or region.
707  By convention, the name of this argument is msg-or-seq.  By convention, the name of this argument is RANGE.
708    
709  If variable `transient-mark-mode' is non-nil and the mark is active, then this  If variable `transient-mark-mode' is non-nil and the mark is active, then this
710  function returns a cons-cell of the region.  function returns a cons-cell of the region.
711  If optional prefix argument provided, then prompt for message sequence with  
712  SEQUENCE-PROMPT and return sequence.  If optional prefix argument is provided, then prompt for message range with
713    RANGE-PROMPT. A list of messages in that range is returned.
714    
715    If a MH range is given, say something like last:20, then a list containing
716    the messages in that range is returned.
717    
718  Otherwise, the message number at point is returned.  Otherwise, the message number at point is returned.
719    
720  This function is usually used with `mh-iterate-on-msg-or-seq' in order to  This function is usually used with `mh-iterate-on-range' in order to provide
721  provide a uniform interface to MH-E functions."  a uniform interface to MH-E functions."
722    (cond    (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
723     ((mh-mark-active-p t)          (current-prefix-arg (mh-read-range range-prompt nil nil t t))
724      (cons (region-beginning) (region-end)))          (t (mh-get-msg-num t))))
    (current-prefix-arg  
     (mh-read-seq-default sequence-prompt t))  
    (t  
     (mh-get-msg-num t))))  
725    
726  ;;;###mh-autoload  ;;;###mh-autoload
727  (defun mh-region-to-msg-list (begin end)  (defun mh-region-to-msg-list (begin end)
# Line 591  provide a uniform interface to MH-E func Line 738  provide a uniform interface to MH-E func
738  ;;; Commands to handle new 'subject sequence.  ;;; Commands to handle new 'subject sequence.
739  ;;; Or "Poor man's threading" by psg.  ;;; Or "Poor man's threading" by psg.
740    
741    ;;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number
742    ;;;  41 for the max size of the subject part. Avoiding this would be desirable.
743  (defun mh-subject-to-sequence (all)  (defun mh-subject-to-sequence (all)
744    "Put all following messages with same subject in sequence 'subject.    "Put all following messages with same subject in sequence 'subject.
745  If arg ALL is t, move to beginning of folder buffer to collect all messages.  If arg ALL is t, move to beginning of folder buffer to collect all messages.
# Line 601  Return number of messages put in the seq Line 750  Return number of messages put in the seq
750   nil -> there was no subject line.   nil -> there was no subject line.
751   0   -> there were no later messages with the same subject (sequence not made)   0   -> there were no later messages with the same subject (sequence not made)
752   >1  -> the total number of messages including current one."   >1  -> the total number of messages including current one."
753      (if (memq 'unthread mh-view-ops)
754          (mh-subject-to-sequence-threaded all)
755        (mh-subject-to-sequence-unthreaded all)))
756    
757    (defun mh-subject-to-sequence-unthreaded (all)
758      "Put all following messages with same subject in sequence 'subject.
759    This function only works with an unthreaded folder. If arg ALL is t, move to
760    beginning of folder buffer to collect all messages. If arg ALL is nil, collect
761    only messages fron current one on forward.
762    
763    Return number of messages put in the sequence:
764    
765     nil -> there was no subject line.
766     0   -> there were no later messages with the same subject (sequence not made)
767     >1  -> the total number of messages including current one."
768    (if (not (eq major-mode 'mh-folder-mode))    (if (not (eq major-mode 'mh-folder-mode))
769        (error "Not in a folder buffer"))        (error "Not in a folder buffer"))
770    (save-excursion    (save-excursion
# Line 628  Return number of messages put in the seq Line 792  Return number of messages put in the seq
792            ;; If we created a new sequence, add the initial message to it too.            ;; If we created a new sequence, add the initial message to it too.
793            (if (not (member (mh-get-msg-num t) list))            (if (not (member (mh-get-msg-num t) list))
794                (setq list (cons (mh-get-msg-num t) list)))                (setq list (cons (mh-get-msg-num t) list)))
795            (if (member '("subject") (mh-seq-names mh-seq-list))            (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
               (mh-delete-seq 'subject))  
796            ;; sort the result into a sequence            ;; sort the result into a sequence
797            (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))            (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
798              (while sorted-list              (while sorted-list
# Line 639  Return number of messages put in the seq Line 802  Return number of messages put in the seq
802           (t           (t
803            0))))))            0))))))
804    
805    (defun mh-subject-to-sequence-threaded (all)
806      "Put all messages with the same subject in the 'subject sequence.
807    This function works when the folder is threaded. In this situation the subject
808    could get truncated and so the normal matching doesn't work.
809    
810    The parameter ALL is non-nil then all the messages in the buffer are
811    considered, otherwise only the messages after the current one are taken into
812    account."
813      (let* ((cur (mh-get-msg-num nil))
814             (subject (mh-thread-find-msg-subject cur))
815             region msgs)
816        (if (null subject)
817            (and (message "No subject line") nil)
818          (setq region (cons (if all (point-min) (point)) (point-max)))
819          (mh-iterate-on-range msg region
820            (when (eq (mh-thread-find-msg-subject msg) subject)
821              (push msg msgs)))
822          (setq msgs (sort msgs #'mh-lessp))
823          (if (null msgs)
824              0
825            (when (assoc 'subject mh-seq-list)
826              (mh-delete-seq 'subject))
827            (mh-add-msgs-to-seq msgs 'subject)
828            (length msgs)))))
829    
830    (defun mh-thread-find-msg-subject (msg)
831      "Find canonicalized subject of MSG.
832    This function can only be used the folder is threaded."
833      (ignore-errors
834        (mh-message-subject
835         (mh-container-message (gethash (gethash msg mh-thread-index-id-map)
836                                        mh-thread-id-table)))))
837    
838  ;;;###mh-autoload  ;;;###mh-autoload
839  (defun mh-narrow-to-subject ()  (defun mh-narrow-to-subject ()
840    "Narrow to a sequence containing all following messages with same subject."    "Narrow to a sequence containing all following messages with same subject."
# Line 657  Return number of messages put in the seq Line 853  Return number of messages put in the seq
853        (if (numberp num)        (if (numberp num)
854            (mh-goto-msg num t t))))))            (mh-goto-msg num t t))))))
855    
856    (defun mh-read-pick-regexp (default)
857      "With prefix arg read a pick regexp.
858    If no prefix arg is given, then return DEFAULT."
859      (let ((default-string (loop for x in default concat (format " %s" x))))
860        (if (or current-prefix-arg (equal default-string ""))
861            (delete "" (split-string (read-string "Pick regexp: " default-string)))
862          default)))
863    
864    ;;;###mh-autoload
865    (defun mh-narrow-to-from (&optional regexp)
866      "Limit to messages with the same From header field as the message at point.
867    With a prefix argument, prompt for the regular expression, REGEXP given to
868    pick."
869      (interactive
870       (list (mh-read-pick-regexp (mh-current-message-header-field 'from))))
871      (mh-narrow-to-header-field 'from regexp))
872    
873    ;;;###mh-autoload
874    (defun mh-narrow-to-cc (&optional regexp)
875      "Limit to messages with the same Cc header field as the message at point.
876    With a prefix argument, prompt for the regular expression, REGEXP given to
877    pick."
878      (interactive
879       (list (mh-read-pick-regexp (mh-current-message-header-field 'cc))))
880      (mh-narrow-to-header-field 'cc regexp))
881    
882    ;;;###mh-autoload
883    (defun mh-narrow-to-to (&optional regexp)
884      "Limit to messages with the same To header field as the message at point.
885    With a prefix argument, prompt for the regular expression, REGEXP given to
886    pick."
887      (interactive
888       (list (mh-read-pick-regexp (mh-current-message-header-field 'to))))
889      (mh-narrow-to-header-field 'to regexp))
890    
891    (defun mh-narrow-to-header-field (header-field regexp)
892      "Limit to messages whose HEADER-FIELD match REGEXP.
893    The MH command pick is used to do the match."
894      (let ((folder mh-current-folder)
895            (original (mh-coalesce-msg-list
896                       (mh-range-to-msg-list (cons (point-min) (point-max)))))
897            (msg-list ()))
898        (with-temp-buffer
899          (apply #'mh-exec-cmd-output "pick" nil folder
900                 (append original (list "-list") regexp))
901          (goto-char (point-min))
902          (while (not (eobp))
903            (let ((num (read-from-string
904                        (buffer-substring (point) (line-end-position)))))
905              (when (numberp (car num)) (push (car num) msg-list))
906              (forward-line))))
907        (if (null msg-list)
908            (message "No matches")
909          (when (assoc 'header mh-seq-list) (mh-delete-seq 'header))
910          (mh-add-msgs-to-seq msg-list 'header)
911          (mh-narrow-to-seq 'header))))
912    
913    (defun mh-current-message-header-field (header-field)
914      "Return a pick regexp to match HEADER-FIELD of the message at point."
915      (let ((num (mh-get-msg-num nil)))
916        (when num
917          (let ((folder mh-current-folder))
918            (with-temp-buffer
919              (insert-file-contents-literally (mh-msg-filename num folder))
920              (goto-char (point-min))
921              (when (search-forward "\n\n" nil t)
922                (narrow-to-region (point-min) (point)))
923              (let* ((field (or (message-fetch-field (format "%s" header-field))
924                                ""))
925                     (field-option (format "-%s" header-field))
926                     (patterns (loop for x in (split-string  field "[ ]*,[ ]*")
927                                     unless (equal x "")
928                                     collect (if (string-match "<\\(.*@.*\\)>" x)
929                                                 (match-string 1 x)
930                                               x))))
931                (when patterns
932                  (loop with accum = `(,field-option ,(car patterns))
933                        for e in (cdr patterns)
934                        do (setq accum `(,field-option ,e "-or" ,@accum))
935                        finally return accum))))))))
936    
937    ;;;###mh-autoload
938    (defun mh-narrow-to-range (range)
939      "Limit to messages in RANGE.
940    
941    Check the documentation of `mh-interactive-range' to see how RANGE is read in
942    interactive use."
943      (interactive (list (mh-interactive-range "Narrow to")))
944      (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
945      (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
946      (mh-narrow-to-seq 'range))
947    
948    
949  ;;;###mh-autoload  ;;;###mh-autoload
950  (defun mh-delete-subject ()  (defun mh-delete-subject ()
951    "Mark all following messages with same subject to be deleted.    "Mark all following messages with same subject to be deleted.
# Line 689  subject for deletion." Line 978  subject for deletion."
978    
979  ;;; Message threading:  ;;; Message threading:
980    
981    (defmacro mh-thread-initialize-hash (var test)
982      "Initialize the hash table in VAR.
983    TEST is the test to use when creating a new hash table."
984      (unless (symbolp var) (error "Expected a symbol: %s" var))
985      `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test))))
986    
987  (defun mh-thread-initialize ()  (defun mh-thread-initialize ()
988    "Make hash tables, otherwise clear them."    "Make new hash tables, or clear them if already present."
989    (cond    (mh-thread-initialize-hash mh-thread-id-hash #'equal)
990     (mh-thread-id-hash    (mh-thread-initialize-hash mh-thread-subject-hash #'equal)
991      (clrhash mh-thread-id-hash)    (mh-thread-initialize-hash mh-thread-id-table #'eq)
992      (clrhash mh-thread-subject-hash)    (mh-thread-initialize-hash mh-thread-id-index-map #'eq)
993      (clrhash mh-thread-id-table)    (mh-thread-initialize-hash mh-thread-index-id-map #'eql)
994      (clrhash mh-thread-id-index-map)    (mh-thread-initialize-hash mh-thread-scan-line-map #'eql)
995      (clrhash mh-thread-index-id-map)    (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq)
996      (clrhash mh-thread-scan-line-map)    (mh-thread-initialize-hash mh-thread-duplicates #'eq)
997      (clrhash mh-thread-subject-container-hash)    (setq mh-thread-history ()))
     (clrhash mh-thread-duplicates)  
     (setq mh-thread-history ()))  
    (t (setq mh-thread-id-hash (make-hash-table :test #'equal))  
       (setq mh-thread-subject-hash (make-hash-table :test #'equal))  
       (setq mh-thread-id-table (make-hash-table :test #'eq))  
       (setq mh-thread-id-index-map (make-hash-table :test #'eq))  
       (setq mh-thread-index-id-map (make-hash-table :test #'eql))  
       (setq mh-thread-scan-line-map (make-hash-table :test #'eql))  
       (setq mh-thread-subject-container-hash (make-hash-table :test #'eq))  
       (setq mh-thread-duplicates (make-hash-table :test #'eq))  
       (setq mh-thread-history ()))))  
998    
999  (defsubst mh-thread-id-container (id)  (defsubst mh-thread-id-container (id)
1000    "Given ID, return the corresponding container in `mh-thread-id-table'.    "Given ID, return the corresponding container in `mh-thread-id-table'.
# Line 959  preference to something that has it." Line 1243  preference to something that has it."
1243                 (push root results)))))                 (push root results)))))
1244      (nreverse results)))      (nreverse results)))
1245    
1246  (defsubst mh-thread-process-in-reply-to (reply-to-header)  (defun mh-thread-process-in-reply-to (reply-to-header)
1247    "Extract message id's from REPLY-TO-HEADER.    "Extract message id's from REPLY-TO-HEADER.
1248  Ideally this should have some regexp which will try to guess if a string  Ideally this should have some regexp which will try to guess if a string
1249  between < and > is a message id and not an email address. For now it will  between < and > is a message id and not an email address. For now it will
# Line 1071  Only information about messages in MSG-L Line 1355  Only information about messages in MSG-L
1355    "Update thread tree for FOLDER.    "Update thread tree for FOLDER.
1356  All messages after START-POINT are added to the thread tree."  All messages after START-POINT are added to the thread tree."
1357    (mh-thread-rewind-pruning)    (mh-thread-rewind-pruning)
1358      (mh-remove-all-notation)
1359    (goto-char start-point)    (goto-char start-point)
1360    (let ((msg-list ()))    (let ((msg-list ()))
1361      (while (not (eobp))      (while (not (eobp))
# Line 1085  All messages after START-POINT are added Line 1370  All messages after START-POINT are added
1370            (old-buffer-modified-flag (buffer-modified-p)))            (old-buffer-modified-flag (buffer-modified-p)))
1371        (delete-region (point-min) (point-max))        (delete-region (point-min) (point-max))
1372        (mh-thread-print-scan-lines thread-tree)        (mh-thread-print-scan-lines thread-tree)
       (mh-notate-user-sequences)  
1373        (mh-notate-deleted-and-refiled)        (mh-notate-deleted-and-refiled)
1374        (mh-notate-cur)        (mh-notate-cur)
1375        (set-buffer-modified-p old-buffer-modified-flag))))        (set-buffer-modified-p old-buffer-modified-flag))))
# Line 1150  Otherwise uses the line at point as the Line 1434  Otherwise uses the line at point as the
1434    (let* ((string (or string    (let* ((string (or string
1435                       (buffer-substring-no-properties (line-beginning-position)                       (buffer-substring-no-properties (line-beginning-position)
1436                                                       (line-end-position))))                                                       (line-end-position))))
1437           (first-string (substring string 0 (+ mh-cmd-note 8))))           (address-start (+ mh-cmd-note mh-scan-field-from-start-offset))
1438      (setf (elt first-string mh-cmd-note) ? )           (body-start (+ mh-cmd-note mh-scan-field-from-end-offset))
1439      (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0))           (first-string (substring string 0 address-start)))
       (setf (elt first-string (1+ mh-cmd-note)) ? ))  
1440      (list first-string      (list first-string
1441            (substring string            (substring string address-start (- body-start 2))
1442                       (+ mh-cmd-note mh-scan-field-from-start-offset)            (substring string body-start)
                      (+ mh-cmd-note mh-scan-field-from-end-offset -2))  
           (substring string (+ mh-cmd-note mh-scan-field-from-end-offset))  
1443            string)))            string)))
1444    
1445  ;;;###mh-autoload  ;;;###mh-autoload
1446    (defun mh-thread-update-scan-line-map (msg notation offset)
1447      "In threaded view update `mh-thread-scan-line-map'.
1448    MSG is the message being notated with NOTATION at OFFSET."
1449      (let* ((msg (or msg (mh-get-msg-num nil)))
1450             (cur-scan-line (and mh-thread-scan-line-map
1451                                 (gethash msg mh-thread-scan-line-map)))
1452             (old-scan-lines (loop for map in mh-thread-scan-line-map-stack
1453                                   collect (and map (gethash msg map))))
1454             (notation (if (stringp notation) (aref notation 0) notation)))
1455        (when cur-scan-line
1456          (setf (aref (car cur-scan-line) offset) notation))
1457        (dolist (line old-scan-lines)
1458          (when line (setf (aref (car line) offset) notation)))))
1459    
1460    ;;;###mh-autoload
1461  (defun mh-thread-add-spaces (count)  (defun mh-thread-add-spaces (count)
1462    "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'."    "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'."
1463    (let ((spaces (format (format "%%%ss" count) "")))    (let ((spaces (format (format "%%%ss" count) "")))
# Line 1197  Otherwise uses the line at point as the Line 1493  Otherwise uses the line at point as the
1493    (message "Threading %s..." (buffer-name))    (message "Threading %s..." (buffer-name))
1494    (mh-thread-initialize)    (mh-thread-initialize)
1495    (goto-char (point-min))    (goto-char (point-min))
1496      (mh-remove-all-notation)
1497    (let ((msg-list ()))    (let ((msg-list ()))
1498      (while (not (eobp))      (mh-iterate-on-range msg (cons (point-min) (point-max))
1499        (let ((index (mh-get-msg-num nil)))        (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line))
1500          (when (numberp index)        (push msg msg-list))
           (push index msg-list)  
           (setf (gethash index mh-thread-scan-line-map)  
                 (mh-thread-parse-scan-line))))  
       (forward-line))  
1501      (let* ((range (mh-coalesce-msg-list msg-list))      (let* ((range (mh-coalesce-msg-list msg-list))
1502             (thread-tree (mh-thread-generate (buffer-name) range)))             (thread-tree (mh-thread-generate (buffer-name) range)))
1503        (delete-region (point-min) (point-max))        (delete-region (point-min) (point-max))
# Line 1403  start of the region and the second is th Line 1696  start of the region and the second is th
1696    
1697  ;; Tick mark handling  ;; Tick mark handling
1698    
1699  ;; Functions to highlight and unhighlight ticked messages.  ;;;###mh-autoload
1700  (defun mh-tick-add-overlay ()  (defun mh-toggle-tick (range)
1701    "Add tick overlay to current line."    "Toggle tick mark of all messages in RANGE."
1702    (with-mh-folder-updating (t)    (interactive (list (mh-interactive-range "Tick")))
     (let ((overlay  
            (or (mh-funcall-if-exists make-overlay (point) (line-end-position))  
                (mh-funcall-if-exists make-extent (point) (line-end-position)))))  
       (or (mh-funcall-if-exists overlay-put overlay 'face 'mh-folder-tick-face)  
           (mh-funcall-if-exists set-extent-face overlay 'mh-folder-tick-face))  
       (mh-funcall-if-exists set-extent-priority overlay 10)  
       (add-text-properties (point) (line-end-position) `(mh-tick ,overlay)))))  
   
 (defun mh-tick-remove-overlay ()  
   "Remove tick overlay from current line."  
   (let ((overlay (get-text-property (point) 'mh-tick)))  
     (when overlay  
       (with-mh-folder-updating (t)  
         (or (mh-funcall-if-exists delete-overlay overlay)  
             (mh-funcall-if-exists delete-extent overlay))  
         (remove-text-properties (point) (line-end-position) `(mh-tick nil))))))  
   
 ;;;###mh-autoload  
 (defun mh-notate-tick (msg ticked-msgs &optional ignore-narrowing)  
   "Highlight current line if MSG is in TICKED-MSGS.  
 If optional argument IGNORE-NARROWING is non-nil then highlighting is carried  
 out even if folder is narrowed to `mh-tick-seq'."  
   (when mh-tick-seq  
     (let ((narrowed-to-tick (and (not ignore-narrowing)  
                                  (eq mh-narrowed-to-seq mh-tick-seq)))  
           (overlay (get-text-property (point) 'mh-tick))  
           (in-tick (member msg ticked-msgs)))  
       (cond (narrowed-to-tick (mh-tick-remove-overlay))  
             ((and (not overlay) in-tick) (mh-tick-add-overlay))  
             ((and overlay (not in-tick)) (mh-tick-remove-overlay))))))  
   
 ;; Interactive function to toggle tick.  
 ;;;###mh-autoload  
 (defun mh-toggle-tick (begin end)  
   "Toggle tick mark of all messages in region BEGIN to END."  
   (interactive (cond ((mh-mark-active-p t)  
                       (list (region-beginning) (region-end)))  
                      (t (list (line-beginning-position) (line-end-position)))))  
1703    (unless mh-tick-seq    (unless mh-tick-seq
1704      (error "Enable ticking by customizing `mh-tick-seq'"))      (error "Enable ticking by customizing `mh-tick-seq'"))
1705    (let* ((tick-seq (mh-find-seq mh-tick-seq))    (let* ((tick-seq (mh-find-seq mh-tick-seq))
1706           (tick-seq-msgs (mh-seq-msgs tick-seq)))           (tick-seq-msgs (mh-seq-msgs tick-seq))
1707      (mh-iterate-on-messages-in-region msg begin end           (ticked ())
1708             (unticked ()))
1709        (mh-iterate-on-range msg range
1710        (cond ((member msg tick-seq-msgs)        (cond ((member msg tick-seq-msgs)
1711               (mh-undefine-sequence mh-tick-seq (list msg))               (push msg unticked)
1712               (setcdr tick-seq (delq msg (cdr tick-seq)))               (setcdr tick-seq (delq msg (cdr tick-seq)))
1713               (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))               (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
1714               (mh-tick-remove-overlay))               (mh-remove-sequence-notation msg t))
1715              (t              (t
1716               (mh-add-msgs-to-seq (list msg) mh-tick-seq nil t)               (push msg ticked)
1717               (setq mh-last-seq-used mh-tick-seq)               (setq mh-last-seq-used mh-tick-seq)
1718               (mh-tick-add-overlay))))               (mh-add-sequence-notation msg t))))
1719      (when (and (eq mh-tick-seq mh-narrowed-to-seq)      (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
1720                 (not mh-tick-seq-changed-when-narrowed-flag))      (mh-undefine-sequence mh-tick-seq unticked)
1721        (setq mh-tick-seq-changed-when-narrowed-flag t)      (when mh-index-data
1722        (let ((ticked-msgs (mh-seq-msgs (mh-find-seq mh-tick-seq))))        (mh-index-add-to-sequence mh-tick-seq ticked)
1723          (mh-iterate-on-messages-in-region msg (point-min) (point-max)        (mh-index-delete-from-sequence mh-tick-seq unticked))))
           (mh-notate-tick msg ticked-msgs t))))))  
1724    
1725  ;;;###mh-autoload  ;;;###mh-autoload
1726  (defun mh-narrow-to-tick ()  (defun mh-narrow-to-tick ()

Legend:
Removed from v.1.2.4.2  
changed lines
  Added in v.1.2.4.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26