X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ab5796a9f97180707734a81320e3eb81937281fe..33462dfacd354645c432dec98c9cf0f29dc97a17:/lisp/mh-e/mh-seq.el diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index e441466a7b..6d15739fe4 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -1,6 +1,7 @@ ;;; mh-seq.el --- MH-E sequences support -;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1995, +;; 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Bill Wohler ;; Maintainer: Bill Wohler @@ -21,140 +22,125 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: -;; -;; This tries to implement the algorithm described at: -;; http://www.jwz.org/doc/threading.html -;; It is also a start to implementing the IMAP Threading extension RFC. The -;; implementation lacks the reference and subject canonicalization of the -;; RFC. -;; -;; In the presentation buffer, children messages are shown indented with -;; either [ ] or < > around them. Square brackets ([ ]) denote that the -;; algorithm can point out some headers which when taken together implies -;; that the unindented message is an ancestor of the indented message. If -;; no such proof exists then angles (< >) are used. -;; -;; Some issues and problems are as follows: -;; -;; (1) Scan truncates the fields at length 512. So longer references: -;; headers get mutilated. The same kind of MH format string works when -;; composing messages. Is there a way to avoid this? My scan command -;; is as follows: -;; scan +folder -width 10000 \ -;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" -;; I would really appreciate it if someone would help me with this. -;; -;; (2) Implement heuristics to recognize message identifiers in -;; In-Reply-To: header. Right now it just assumes that the last text -;; between angles (< and >) is the message identifier. There is the -;; chance that this will incorrectly use an email address like a -;; message identifier. -;; -;; (3) Error checking of found message identifiers should be done. -;; -;; (4) Since this breaks the assumption that message indices increase as -;; one goes down the buffer, the binary search based mh-goto-msg -;; doesn't work. I have a simpler replacement which may be less -;; efficient. -;; -;; (5) Better canonicalizing for message identifier and subject strings. -;; - -;; Internal support for MH-E package. + +;; Sequences are stored in the alist `mh-seq-list' in the form: +;; ((seq-name msgs ...) (seq-name msgs ...) ...) ;;; Change Log: ;;; Code: -(require 'cl) (require 'mh-e) +(mh-require-cl) +(require 'mh-scan) -;; Shush the byte-compiler -(defvar tool-bar-mode) - -;;; Data structures (used in message threading)... -(defstruct (mh-thread-message (:conc-name mh-message-) - (:constructor mh-thread-make-message)) - (id nil) - (references ()) - (subject "") - (subject-re-p nil)) +(require 'font-lock) -(defstruct (mh-thread-container (:conc-name mh-container-) - (:constructor mh-thread-make-container)) - message parent children - (real-child-p t)) +;;; Variables - -;;; Internal variables: (defvar mh-last-seq-used nil "Name of seq to which a msg was last added.") (defvar mh-non-seq-mode-line-annotation nil "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") +(make-variable-buffer-local 'mh-non-seq-mode-line-annotation) + +(defvar mh-internal-seqs '(answered cur deleted forwarded printed)) + +;;; Macros + +(defmacro mh-make-seq (name msgs) + "Create sequence NAME with the given MSGS." + (list 'cons name msgs)) + +(defmacro mh-seq-name (sequence) + "Extract sequence name from the given SEQUENCE." + (list 'car sequence)) + + + +;;; MH-Folder Commands + +;; Alphabetical. + +;;;###mh-autoload +(defun mh-catchup (range) + "Delete RANGE from the \"unseen\" sequence. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (interactive (list (mh-interactive-range "Catchup" + (cons (point-min) (point-max))))) + (mh-delete-msg-from-seq range mh-unseen-seq)) -;;; Maps and hashes... -(defvar mh-thread-id-hash nil - "Hashtable used to canonicalize message identifiers.") -(defvar mh-thread-subject-hash nil - "Hashtable used to canonicalize subject strings.") -(defvar mh-thread-id-table nil - "Thread ID table maps from message identifiers to message containers.") -(defvar mh-thread-id-index-map nil - "Table to look up message index number from message identifier.") -(defvar mh-thread-index-id-map nil - "Table to look up message identifier from message index.") -(defvar mh-thread-scan-line-map nil - "Map of message index to various parts of the scan line.") -(defvar mh-thread-old-scan-line-map nil - "Old map of message index to various parts of the scan line. -This is the original map that is stored when the folder is narrowed.") -(defvar mh-thread-subject-container-hash nil - "Hashtable used to group messages by subject.") -(defvar mh-thread-duplicates nil - "Hashtable used to associate messages with the same message identifier.") -(defvar mh-thread-history () - "Variable to remember the transformations to the thread tree. -When new messages are added, these transformations are rewound, then the -links are added from the newly seen messages. Finally the transformations are -redone to get the new thread tree. This makes incremental threading easier.") -(defvar mh-thread-body-width nil - "Width of scan substring that contains subject and body of message.") - -(make-variable-buffer-local 'mh-thread-id-hash) -(make-variable-buffer-local 'mh-thread-subject-hash) -(make-variable-buffer-local 'mh-thread-id-table) -(make-variable-buffer-local 'mh-thread-id-index-map) -(make-variable-buffer-local 'mh-thread-index-id-map) -(make-variable-buffer-local 'mh-thread-scan-line-map) -(make-variable-buffer-local 'mh-thread-old-scan-line-map) -(make-variable-buffer-local 'mh-thread-subject-container-hash) -(make-variable-buffer-local 'mh-thread-duplicates) -(make-variable-buffer-local 'mh-thread-history) +;;;###mh-autoload +(defun mh-delete-msg-from-seq (range sequence &optional internal-flag) + "Delete RANGE from SEQUENCE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use. + +In a program, non-nil INTERNAL-FLAG means do not inform MH of the +change." + (interactive (list (mh-interactive-range "Delete") + (mh-read-seq-default "Delete from" t) + nil)) + (let ((entry (mh-find-seq sequence)) + (user-sequence-flag (not (mh-internal-seq sequence))) + (folders-changed (list mh-current-folder)) + (msg-list ())) + (when entry + (mh-iterate-on-range msg range + (push msg msg-list) + ;; Calling "mark" repeatedly takes too long. So we will pretend here + ;; that we are just modifying an internal sequence... + (when (memq msg (cdr entry)) + (mh-remove-sequence-notation msg (not user-sequence-flag))) + (mh-delete-a-msg-from-seq msg sequence t)) + ;; ... and here we will "mark" all the messages at one go. + (unless internal-flag (mh-undefine-sequence sequence msg-list)) + (when (and mh-index-data (not internal-flag)) + (setq folders-changed + (append folders-changed + (mh-index-delete-from-sequence sequence msg-list)))) + (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) + (apply #'mh-speed-flists t folders-changed))))) ;;;###mh-autoload (defun mh-delete-seq (sequence) - "Delete the SEQUENCE." + "Delete SEQUENCE. + +You are prompted for the sequence to delete. Note that this +deletes only the sequence, not the messages in the sequence. If +you want to delete the messages, use \"\\[universal-argument] +\\[mh-delete-msg]\"." (interactive (list (mh-read-seq-default "Delete" t))) - (let ((msg-list (mh-seq-to-msgs sequence))) + (let ((msg-list (mh-seq-to-msgs sequence)) + (internal-flag (mh-internal-seq sequence)) + (folders-changed (list mh-current-folder))) + (mh-iterate-on-range msg sequence + (mh-remove-sequence-notation msg internal-flag)) (mh-undefine-sequence sequence '("all")) (mh-delete-seq-locally sequence) - (mh-iterate-on-messages-in-region msg (point-min) (point-max) - (cond ((and mh-tick-seq (eq sequence mh-tick-seq)) - (mh-notate-tick msg ())) - ((and (member msg msg-list) (not (mh-seq-containing-msg msg nil))) - (mh-notate nil ? (1+ mh-cmd-note))))))) + (when mh-index-data + (setq folders-changed + (append folders-changed + (mh-index-delete-from-sequence sequence msg-list)))) + (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) + (apply #'mh-speed-flists t folders-changed)))) -;; Avoid compiler warnings +;; Shush compiler. (defvar view-exit-action) ;;;###mh-autoload (defun mh-list-sequences () - "List the sequences defined in the folder being visited." + "List all sequences in folder. + +The list appears in a buffer named \"*MH-E Sequences*\"." (interactive) (let ((folder mh-current-folder) (temp-buffer mh-sequences-buffer) @@ -189,18 +175,22 @@ redone to get the new thread tree. This makes incremental threading easier.") (insert "\n")) (setq seq-list (cdr seq-list))) (goto-char (point-min)) - (view-mode 1) + (mh-view-mode-enter) (setq view-exit-action 'kill-buffer) (message "Listing sequences...done"))))) ;;;###mh-autoload (defun mh-msg-is-in-seq (message) - "Display the sequences that contain MESSAGE. -Default is the displayed message." - (interactive (list (mh-get-msg-num t))) + "Display the sequences in which the current message appears. + +Use a prefix argument to display the sequences in which another +MESSAGE appears." + (interactive "P") + (if (not message) + (setq message (mh-get-msg-num t))) (let* ((dest-folder (loop for seq in mh-refile-list - until (member message (cdr seq)) - finally return (car seq))) + when (member message (cdr seq)) return (car seq) + finally return nil)) (deleted-flag (unless dest-folder (member message mh-delete-list)))) (message "Message %d%s is in sequences: %s" message @@ -211,30 +201,35 @@ Default is the displayed message." (mh-list-to-string (mh-seq-containing-msg message t)) " ")))) -;; Avoid compiler warning -(defvar tool-bar-map) +;; Shush compiler. +(defvar tool-bar-mode) ; XEmacs ;;;###mh-autoload (defun mh-narrow-to-seq (sequence) - "Restrict display of this folder to just messages in SEQUENCE. -Use \\\\[mh-widen] to undo this command." + "Restrict display to messages in SEQUENCE. + +You are prompted for the name of the sequence. What this command +does is show only those messages that are in the selected +sequence in the MH-Folder buffer. In addition, it limits further +MH-E searches to just those messages. + +When you want to widen the view to all your messages again, use +\\[mh-widen]." (interactive (list (mh-read-seq "Narrow to" t))) (with-mh-folder-updating (t) (cond ((mh-seq-to-msgs sequence) - (mh-widen) (mh-remove-all-notation) (let ((eob (point-max)) (msg-at-cursor (mh-get-msg-num nil))) - (setq mh-thread-old-scan-line-map mh-thread-scan-line-map) + (push mh-thread-scan-line-map mh-thread-scan-line-map-stack) (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) (mh-copy-seq-to-eob sequence) - (narrow-to-region eob (point-max)) - (setq mh-narrowed-to-seq sequence) - (mh-notate-user-sequences) + (push (buffer-substring-no-properties (point-min) eob) + mh-folder-view-stack) + (delete-region (point-min) eob) (mh-notate-deleted-and-refiled) (mh-notate-cur) (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) - (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) (setq mh-mode-line-annotation (symbol-name sequence)) (mh-make-folder-mode-line) @@ -243,205 +238,294 @@ Use \\\\[mh-widen] to undo this command." (set (make-local-variable 'tool-bar-map) mh-folder-seq-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) - (save-excursion - (set-buffer (get-buffer mh-show-buffer)) + (with-current-buffer mh-show-buffer (set (make-local-variable 'tool-bar-map) mh-show-seq-tool-bar-map)))) (push 'widen mh-view-ops))) (t - (error "No messages in sequence `%s'" (symbol-name sequence)))))) + (error "No messages in sequence %s" (symbol-name sequence)))))) + +;;;###mh-autoload +(defun mh-narrow-to-tick () + "Limit to ticked messages. + +What this command does is show only those messages that are in +the \"tick\" sequence (which you can customize via the +`mh-tick-seq' option) in the MH-Folder buffer. In addition, it +limits further MH-E searches to just those messages. When you +want to widen the view to all your messages again, use +\\[mh-widen]." + (interactive) + (cond ((not mh-tick-seq) + (error "Enable ticking by customizing `mh-tick-seq'")) + ((null (mh-seq-msgs (mh-find-seq mh-tick-seq))) + (message "No messages in %s sequence" mh-tick-seq)) + (t (mh-narrow-to-seq mh-tick-seq)))) ;;;###mh-autoload -(defun mh-put-msg-in-seq (msg-or-seq sequence) - "Add MSG-OR-SEQ to SEQUENCE. -Default is the displayed message. -If optional prefix argument is provided, then prompt for the message sequence. -If variable `transient-mark-mode' is non-nil and the mark is active, then the -selected region is added to the sequence. -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") +(defun mh-put-msg-in-seq (range sequence) + "Add RANGE to SEQUENCE\\. + +Give this command a RANGE and you can add all the messages in a +sequence to another sequence (for example, +\"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET +DestSequence RET\"). Check the documentation of +`mh-interactive-range' to see how RANGE is read in interactive +use." + (interactive (list (mh-interactive-range "Add messages from") (mh-read-seq-default "Add to" nil))) - (when (and (interactive-p) mh-tick-seq (eq sequence mh-tick-seq)) - (error "Use `mh-toggle-tick' to add messages to %s" mh-tick-seq)) + (unless (mh-valid-seq-p sequence) + (error "Can't put message in invalid sequence %s" sequence)) (let* ((internal-seq-flag (mh-internal-seq sequence)) - (note-seq (if internal-seq-flag nil mh-note-seq)) - (msg-list ())) - (mh-iterate-on-msg-or-seq m msg-or-seq - (push m msg-list) - (mh-notate nil note-seq (1+ mh-cmd-note))) + (original-msgs (mh-seq-msgs (mh-find-seq sequence))) + (folders (list mh-current-folder)) + (msg-list (mh-range-to-msg-list range))) (mh-add-msgs-to-seq msg-list sequence nil t) + (mh-iterate-on-range m range + (unless (memq m original-msgs) + (mh-add-sequence-notation m internal-seq-flag))) (if (not internal-seq-flag) (setq mh-last-seq-used sequence)) + (when mh-index-data + (setq folders + (append folders (mh-index-add-to-sequence sequence msg-list)))) (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) - (mh-speed-flists t mh-current-folder)))) + (apply #'mh-speed-flists t folders)))) -(defun mh-valid-view-change-operation-p (op) - "Check if the view change operation can be performed. -OP is one of 'widen and 'unthread." - (cond ((eq (car mh-view-ops) op) - (pop mh-view-ops)) - (t nil))) +;;;###mh-autoload +(defun mh-toggle-tick (range) + "Toggle tick mark of RANGE. + +This command adds messages to the \"tick\" sequence (which you can customize +via the option `mh-tick-seq'). This sequence can be viewed later with the +\\[mh-index-ticked-messages] command. + +Check the documentation of `mh-interactive-range' to see how RANGE is read in +interactive use." + (interactive (list (mh-interactive-range "Tick"))) + (unless mh-tick-seq + (error "Enable ticking by customizing `mh-tick-seq'")) + (let* ((tick-seq (mh-find-seq mh-tick-seq)) + (tick-seq-msgs (mh-seq-msgs tick-seq)) + (ticked ()) + (unticked ())) + (mh-iterate-on-range msg range + (cond ((member msg tick-seq-msgs) + (push msg unticked) + (setcdr tick-seq (delq msg (cdr tick-seq))) + (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) + (mh-remove-sequence-notation msg (mh-colors-in-use-p))) + (t + (push msg ticked) + (setq mh-last-seq-used mh-tick-seq) + (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list))) + (mh-add-sequence-notation msg (mh-colors-in-use-p)))))) + (mh-add-msgs-to-seq ticked mh-tick-seq nil t) + (mh-undefine-sequence mh-tick-seq unticked) + (when mh-index-data + (mh-index-add-to-sequence mh-tick-seq ticked) + (mh-index-delete-from-sequence mh-tick-seq unticked)))) ;;;###mh-autoload -(defun mh-widen () - "Remove restrictions from current folder, thereby showing all messages." - (interactive) +(defun mh-widen (&optional all-flag) + "Remove last restriction. + +Each limit or sequence restriction can be undone in turn with +this command. Give this command a prefix argument ALL-FLAG to +remove all limits and sequence restrictions." + (interactive "P") (let ((msg (mh-get-msg-num nil))) - (when mh-narrowed-to-seq - (cond ((mh-valid-view-change-operation-p 'widen) nil) + (when mh-folder-view-stack + (cond (all-flag + (while (cdr mh-view-ops) + (setq mh-view-ops (cdr mh-view-ops))) + (when (eq (car mh-view-ops) 'widen) + (setq mh-view-ops (cdr mh-view-ops)))) + ((mh-valid-view-change-operation-p 'widen) nil) ((memq 'widen mh-view-ops) (while (not (eq (car mh-view-ops) 'widen)) (setq mh-view-ops (cdr mh-view-ops))) - (pop mh-view-ops)) + (setq mh-view-ops (cdr mh-view-ops))) (t (error "Widening is not applicable"))) - (when (memq 'unthread mh-view-ops) - (setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) + ;; If ALL-FLAG is non-nil then rewind stacks + (when all-flag + (while (cdr mh-thread-scan-line-map-stack) + (setq mh-thread-scan-line-map-stack + (cdr mh-thread-scan-line-map-stack))) + (while (cdr mh-folder-view-stack) + (setq mh-folder-view-stack (cdr mh-folder-view-stack)))) + (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack)) (with-mh-folder-updating (t) (delete-region (point-min) (point-max)) - (widen) + (insert (pop mh-folder-view-stack)) + (mh-remove-all-notation) (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) (mh-make-folder-mode-line)) (if msg (mh-goto-msg msg t t)) - (setq mh-narrowed-to-seq nil) - (setq mh-tick-seq-changed-when-narrowed-flag nil) (mh-notate-deleted-and-refiled) (mh-notate-user-sequences) (mh-notate-cur) (mh-recenter nil))) - (when (and (boundp 'tool-bar-mode) tool-bar-mode) + (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode) (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) (when (buffer-live-p (get-buffer mh-show-buffer)) - (save-excursion - (set-buffer (get-buffer mh-show-buffer)) + (with-current-buffer mh-show-buffer (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))))) -;; FIXME? We may want to clear all notations and add one for current-message -;; and process user sequences. -(defun mh-notate-deleted-and-refiled () - "Notate messages marked for deletion or refiling. -Messages to be deleted are given by `mh-delete-list' while messages to be -refiled are present in `mh-refile-list'." - (let ((refiled-hash (make-hash-table)) - (deleted-hash (make-hash-table))) - (dolist (msg mh-delete-list) - (setf (gethash msg deleted-hash) t)) - (dolist (dest-msg-list mh-refile-list) - (dolist (msg (cdr dest-msg-list)) - (setf (gethash msg refiled-hash) t))) - (mh-iterate-on-messages-in-region msg (point-min) (point-max) - (cond ((gethash msg refiled-hash) - (mh-notate nil mh-note-refiled mh-cmd-note)) - ((gethash msg deleted-hash) - (mh-notate nil mh-note-deleted mh-cmd-note)))))) - -;;; Commands to manipulate sequences. Sequences are stored in an alist -;;; of the form: -;;; ((seq-name msgs ...) (seq-name msgs ...) ...) +;;; Support Routines +(defvar mh-sequence-history ()) + +;;;###mh-autoload (defun mh-read-seq-default (prompt not-empty) "Read and return sequence name with default narrowed or previous sequence. -PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a -non-empty sequence is read." +PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil +then a non-empty sequence is read." (mh-read-seq prompt not-empty - (or mh-narrowed-to-seq - mh-last-seq-used + (or mh-last-seq-used (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) (defun mh-read-seq (prompt not-empty &optional default) "Read and return a sequence name. -Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY -flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' -defaults to the first sequence containing the current message." - (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" +Prompt with PROMPT, raise an error if the sequence is empty and +the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT +sequence. A reply of '%' defaults to the first sequence +containing the current message." + (let* ((input (completing-read (format "%s sequence%s: " prompt (if default - (format "[%s] " default) + (format " (default %s)" default) "")) - (mh-seq-names mh-seq-list))) + (mh-seq-names mh-seq-list) + nil nil nil 'mh-sequence-history)) (seq (cond ((equal input "%") (car (mh-seq-containing-msg (mh-get-msg-num t) nil))) ((equal input "") default) (t (intern input)))) (msgs (mh-seq-to-msgs seq))) (if (and (null msgs) not-empty) - (error "No messages in sequence `%s'" seq)) + (error "No messages in sequence %s" seq)) seq)) -(defun mh-seq-names (seq-list) - "Return an alist containing the names of the SEQ-LIST." - (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) - seq-list)) +(defun mh-internal-seq (name) + "Return non-nil if NAME is the name of an internal MH-E sequence." + (or (memq name mh-internal-seqs) + (eq name mh-unseen-seq) + (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq)) + (eq name mh-previous-seq) + (mh-folder-name-p name))) ;;;###mh-autoload -(defun mh-rename-seq (sequence new-name) - "Rename SEQUENCE to have NEW-NAME." - (interactive (list (mh-read-seq "Old" t) - (intern (read-string "New sequence name: ")))) - (let ((old-seq (mh-find-seq sequence))) - (or old-seq - (error "Sequence %s does not exist" sequence)) - ;; create new sequence first, since it might raise an error. - (mh-define-sequence new-name (mh-seq-msgs old-seq)) - (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) - (rplaca old-seq new-name))) +(defun mh-valid-seq-p (name) + "Return non-nil if NAME is a valid MH sequence name." + (and (symbolp name) + (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name)))) ;;;###mh-autoload -(defun mh-map-to-seq-msgs (func seq &rest args) - "Invoke the FUNC at each message in the SEQ. -SEQ can either be a list of messages or a MH sequence. The remaining ARGS are -passed as arguments to FUNC." - (save-excursion - (let ((msgs (if (listp seq) seq (mh-seq-to-msgs seq)))) - (while msgs - (if (mh-goto-msg (car msgs) t t) - (apply func (car msgs) args)) - (setq msgs (cdr msgs)))))) +(defun mh-find-seq (name) + "Return sequence NAME." + (assoc name mh-seq-list)) ;;;###mh-autoload -(defun mh-notate-seq (seq notation offset) - "Mark the scan listing. -All messages in SEQ are marked with NOTATION at OFFSET from the beginning of -the line." - (let ((msg-list (mh-seq-to-msgs seq))) - (mh-iterate-on-messages-in-region msg (point-min) (point-max) - (when (member msg msg-list) - (mh-notate nil notation offset))))) +(defun mh-seq-to-msgs (seq) + "Return a list of the messages in SEQ." + (mh-seq-msgs (mh-find-seq seq))) + +(defun mh-seq-containing-msg (msg &optional include-internal-flag) + "Return a list of the sequences containing MSG. +If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences +in list." + (let ((l mh-seq-list) + (seqs ())) + (while l + (and (memq msg (mh-seq-msgs (car l))) + (or include-internal-flag + (not (mh-internal-seq (mh-seq-name (car l))))) + (setq seqs (cons (mh-seq-name (car l)) seqs))) + (setq l (cdr l))) + seqs)) ;;;###mh-autoload -(defun mh-notate-cur () - "Mark the MH sequence cur. -In addition to notating the current message with `mh-note-cur' the function -uses `overlay-arrow-position' to put a marker in the fringe." - (let ((cur (car (mh-seq-to-msgs 'cur)))) - (when (and cur (mh-goto-msg cur t t)) - (beginning-of-line) - (when (looking-at mh-scan-good-msg-regexp) - (mh-notate nil mh-note-cur mh-cmd-note)) - (setq mh-arrow-marker (set-marker mh-arrow-marker (point))) - (setq overlay-arrow-position mh-arrow-marker)))) +(defun mh-define-sequence (seq msgs) + "Define the SEQ to contain the list of MSGS. +Do not mark pseudo-sequences or empty sequences. +Signals an error if SEQ is an invalid name." + (if (and msgs + (mh-valid-seq-p seq) + (not (mh-folder-name-p seq))) + (save-excursion + (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero" + "-sequence" (symbol-name seq) + (mh-coalesce-msg-list msgs))))) ;;;###mh-autoload +(defun mh-undefine-sequence (seq msgs) + "Remove from the SEQ the list of MSGS." + (when (and (mh-valid-seq-p seq) msgs) + (apply #'mh-exec-cmd "mark" mh-current-folder "-delete" + "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs)))) + +;;;###mh-autoload +(defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag) + "Add MSGS to SEQ. + +Remove duplicates and keep sequence sorted. If optional +INTERNAL-FLAG is non-nil, do not mark the message in the scan +listing or inform MH of the addition. + +If DONT-ANNOTATE-FLAG is non-nil then the annotations in the +folder buffer are not updated." + (let ((entry (mh-find-seq seq)) + (internal-seq-flag (mh-internal-seq seq))) + (if (and msgs (atom msgs)) (setq msgs (list msgs))) + (if (null entry) + (setq mh-seq-list + (cons (mh-make-seq seq (mh-canonicalize-sequence msgs)) + mh-seq-list)) + (if msgs (setcdr entry (mh-canonicalize-sequence + (append msgs (mh-seq-msgs entry)))))) + (unless internal-flag + (mh-add-to-sequence seq msgs) + (when (not dont-annotate-flag) + (mh-iterate-on-range msg msgs + (unless (memq msg (cdr entry)) + (mh-add-sequence-notation msg internal-seq-flag))))))) + (defun mh-add-to-sequence (seq msgs) "The sequence SEQ is augmented with the messages in MSGS." ;; Add to a SEQUENCE each message the list of MSGS. - (if (not (mh-folder-name-p seq)) + (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq))) (if msgs (apply 'mh-exec-cmd "mark" mh-current-folder "-add" "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))) -;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes -;; that the folder buffer is sorted. However in this case that assumption -;; doesn't hold. So we will do this the dumb way. -;(defun mh-copy-seq-to-point (seq location) -; ;; Copy the scan listing of the messages in SEQUENCE to after the point -; ;; LOCATION in the current buffer. -; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) - -(defvar mh-thread-last-ancestor) +(defun mh-canonicalize-sequence (msgs) + "Sort MSGS in decreasing order and remove duplicates." + (let* ((sorted-msgs (sort (copy-sequence msgs) '>)) + (head sorted-msgs)) + (while (cdr head) + (if (= (car head) (cadr head)) + (setcdr head (cddr head)) + (setq head (cdr head)))) + sorted-msgs)) + +(defun mh-delete-a-msg-from-seq (msg sequence internal-flag) + "Delete MSG from SEQUENCE. +If INTERNAL-FLAG is non-nil, then do not inform MH of the +change." + (let ((entry (mh-find-seq sequence))) + (when (and entry (memq msg (mh-seq-msgs entry))) + (if (not internal-flag) + (mh-undefine-sequence sequence (list msg))) + (setcdr entry (delq msg (mh-seq-msgs entry)))))) + +(defun mh-delete-seq-locally (seq) + "Remove MH-E's record of SEQ." + (let ((entry (mh-find-seq seq))) + (setq mh-seq-list (delq entry mh-seq-list)))) (defun mh-copy-seq-to-eob (seq) "Copy SEQ to the end of the buffer." @@ -458,1032 +542,480 @@ uses `overlay-arrow-position' to put a marker in the fringe." (mh-regenerate-headers coalesced-msgs t) (cond ((memq 'unthread mh-view-ops) ;; Populate restricted scan-line map - (goto-char (point-min)) - (while (not (eobp)) - (let ((msg (mh-get-msg-num nil))) - (when (numberp msg) - (setf (gethash msg mh-thread-scan-line-map) - (mh-thread-parse-scan-line)))) - (forward-line)) + (mh-remove-all-notation) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (setf (gethash msg mh-thread-scan-line-map) + (mh-thread-parse-scan-line))) ;; Remove scan lines and read results from pre-computed tree (delete-region (point-min) (point-max)) (mh-thread-print-scan-lines - (mh-thread-generate mh-current-folder ()))) + (mh-thread-generate mh-current-folder ())) + (mh-notate-user-sequences)) (mh-index-data (mh-index-insert-folder-headers))))))) -(defun mh-copy-line-to-point (msg location) - "Copy current message line to a specific location. -The argument MSG is not used. The message in the current line is copied to -LOCATION." - ;; msg is not used? - ;; Copy the current line to the LOCATION in the current buffer. - (beginning-of-line) - (save-excursion - (let ((beginning-of-line (point)) - end) - (forward-line 1) - (setq end (point)) - (goto-char location) - (insert-buffer-substring (current-buffer) beginning-of-line end)))) - -;;;###mh-autoload -(defmacro mh-iterate-on-messages-in-region (var begin end &rest body) - "Iterate over region. -VAR is bound to the message on the current line as we loop starting from BEGIN -till END. In each step BODY is executed. - -If VAR is nil then the loop is executed without any binding." - (unless (symbolp var) - (error "Can not bind the non-symbol %s" var)) - (let ((binding-needed-flag var)) - `(save-excursion - (goto-char ,begin) - (beginning-of-line) - (while (and (<= (point) ,end) (not (eobp))) - (when (looking-at mh-scan-valid-regexp) - (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ()) - ,@body)) - (forward-line 1))))) - -(put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) - ;;;###mh-autoload -(defmacro mh-iterate-on-msg-or-seq (var msg-or-seq &rest body) - "Iterate an operation over a region or sequence. - -VAR is bound to each message in turn in a loop over MSG-OR-SEQ, which can be a -message number, a list of message numbers, a sequence, or a region in a cons -cell. In each iteration, BODY is executed. - -The parameter MSG-OR-SEQ is usually created with `mh-interactive-msg-or-seq' -in order to provide a uniform interface to MH-E functions." - (unless (symbolp var) - (error "Can not bind the non-symbol %s" var)) - (let ((binding-needed-flag var) - (msgs (make-symbol "msgs")) - (seq-hash-table (make-symbol "seq-hash-table"))) - `(cond ((numberp ,msg-or-seq) - (when (mh-goto-msg ,msg-or-seq t t) - (let ,(if binding-needed-flag `((,var ,msg-or-seq)) ()) - ,@body))) - ((and (consp ,msg-or-seq) - (numberp (car ,msg-or-seq)) (numberp (cdr ,msg-or-seq))) - (mh-iterate-on-messages-in-region ,var - (car ,msg-or-seq) (cdr ,msg-or-seq) - ,@body)) - (t (let ((,msgs (if (and ,msg-or-seq (symbolp ,msg-or-seq)) - (mh-seq-to-msgs ,msg-or-seq) - ,msg-or-seq)) - (,seq-hash-table (make-hash-table))) - (dolist (msg ,msgs) - (setf (gethash msg ,seq-hash-table) t)) - (mh-iterate-on-messages-in-region v (point-min) (point-max) - (when (gethash v ,seq-hash-table) - (let ,(if binding-needed-flag `((,var v)) ()) - ,@body)))))))) - -(put 'mh-iterate-on-msg-or-seq 'lisp-indent-hook 'defun) +(defun mh-valid-view-change-operation-p (op) + "Check if the view change operation can be performed. +OP is one of 'widen and 'unthread." + (cond ((eq (car mh-view-ops) op) + (pop mh-view-ops)) + (t nil))) -;;;###mh-autoload -(defun mh-msg-or-seq-to-msg-list (msg-or-seq) - "Return a list of messages for MSG-OR-SEQ. -MSG-OR-SEQ can be a message number, a list of message numbers, a sequence, or -a region in a cons cell." - (let (msg-list) - (mh-iterate-on-msg-or-seq msg msg-or-seq - (push msg msg-list)) - (nreverse msg-list))) + -;;;###mh-autoload -(defun mh-interactive-msg-or-seq (sequence-prompt) - "Return interactive specification for message, sequence, or region. -By convention, the name of this argument is msg-or-seq. - -If variable `transient-mark-mode' is non-nil and the mark is active, then this -function returns a cons-cell of the region. -If optional prefix argument provided, then prompt for message sequence with -SEQUENCE-PROMPT and return sequence. -Otherwise, the message number at point is returned. +;;; Ranges -This function is usually used with `mh-iterate-on-msg-or-seq' in order to -provide a uniform interface to MH-E functions." - (cond - ((mh-mark-active-p t) - (cons (region-beginning) (region-end))) - (current-prefix-arg - (mh-read-seq-default sequence-prompt t)) - (t - (mh-get-msg-num t)))) +(defvar mh-range-seq-names) +(defvar mh-range-history ()) +(defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map)) +(define-key mh-range-completion-map " " 'self-insert-command) ;;;###mh-autoload -(defun mh-region-to-msg-list (begin end) - "Return a list of messages within the region between BEGIN and END." - ;; If end is end of buffer back up one position - (setq end (if (equal end (point-max)) (1- end) end)) - (let ((result)) - (mh-iterate-on-messages-in-region index begin end - (when (numberp index) (push index result))) - result)) +(defun mh-interactive-range (range-prompt &optional default) + "Return interactive specification for message, sequence, range or region. +By convention, the name of this argument is RANGE. - +If variable `transient-mark-mode' is non-nil and the mark is active, +then this function returns a cons-cell of the region. -;;; Commands to handle new 'subject sequence. -;;; Or "Poor man's threading" by psg. +If optional prefix argument is provided, then prompt for message range +with RANGE-PROMPT. A list of messages in that range is returned. -(defun mh-subject-to-sequence (all) - "Put all following messages with same subject in sequence 'subject. -If arg ALL is t, move to beginning of folder buffer to collect all messages. -If arg ALL is nil, collect only messages fron current one on forward. +If a MH range is given, say something like last:20, then a list +containing the messages in that range is returned. -Return number of messages put in the sequence: +If DEFAULT non-nil then it is returned. - nil -> there was no subject line. - 0 -> there were no later messages with the same subject (sequence not made) - >1 -> the total number of messages including current one." - (if (not (eq major-mode 'mh-folder-mode)) - (error "Not in a folder buffer")) - (save-excursion - (beginning-of-line) - (if (or (not (looking-at mh-scan-subject-regexp)) - (not (match-string 3)) - (string-equal "" (match-string 3))) - (progn (message "No subject line.") - nil) - (let ((subject (match-string-no-properties 3)) - (list)) - (if (> (length subject) 41) - (setq subject (substring subject 0 41))) - (save-excursion - (if all - (goto-char (point-min))) - (while (re-search-forward mh-scan-subject-regexp nil t) - (let ((this-subject (match-string-no-properties 3))) - (if (> (length this-subject) 41) - (setq this-subject (substring this-subject 0 41))) - (if (string-equal this-subject subject) - (setq list (cons (mh-get-msg-num t) list)))))) - (cond - (list - ;; If we created a new sequence, add the initial message to it too. - (if (not (member (mh-get-msg-num t) list)) - (setq list (cons (mh-get-msg-num t) list))) - (if (member '("subject") (mh-seq-names mh-seq-list)) - (mh-delete-seq 'subject)) - ;; sort the result into a sequence - (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) - (while sorted-list - (mh-add-msgs-to-seq (car sorted-list) 'subject nil) - (setq sorted-list (cdr sorted-list))) - (safe-length list))) - (t - 0)))))) +Otherwise, the message number at point is returned. -;;;###mh-autoload -(defun mh-narrow-to-subject () - "Narrow to a sequence containing all following messages with same subject." - (interactive) - (let ((num (mh-get-msg-num nil)) - (count (mh-subject-to-sequence t))) - (cond - ((not count) ; No subject line, delete msg anyway - nil) - ((= 0 count) ; No other msgs, delete msg anyway. - (message "No other messages with same Subject following this one.") - nil) - (t ; We have a subject sequence. - (message "Found %d messages for subject sequence." count) - (mh-narrow-to-seq 'subject) - (if (numberp num) - (mh-goto-msg num t t)))))) +This function is usually used with `mh-iterate-on-range' in order to +provide a uniform interface to MH-E functions." + (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) + (current-prefix-arg (mh-read-range range-prompt nil nil t t)) + (default default) + (t (mh-get-msg-num t)))) ;;;###mh-autoload -(defun mh-delete-subject () - "Mark all following messages with same subject to be deleted. -This puts the messages in a sequence named subject. You can undo the last -deletion marks using `mh-undo' with a prefix argument and then specifying the -subject sequence." - (interactive) - (let ((count (mh-subject-to-sequence nil))) - (cond - ((not count) ; No subject line, delete msg anyway - (mh-delete-msg (mh-get-msg-num t))) - ((= 0 count) ; No other msgs, delete msg anyway. - (message "No other messages with same Subject following this one.") - (mh-delete-msg (mh-get-msg-num t))) - (t ; We have a subject sequence. - (message "Marked %d messages for deletion" count) - (mh-delete-msg 'subject))))) +(defun mh-read-range (prompt &optional folder default + expand-flag ask-flag number-as-range-flag) + "Read a message range with PROMPT. + +If FOLDER is non-nil then a range is read from that folder, otherwise +use `mh-current-folder'. + +If DEFAULT is a string then use that as default range to return. If +DEFAULT is nil then ask user with default answer a range based on the +sequences that seem relevant. Finally if DEFAULT is t, try to avoid +prompting the user. Unseen messages, if present, are returned. If the +folder has fewer than `mh-large-folder' messages then \"all\" messages +are returned. Finally as a last resort prompt the user. + +If EXPAND-FLAG is non-nil then a list of message numbers corresponding +to the input is returned. If this list is empty then an error is +raised. If EXPAND-FLAG is nil just return the input string. In this +case we don't check if the range is empty. + +If ASK-FLAG is non-nil, then the user is always queried for a range of +messages. If ASK-FLAG is nil, then the function checks if the unseen +sequence is non-empty. If that is the case, `mh-unseen-seq', or the +list of messages in it depending on the value of EXPAND, is returned. +Otherwise if the folder has fewer than `mh-large-folder' messages then +the list of messages corresponding to \"all\" is returned. If neither +of the above holds then as a last resort the user is queried for a +range of messages. + +If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as +input, it is interpreted as the range \"last:N\". + +This function replaces the existing function `mh-read-msg-range'. +Calls to: + + (mh-read-msg-range folder flag) + +should be replaced with: + + (mh-read-range \"Suitable prompt\" folder t nil flag + mh-interpret-number-as-range-flag)" + (setq default (or default mh-last-seq-used + (car (mh-seq-containing-msg (mh-get-msg-num nil) t))) + prompt (format "%s range" prompt)) + (let* ((folder (or folder mh-current-folder)) + (guess (eq default t)) + (counts (and guess (mh-folder-size folder))) + (unseen (and counts (> (cadr counts) 0))) + (large (and counts mh-large-folder (> (car counts) mh-large-folder))) + (default (cond ((and guess large) (format "last:%s" mh-large-folder)) + ((and guess (not large)) "all") + ((stringp default) default) + ((symbolp default) (symbol-name default)))) + (prompt (cond ((and guess large default) + (format "%s (folder has %s messages, default %s)" + prompt (car counts) default)) + ((and guess large) + (format "%s (folder has %s messages)" + prompt (car counts))) + (default + (format "%s (default %s)" prompt default)))) + (minibuffer-local-completion-map mh-range-completion-map) + (seq-list (if (eq folder mh-current-folder) + mh-seq-list + (mh-read-folder-sequences folder nil))) + (mh-range-seq-names + (append '(("first") ("last") ("all") ("prev") ("next")) + (mh-seq-names seq-list))) + (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq)) + ((and (not ask-flag) (not large)) "all") + (t (completing-read (format "%s: " prompt) + 'mh-range-completion-function nil nil + nil 'mh-range-history default)))) + msg-list) + (when (and number-as-range-flag + (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input)) + (setq input (concat "last:" (match-string 1 input)))) + (cond ((not expand-flag) input) + ((assoc (intern input) seq-list) + (cdr (assoc (intern input) seq-list))) + ((setq msg-list (mh-translate-range folder input)) msg-list) + (t (error "No messages in range %s" input))))) ;;;###mh-autoload -(defun mh-delete-subject-or-thread () - "Mark messages for deletion intelligently. -If the folder is threaded then `mh-thread-delete' is used to mark the current -message and all its descendants for deletion. Otherwise `mh-delete-subject' is -used to mark the current message and all messages following it with the same -subject for deletion." - (interactive) - (if (memq 'unthread mh-view-ops) - (mh-thread-delete) - (mh-delete-subject))) - -;;; Message threading: - -(defun mh-thread-initialize () - "Make hash tables, otherwise clear them." - (cond - (mh-thread-id-hash - (clrhash mh-thread-id-hash) - (clrhash mh-thread-subject-hash) - (clrhash mh-thread-id-table) - (clrhash mh-thread-id-index-map) - (clrhash mh-thread-index-id-map) - (clrhash mh-thread-scan-line-map) - (clrhash mh-thread-subject-container-hash) - (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 ())))) - -(defsubst mh-thread-id-container (id) - "Given ID, return the corresponding container in `mh-thread-id-table'. -If no container exists then a suitable container is created and the id-table -is updated." - (when (not id) - (error "1")) - (or (gethash id mh-thread-id-table) - (setf (gethash id mh-thread-id-table) - (let ((message (mh-thread-make-message :id id))) - (mh-thread-make-container :message message))))) - -(defsubst mh-thread-remove-parent-link (child) - "Remove parent link of CHILD if it exists." - (let* ((child-container (if (mh-thread-container-p child) - child (mh-thread-id-container child))) - (parent-container (mh-container-parent child-container))) - (when parent-container - (setf (mh-container-children parent-container) - (loop for elem in (mh-container-children parent-container) - unless (eq child-container elem) collect elem)) - (setf (mh-container-parent child-container) nil)))) - -(defsubst mh-thread-add-link (parent child &optional at-end-p) - "Add links so that PARENT becomes a parent of CHILD. -Doesn't make any changes if CHILD is already an ancestor of PARENT. If -optional argument AT-END-P is non-nil, the CHILD is added to the end of the -children list of PARENT." - (let ((parent-container (cond ((null parent) nil) - ((mh-thread-container-p parent) parent) - (t (mh-thread-id-container parent)))) - (child-container (if (mh-thread-container-p child) - child (mh-thread-id-container child)))) - (when (and parent-container - (not (mh-thread-ancestor-p child-container parent-container)) - (not (mh-thread-ancestor-p parent-container child-container))) - (mh-thread-remove-parent-link child-container) - (cond ((not at-end-p) - (push child-container (mh-container-children parent-container))) - ((null (mh-container-children parent-container)) - (push child-container (mh-container-children parent-container))) - (t (let ((last-child (mh-container-children parent-container))) - (while (cdr last-child) - (setq last-child (cdr last-child))) - (setcdr last-child (cons child-container nil))))) - (setf (mh-container-parent child-container) parent-container)) - (unless parent-container - (mh-thread-remove-parent-link child-container)))) - -(defun mh-thread-ancestor-p (ancestor successor) - "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. -In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same -containers." - (block nil - (while successor - (when (eq ancestor successor) (return t)) - (setq successor (mh-container-parent successor))) - nil)) - -(defsubst mh-thread-get-message-container (message) - "Return container which has MESSAGE in it. -If there is no container present then a new container is allocated." - (let* ((id (mh-message-id message)) - (container (gethash id mh-thread-id-table))) - (cond (container (setf (mh-container-message container) message) - container) - (t (setf (gethash id mh-thread-id-table) - (mh-thread-make-container :message message)))))) - -(defsubst mh-thread-get-message (id subject-re-p subject refs) - "Return appropriate message. -Otherwise update message already present to have the proper ID, SUBJECT-RE-P, -SUBJECT and REFS fields." - (let* ((container (gethash id mh-thread-id-table)) - (message (if container (mh-container-message container) nil))) - (cond (message - (setf (mh-message-subject-re-p message) subject-re-p) - (setf (mh-message-subject message) subject) - (setf (mh-message-id message) id) - (setf (mh-message-references message) refs) - message) - (container - (setf (mh-container-message container) - (mh-thread-make-message :subject subject - :subject-re-p subject-re-p - :id id :references refs))) - (t (let ((message (mh-thread-make-message - :subject subject - :subject-re-p subject-re-p - :id id :references refs))) - (prog1 message - (mh-thread-get-message-container message))))))) - -(defsubst mh-thread-canonicalize-id (id) - "Produce canonical string representation for ID. -This allows cheap string comparison with EQ." - (or (and (equal id "") (copy-sequence "")) - (gethash id mh-thread-id-hash) - (setf (gethash id mh-thread-id-hash) id))) - -(defsubst mh-thread-prune-subject (subject) - "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. -If the result after pruning is not the empty string then it is canonicalized -so that subjects can be tested for equality with eq. This is done so that all -the messages without a subject are not put into a single thread." - (let ((case-fold-search t) - (subject-pruned-flag nil)) - ;; Prune subject leader - (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" - subject) - (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) - (setq subject-pruned-flag t) - (setq subject (substring subject (match-end 0)))) - ;; Prune subject trailer - (while (or (string-match "(fwd)$" subject) - (string-match "[ \t]+$" subject)) - (setq subject-pruned-flag t) - (setq subject (substring subject 0 (match-beginning 0)))) - ;; Canonicalize subject only if it is non-empty - (cond ((equal subject "") (values subject subject-pruned-flag)) - (t (values - (or (gethash subject mh-thread-subject-hash) - (setf (gethash subject mh-thread-subject-hash) subject)) - subject-pruned-flag))))) - -(defun mh-thread-container-subject (container) - "Return the subject of CONTAINER. -If CONTAINER is empty return the subject info of one of its children." - (cond ((and (mh-container-message container) - (mh-message-id (mh-container-message container))) - (mh-message-subject (mh-container-message container))) - (t (block nil - (dolist (kid (mh-container-children container)) - (when (and (mh-container-message kid) - (mh-message-id (mh-container-message kid))) - (let ((kid-message (mh-container-message kid))) - (return (mh-message-subject kid-message))))) - (error "This can't happen!"))))) - -(defun mh-thread-rewind-pruning () - "Restore the thread tree to its state before pruning." - (while mh-thread-history - (let ((action (pop mh-thread-history))) - (cond ((eq (car action) 'DROP) - (mh-thread-remove-parent-link (cadr action)) - (mh-thread-add-link (caddr action) (cadr action))) - ((eq (car action) 'PROMOTE) - (let ((node (cadr action)) - (parent (caddr action)) - (children (cdddr action))) - (dolist (child children) - (mh-thread-remove-parent-link child) - (mh-thread-add-link node child)) - (mh-thread-add-link parent node))) - ((eq (car action) 'SUBJECT) - (let ((node (cadr action))) - (mh-thread-remove-parent-link node) - (setf (mh-container-real-child-p node) t))))))) - -(defun mh-thread-prune-containers (roots) - "Prune empty containers in the containers ROOTS." - (let ((dfs-ordered-nodes ()) - (work-list roots)) - (while work-list - (let ((node (pop work-list))) - (dolist (child (mh-container-children node)) - (push child work-list)) - (push node dfs-ordered-nodes))) - (while dfs-ordered-nodes - (let ((node (pop dfs-ordered-nodes))) - (cond ((gethash (mh-message-id (mh-container-message node)) - mh-thread-id-index-map) - ;; Keep it - (setf (mh-container-children node) - (mh-thread-sort-containers (mh-container-children node)))) - ((and (mh-container-children node) - (or (null (cdr (mh-container-children node))) - (mh-container-parent node))) - ;; Promote kids - (let ((children ())) - (dolist (kid (mh-container-children node)) - (mh-thread-remove-parent-link kid) - (mh-thread-add-link (mh-container-parent node) kid) - (push kid children)) - (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) - mh-thread-history) - (mh-thread-remove-parent-link node))) - ((mh-container-children node) - ;; Promote the first orphan to parent and add the other kids as - ;; his children - (setf (mh-container-children node) - (mh-thread-sort-containers (mh-container-children node))) - (let ((new-parent (car (mh-container-children node))) - (other-kids (cdr (mh-container-children node)))) - (mh-thread-remove-parent-link new-parent) - (dolist (kid other-kids) - (mh-thread-remove-parent-link kid) - (setf (mh-container-real-child-p kid) nil) - (mh-thread-add-link new-parent kid t)) - (push `(PROMOTE ,node ,(mh-container-parent node) - ,new-parent ,@other-kids) - mh-thread-history) - (mh-thread-remove-parent-link node))) - (t - ;; Drop it - (push `(DROP ,node ,(mh-container-parent node)) - mh-thread-history) - (mh-thread-remove-parent-link node))))) - (let ((results ())) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (and (null (mh-container-parent v)) - (gethash (mh-message-id (mh-container-message v)) - mh-thread-id-index-map)) - (push v results))) - mh-thread-id-table) - (mh-thread-sort-containers results)))) - -(defun mh-thread-sort-containers (containers) - "Sort a list of message CONTAINERS to be in ascending order wrt index." - (sort containers - #'(lambda (x y) - (when (and (mh-container-message x) (mh-container-message y)) - (let* ((id-x (mh-message-id (mh-container-message x))) - (id-y (mh-message-id (mh-container-message y))) - (index-x (gethash id-x mh-thread-id-index-map)) - (index-y (gethash id-y mh-thread-id-index-map))) - (and (integerp index-x) (integerp index-y) - (< index-x index-y))))))) - -(defsubst mh-thread-group-by-subject (roots) - "Group the set of message containers, ROOTS based on subject. -Bug: Check for and make sure that something without Re: is made the parent in -preference to something that has it." - (clrhash mh-thread-subject-container-hash) - (let ((results ())) - (dolist (root roots) - (let* ((subject (mh-thread-container-subject root)) - (parent (gethash subject mh-thread-subject-container-hash))) - (cond (parent (mh-thread-remove-parent-link root) - (mh-thread-add-link parent root t) - (setf (mh-container-real-child-p root) nil) - (push `(SUBJECT ,root) mh-thread-history)) - (t - (setf (gethash subject mh-thread-subject-container-hash) root) - (push root results))))) - (nreverse results))) - -(defsubst mh-thread-process-in-reply-to (reply-to-header) - "Extract message id's from REPLY-TO-HEADER. -Ideally this should have some regexp which will try to guess if a string -between < and > is a message id and not an email address. For now it will -take the last string inside angles." - (let ((end (mh-search-from-end ?> reply-to-header))) - (when (numberp end) - (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) - (when (numberp begin) - (list (substring reply-to-header begin (1+ end)))))))) - -(defun mh-thread-set-tables (folder) - "Use the tables of FOLDER in current buffer." - (flet ((mh-get-table (symbol) - (save-excursion - (set-buffer folder) - (symbol-value symbol)))) - (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) - (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) - (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) - (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) - (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) - (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) - (setq mh-thread-subject-container-hash - (mh-get-table 'mh-thread-subject-container-hash)) - (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) - (setq mh-thread-history (mh-get-table 'mh-thread-history)))) - -(defsubst mh-thread-update-id-index-maps (id index) - "Message with id, ID is the message in INDEX. -The function also checks for duplicate messages (that is multiple messages -with the same ID). These messages are put in the `mh-thread-duplicates' hash -table." - (let ((old-index (gethash id mh-thread-id-index-map))) - (when old-index (push old-index (gethash id mh-thread-duplicates))) - (setf (gethash id mh-thread-id-index-map) index) - (setf (gethash index mh-thread-index-id-map) id))) +(defun mh-range-to-msg-list (range) + "Return a list of messages for RANGE. - +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use." + (let (msg-list) + (mh-iterate-on-range msg range + (push msg msg-list)) + (nreverse msg-list))) + +;;;###mh-autoload +(defun mh-translate-range (folder expr) + "In FOLDER, translate the string EXPR to a list of messages numbers." + (save-excursion + (let ((strings (delete "" (split-string expr "[ \t\n]"))) + (result ())) + (ignore-errors + (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings) + (set-buffer mh-temp-buffer) + (goto-char (point-min)) + (while (re-search-forward "/\\([0-9]*\\)$" nil t) + (push (string-to-number (match-string 1)) result)) + (nreverse result))))) + +(defun mh-range-completion-function (string predicate flag) + "Programmable completion of message ranges. +STRING is the user input that is to be completed. PREDICATE if non-nil is a +function used to filter the possible choices and FLAG determines whether the +completion is over." + (let* ((candidates mh-range-seq-names) + (last-char (and (not (equal string "")) + (aref string (1- (length string))))) + (last-word (cond ((null last-char) "") + ((memq last-char '(? ?- ?:)) "") + (t (car (last (split-string string "[ -:]+")))))) + (prefix (substring string 0 (- (length string) (length last-word))))) + (cond ((eq flag nil) + (let ((res (try-completion last-word candidates predicate))) + (cond ((null res) nil) + ((eq res t) t) + (t (concat prefix res))))) + ((eq flag t) + (all-completions last-word candidates predicate)) + ((eq flag 'lambda) + (loop for x in candidates + when (equal x last-word) return t + finally return nil))))) -;;; Generate Threads... +(defun mh-seq-names (seq-list) + "Return an alist containing the names of the SEQ-LIST." + (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) + seq-list)) -(defvar mh-message-id-regexp "^<.*@.*>$" - "Regexp to recognize whether a string is a message identifier.") +(defun mh-folder-size (folder) + "Find size of FOLDER." + (if mh-flists-present-flag + (mh-folder-size-flist folder) + (mh-folder-size-folder folder))) -(defun mh-thread-generate (folder msg-list) - "Scan FOLDER to get info for threading. -Only information about messages in MSG-LIST are added to the tree." +(defun mh-folder-size-flist (folder) + "Find size of FOLDER using \"flist\"." (with-temp-buffer - (mh-thread-set-tables folder) - (when msg-list - (apply - #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil - "-width" "10000" "-format" - "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" - folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) + (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero" + "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq)) (goto-char (point-min)) - (let ((roots ()) - (case-fold-search t)) - (block nil - (while (not (eobp)) - (block process-message - (let* ((index-line - (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (index (car (read-from-string index-line))) - (id (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (refs (prog1 (buffer-substring (point) (line-end-position)) - (forward-line))) - (in-reply-to (prog1 (buffer-substring (point) - (line-end-position)) - (forward-line))) - (subject (prog1 - (buffer-substring (point) (line-end-position)) - (forward-line))) - (subject-re-p nil)) - (unless (gethash index mh-thread-scan-line-map) - (return-from process-message)) - (unless (integerp index) (return)) ;Error message here - (multiple-value-setq (subject subject-re-p) - (mh-thread-prune-subject subject)) - (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) - (setq refs (loop for x in (append (split-string refs) in-reply-to) - when (string-match mh-message-id-regexp x) - collect x)) - (setq id (mh-thread-canonicalize-id id)) - (mh-thread-update-id-index-maps id index) - (setq refs (mapcar #'mh-thread-canonicalize-id refs)) - (mh-thread-get-message id subject-re-p subject refs) - (do ((ancestors refs (cdr ancestors))) - ((null (cdr ancestors)) - (when (car ancestors) - (mh-thread-remove-parent-link id) - (mh-thread-add-link (car ancestors) id))) - (mh-thread-add-link (car ancestors) (cadr ancestors))))))) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (null (mh-container-parent v)) - (push v roots))) - mh-thread-id-table) - (setq roots (mh-thread-prune-containers roots)) - (prog1 (setq roots (mh-thread-group-by-subject roots)) - (let ((history mh-thread-history)) - (set-buffer folder) - (setq mh-thread-history history)))))) + (multiple-value-bind (folder unseen total) + (mh-parse-flist-output-line + (buffer-substring (point) (mh-line-end-position))) + (values total unseen folder)))) -;;;###mh-autoload -(defun mh-thread-inc (folder start-point) - "Update thread tree for FOLDER. -All messages after START-POINT are added to the thread tree." - (mh-thread-rewind-pruning) - (goto-char start-point) - (let ((msg-list ())) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) - (push index msg-list) - (setf (gethash index mh-thread-scan-line-map) - (mh-thread-parse-scan-line))) - (forward-line))) - (let ((thread-tree (mh-thread-generate folder msg-list)) - (buffer-read-only nil) - (old-buffer-modified-flag (buffer-modified-p))) - (delete-region (point-min) (point-max)) - (mh-thread-print-scan-lines thread-tree) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-cur) - (set-buffer-modified-p old-buffer-modified-flag)))) - -(defun mh-thread-generate-scan-lines (tree level) - "Generate scan lines. -TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices -to the corresponding scan lines and LEVEL used to determine indentation of -the message." - (cond ((null tree) nil) - ((mh-thread-container-p tree) - (let* ((message (mh-container-message tree)) - (id (mh-message-id message)) - (index (gethash id mh-thread-id-index-map)) - (duplicates (gethash id mh-thread-duplicates)) - (new-level (+ level 2)) - (dupl-flag t) - (force-angle-flag nil) - (increment-level-flag nil)) - (dolist (scan-line (mapcar (lambda (x) - (gethash x mh-thread-scan-line-map)) - (reverse (cons index duplicates)))) - (when scan-line - (when (and dupl-flag (equal level 0) - (mh-thread-ancestor-p mh-thread-last-ancestor tree)) - (setq level (+ level 2) - new-level (+ new-level 2) - force-angle-flag t)) - (when (equal level 0) - (setq mh-thread-last-ancestor tree) - (while (mh-container-parent mh-thread-last-ancestor) - (setq mh-thread-last-ancestor - (mh-container-parent mh-thread-last-ancestor)))) - (let* ((lev (if dupl-flag level new-level)) - (square-flag (or (and (mh-container-real-child-p tree) - (not force-angle-flag) - dupl-flag) - (equal lev 0)))) - (insert (car scan-line) - (format (format "%%%ss" lev) "") - (if square-flag "[" "<") - (cadr scan-line) - (if square-flag "]" ">") - (truncate-string-to-width - (caddr scan-line) (- mh-thread-body-width lev)) - "\n")) - (setq increment-level-flag t) - (setq dupl-flag nil))) - (unless increment-level-flag (setq new-level level)) - (dolist (child (mh-container-children tree)) - (mh-thread-generate-scan-lines child new-level)))) - (t (let ((nlevel (+ level 2))) - (dolist (ch tree) - (mh-thread-generate-scan-lines ch nlevel)))))) - -;; Another and may be better approach would be to generate all the info from -;; the scan which generates the threading info. For now this will have to do. -(defun mh-thread-parse-scan-line (&optional string) - "Parse a scan line. -If optional argument STRING is given then that is assumed to be the scan line. -Otherwise uses the line at point as the scan line to parse." - (let* ((string (or string - (buffer-substring-no-properties (line-beginning-position) - (line-end-position)))) - (first-string (substring string 0 (+ mh-cmd-note 8)))) - (setf (elt first-string mh-cmd-note) ? ) - (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) - (setf (elt first-string (1+ mh-cmd-note)) ? )) - (list first-string - (substring string - (+ mh-cmd-note mh-scan-field-from-start-offset) - (+ mh-cmd-note mh-scan-field-from-end-offset -2)) - (substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) - string))) - -;;;###mh-autoload -(defun mh-thread-add-spaces (count) - "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." - (let ((spaces (format (format "%%%ss" count) ""))) - (while (not (eobp)) - (let* ((msg-num (mh-get-msg-num nil)) - (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) - (when (numberp msg-num) - (setf (gethash msg-num mh-thread-scan-line-map) - (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) - (forward-line 1)))) - -(defun mh-thread-print-scan-lines (thread-tree) - "Print scan lines in THREAD-TREE in threaded mode." - (let ((mh-thread-body-width (- (window-width) mh-cmd-note - (1- mh-scan-field-subject-start-offset))) - (mh-thread-last-ancestor nil)) - (if (null mh-index-data) - (mh-thread-generate-scan-lines thread-tree -2) - (loop for x in (mh-index-group-by-folder) - do (let* ((old-map mh-thread-scan-line-map) - (mh-thread-scan-line-map (make-hash-table))) - (setq mh-thread-last-ancestor nil) - (loop for msg in (cdr x) - do (let ((v (gethash msg old-map))) - (when v - (setf (gethash msg mh-thread-scan-line-map) v)))) - (when (> (hash-table-count mh-thread-scan-line-map) 0) - (insert (if (bobp) "" "\n") (car x) "\n") - (mh-thread-generate-scan-lines thread-tree -2))))))) - -(defun mh-thread-folder () - "Generate thread view of folder." - (message "Threading %s..." (buffer-name)) - (mh-thread-initialize) - (goto-char (point-min)) - (let ((msg-list ())) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when (numberp index) - (push index msg-list) - (setf (gethash index mh-thread-scan-line-map) - (mh-thread-parse-scan-line)))) - (forward-line)) - (let* ((range (mh-coalesce-msg-list msg-list)) - (thread-tree (mh-thread-generate (buffer-name) range))) - (delete-region (point-min) (point-max)) - (mh-thread-print-scan-lines thread-tree) - (mh-notate-user-sequences) - (mh-notate-deleted-and-refiled) - (mh-notate-cur) - (message "Threading %s...done" (buffer-name))))) +(defun mh-folder-size-folder (folder) + "Find size of FOLDER using \"folder\"." + (with-temp-buffer + (let ((u (length (cdr (assoc mh-unseen-seq + (mh-read-folder-sequences folder nil)))))) + (call-process (expand-file-name "folder" mh-progs) nil t nil + "-norecurse" folder) + (goto-char (point-min)) + (if (re-search-forward " has \\([0-9]+\\) " nil t) + (values (string-to-number (match-string 1)) u folder) + (values 0 u folder))))) ;;;###mh-autoload -(defun mh-toggle-threads () - "Toggle threaded view of folder." - (interactive) - (let ((msg-at-point (mh-get-msg-num nil)) - (old-buffer-modified-flag (buffer-modified-p)) - (buffer-read-only nil)) - (cond ((memq 'unthread mh-view-ops) - (unless (mh-valid-view-change-operation-p 'unthread) - (error "Can't unthread folder")) - (let ((msg-list ())) - (goto-char (point-min)) - (while (not (eobp)) - (let ((index (mh-get-msg-num nil))) - (when index - (push index msg-list))) - (forward-line)) - (mh-scan-folder mh-current-folder - (mapcar #'(lambda (x) (format "%s" x)) - (mh-coalesce-msg-list msg-list)) - t)) - (when mh-index-data - (mh-index-insert-folder-headers) - (mh-notate-cur))) - (t (mh-thread-folder) - (push 'unthread mh-view-ops))) - (when msg-at-point (mh-goto-msg msg-at-point t t)) - (set-buffer-modified-p old-buffer-modified-flag) - (mh-recenter nil))) +(defun mh-parse-flist-output-line (line &optional current-folder) + "Parse LINE to generate folder name, unseen messages and total messages. +If CURRENT-FOLDER is non-nil then it contains the current folder +name and it is used to avoid problems in corner cases involving +folders whose names end with a '+' character." + (with-temp-buffer + (insert line) + (goto-char (point-max)) + (let (folder unseen total p) + (when (search-backward " out of " (point-min) t) + (setq total (string-to-number + (buffer-substring-no-properties + (match-end 0) (mh-line-end-position)))) + (when (search-backward " in sequence " (point-min) t) + (setq p (point)) + (when (search-backward " has " (point-min) t) + (setq unseen (string-to-number (buffer-substring-no-properties + (match-end 0) p))) + (while (eq (char-after) ? ) + (backward-char)) + (setq folder (buffer-substring-no-properties + (point-min) (1+ (point)))) + (when (and (equal (aref folder (1- (length folder))) ?+) + (equal current-folder folder)) + (setq folder (substring folder 0 (1- (length folder))))) + (values (format "+%s" folder) unseen total))))))) ;;;###mh-autoload -(defun mh-thread-forget-message (index) - "Forget the message INDEX from the threading tables." - (let* ((id (gethash index mh-thread-index-id-map)) - (id-index (gethash id mh-thread-id-index-map)) - (duplicates (gethash id mh-thread-duplicates))) - (remhash index mh-thread-index-id-map) - (remhash index mh-thread-scan-line-map) - (cond ((and (eql index id-index) (null duplicates)) - (remhash id mh-thread-id-index-map)) - ((eql index id-index) - (setf (gethash id mh-thread-id-index-map) (car duplicates)) - (setf (gethash (car duplicates) mh-thread-index-id-map) id) - (setf (gethash id mh-thread-duplicates) (cdr duplicates))) - (t - (setf (gethash id mh-thread-duplicates) - (remove index duplicates)))))) +(defun mh-read-folder-sequences (folder save-refiles) + "Read and return the predefined sequences for a FOLDER. +If SAVE-REFILES is non-nil, then keep the sequences +that note messages to be refiled." + (let ((seqs ())) + (cond (save-refiles + (mh-mapc (function (lambda (seq) ; Save the refiling sequences + (if (mh-folder-name-p (mh-seq-name seq)) + (setq seqs (cons seq seqs))))) + mh-seq-list))) + (save-excursion + (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list")) + (progn + ;; look for name in line of form "cur: 4" or "myseq (private): 23" + (while (re-search-forward "^[^: ]+" nil t) + (setq seqs (cons (mh-make-seq (intern (buffer-substring + (match-beginning 0) + (match-end 0))) + (mh-read-msg-list)) + seqs))) + (delete-region (point-min) (point))))) ; avoid race with + ; mh-process-daemon + seqs)) + +(defun mh-read-msg-list () + "Return a list of message numbers from point to the end of the line. +Expands ranges into set of individual numbers." + (let ((msgs ()) + (end-of-line (save-excursion (end-of-line) (point))) + num) + (while (re-search-forward "[0-9]+" end-of-line t) + (setq num (string-to-number (buffer-substring (match-beginning 0) + (match-end 0)))) + (cond ((looking-at "-") ; Message range + (forward-char 1) + (re-search-forward "[0-9]+" end-of-line t) + (let ((num2 (string-to-number + (buffer-substring (match-beginning 0) + (match-end 0))))) + (if (< num2 num) + (error "Bad message range: %d-%d" num num2)) + (while (<= num num2) + (setq msgs (cons num msgs)) + (setq num (1+ num))))) + ((not (zerop num)) ;"pick" outputs "0" to mean no match + (setq msgs (cons num msgs))))) + msgs)) -;;; Operations on threads - -(defun mh-thread-current-indentation-level () - "Find the number of spaces by which current message is indented." - (save-excursion - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level 0)) - (beginning-of-line) - (forward-char address-start-offset) - (while (char-equal (char-after) ? ) - (incf level) - (forward-char)) - level))) +;;; Notation ;;;###mh-autoload -(defun mh-thread-next-sibling (&optional previous-flag) - "Jump to next sibling. -With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (beginning-of-line) - (let ((point (point)) - (done nil) - (my-level (mh-thread-current-indentation-level))) - (while (and (not done) - (equal (forward-line (if previous-flag -1 1)) 0) - (not (eobp))) - (let ((level (mh-thread-current-indentation-level))) - (cond ((equal level my-level) - (setq done 'success)) - ((< level my-level) - (message "No %s sibling" (if previous-flag "previous" "next")) - (setq done 'failure))))) - (cond ((eq done 'success) (mh-maybe-show)) - ((eq done 'failure) (goto-char point)) - (t (message "No %s sibling" (if previous-flag "previous" "next")) - (goto-char point))))) +(defun mh-notate (msg notation offset) + "Mark MSG with the character NOTATION at position OFFSET. +Null MSG means the message at cursor. +If NOTATION is nil then no change in the buffer occurs." + (save-excursion + (if (or (null msg) + (mh-goto-msg msg t t)) + (with-mh-folder-updating (t) + (beginning-of-line) + (forward-char offset) + (let* ((change-stack-flag + (and (equal offset + (+ mh-cmd-note mh-scan-field-destination-offset)) + (not (eq notation mh-note-seq)))) + (msg (and change-stack-flag (or msg (mh-get-msg-num nil)))) + (stack (and msg (gethash msg mh-sequence-notation-history))) + (notation (or notation (char-after)))) + (if stack + ;; The presence of the stack tells us that we don't need to + ;; notate the message, since the notation would be replaced + ;; by a sequence notation. So we will just put the notation + ;; at the bottom of the stack. If the sequence is deleted, + ;; the correct notation will be shown. + (setf (gethash msg mh-sequence-notation-history) + (reverse (cons notation (cdr (reverse stack))))) + ;; Since we don't have any sequence notations in the way, just + ;; notate the scan line. + (delete-char 1) + (insert notation)) + (when change-stack-flag + (mh-thread-update-scan-line-map msg notation offset))))))) ;;;###mh-autoload -(defun mh-thread-previous-sibling () - "Jump to previous sibling." - (interactive) - (mh-thread-next-sibling t)) - -(defun mh-thread-immediate-ancestor () - "Jump to immediate ancestor in thread tree." - (beginning-of-line) - (let ((point (point)) - (ancestor-level (- (mh-thread-current-indentation-level) 2)) - (done nil)) - (if (< ancestor-level 0) - nil - (while (and (not done) (equal (forward-line -1) 0)) - (when (equal ancestor-level (mh-thread-current-indentation-level)) - (setq done t))) - (unless done - (goto-char point)) - done))) +(defun mh-notate-cur () + "Mark the MH sequence cur. +In addition to notating the current message with `mh-note-cur' +the function uses `overlay-arrow-position' to put a marker in the +fringe." + (let ((cur (car (mh-seq-to-msgs 'cur)))) + (when (and cur (mh-goto-msg cur t t)) + (beginning-of-line) + (when (looking-at mh-scan-good-msg-regexp) + (mh-notate nil mh-note-cur mh-cmd-note)) + (setq mh-arrow-marker (set-marker mh-arrow-marker (point))) + (setq overlay-arrow-position mh-arrow-marker)))) ;;;###mh-autoload -(defun mh-thread-ancestor (&optional thread-root-flag) - "Jump to the ancestor of current message. -If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the -thread tree the message belongs to." - (interactive "P") - (beginning-of-line) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point"))) - (let ((current-level (mh-thread-current-indentation-level))) - (cond (thread-root-flag - (while (mh-thread-immediate-ancestor)) - (mh-maybe-show)) - ((equal current-level 1) - (message "Message has no ancestor")) - (t (mh-thread-immediate-ancestor) - (mh-maybe-show))))) - -(defun mh-thread-find-children () - "Return a region containing the current message and its children. -The result is returned as a list of two elements. The first is the point at the -start of the region and the second is the point at the end." - (beginning-of-line) - (if (eobp) - nil - (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width - mh-scan-date-width 1)) - (level (mh-thread-current-indentation-level)) - spaces begin) - (setq begin (point)) - (setq spaces (format (format "%%%ss" (1+ level)) "")) - (forward-line) - (block nil - (while (not (eobp)) - (forward-char address-start-offset) - (unless (equal (string-match spaces (buffer-substring-no-properties - (point) (line-end-position))) - 0) - (beginning-of-line) - (backward-char) - (return)) - (forward-line))) - (list begin (point))))) +(defun mh-remove-cur-notation () + "Remove old cur notation." + (let ((cur-msg (car (mh-seq-to-msgs 'cur)))) + (save-excursion + (when (and cur-msg + (mh-goto-msg cur-msg t t) + (looking-at mh-scan-cur-msg-number-regexp)) + (mh-notate nil ? mh-cmd-note) + (setq overlay-arrow-position nil))))) +;; FIXME? We may want to clear all notations and add one for current-message +;; and process user sequences. ;;;###mh-autoload -(defun mh-thread-delete () - "Mark current message and all its children for subsequent deletion." - (interactive) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (let ((region (mh-thread-find-children))) - (mh-iterate-on-messages-in-region () (car region) (cadr region) - (mh-delete-a-msg nil)) - (mh-next-msg))))) +(defun mh-notate-deleted-and-refiled () + "Notate messages marked for deletion or refiling. +Messages to be deleted are given by `mh-delete-list' while +messages to be refiled are present in `mh-refile-list'." + (let ((refiled-hash (make-hash-table)) + (deleted-hash (make-hash-table))) + (dolist (msg mh-delete-list) + (setf (gethash msg deleted-hash) t)) + (dolist (dest-msg-list mh-refile-list) + (dolist (msg (cdr dest-msg-list)) + (setf (gethash msg refiled-hash) t))) + (mh-iterate-on-messages-in-region msg (point-min) (point-max) + (cond ((gethash msg refiled-hash) + (mh-notate nil mh-note-refiled mh-cmd-note)) + ((gethash msg deleted-hash) + (mh-notate nil mh-note-deleted mh-cmd-note)))))) ;;;###mh-autoload -(defun mh-thread-refile (folder) - "Mark current message and all its children for refiling to FOLDER." - (interactive (list (intern (mh-prompt-for-refile-folder)))) - (cond ((not (memq 'unthread mh-view-ops)) - (error "Folder isn't threaded")) - ((eobp) - (error "No message at point")) - (t (let ((region (mh-thread-find-children))) - (mh-iterate-on-messages-in-region () (car region) (cadr region) - (mh-refile-a-msg nil folder)) - (mh-next-msg))))) - - - -;; Tick mark handling - -;; Functions to highlight and unhighlight ticked messages. -(defun mh-tick-add-overlay () - "Add tick overlay to current line." +(defun mh-notate-user-sequences (&optional range) + "Mark user-defined sequences in RANGE. + +Check the documentation of `mh-interactive-range' to see how +RANGE is read in interactive use; if nil all messages are +notated." + (unless range + (setq range (cons (point-min) (point-max)))) + (let ((seqs mh-seq-list) + (msg-hash (make-hash-table))) + (dolist (seq seqs) + (dolist (msg (mh-seq-msgs seq)) + (push (car seq) (gethash msg msg-hash)))) + (mh-iterate-on-range msg range + (loop for seq in (gethash msg msg-hash) + do (mh-add-sequence-notation msg (mh-internal-seq seq)))))) + +(defun mh-add-sequence-notation (msg internal-seq-flag) + "Add sequence notation to the MSG on the current line. +If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if +font-lock is turned on." (with-mh-folder-updating (t) - (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)))))) + (save-excursion + (beginning-of-line) + (if internal-seq-flag + (progn + ;; Change the buffer so that if transient-mark-mode is active + ;; and there is an active region it will get deactivated as in + ;; the case of user sequences. + (mh-notate nil nil mh-cmd-note) + (when font-lock-mode + (font-lock-fontify-region (point) (mh-line-end-position)))) + (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) + (let ((stack (gethash msg mh-sequence-notation-history))) + (setf (gethash msg mh-sequence-notation-history) + (cons (char-after) stack))) + (mh-notate nil mh-note-seq + (+ mh-cmd-note mh-scan-field-destination-offset)))))) + +(defun mh-remove-sequence-notation (msg internal-seq-flag &optional all) + "Remove sequence notation from the MSG on the current line. +If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to +highlight the sequence. In that case, no notation needs to be removed. +Otherwise the effect of inserting `mh-note-seq' needs to be reversed. +If ALL is non-nil, then all sequence marks on the scan line are +removed." + (with-mh-folder-updating (t) + ;; This takes care of internal sequences... + (mh-notate nil nil mh-cmd-note) + (unless internal-seq-flag + ;; ... and this takes care of user sequences. + (let ((stack (gethash msg mh-sequence-notation-history))) + (while (and all (cdr stack)) + (setq stack (cdr stack))) + (when stack + (save-excursion + (beginning-of-line) + (forward-char (+ mh-cmd-note mh-scan-field-destination-offset)) + (delete-char 1) + (insert (car stack)))) + (setf (gethash msg mh-sequence-notation-history) (cdr stack)))))) ;;;###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))))) - (unless mh-tick-seq - (error "Enable ticking by customizing `mh-tick-seq'")) - (let* ((tick-seq (mh-find-seq mh-tick-seq)) - (tick-seq-msgs (mh-seq-msgs tick-seq))) - (mh-iterate-on-messages-in-region msg begin end - (cond ((member msg tick-seq-msgs) - (mh-undefine-sequence mh-tick-seq (list msg)) - (setcdr tick-seq (delq msg (cdr tick-seq))) - (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) - (mh-tick-remove-overlay)) - (t - (mh-add-msgs-to-seq (list msg) mh-tick-seq nil t) - (setq mh-last-seq-used mh-tick-seq) - (mh-tick-add-overlay)))) - (when (and (eq mh-tick-seq mh-narrowed-to-seq) - (not mh-tick-seq-changed-when-narrowed-flag)) - (setq mh-tick-seq-changed-when-narrowed-flag t) - (let ((ticked-msgs (mh-seq-msgs (mh-find-seq mh-tick-seq)))) - (mh-iterate-on-messages-in-region msg (point-min) (point-max) - (mh-notate-tick msg ticked-msgs t)))))) +(defun mh-remove-all-notation () + "Remove all notations on all scan lines that MH-E introduces." + (save-excursion + (setq overlay-arrow-position nil) + (goto-char (point-min)) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (mh-notate nil ? mh-cmd-note) + (mh-remove-sequence-notation msg nil t)) + (clrhash mh-sequence-notation-history))) -;;;###mh-autoload -(defun mh-narrow-to-tick () - "Restrict display of this folder to just messages in `mh-tick-seq'. -Use \\\\[mh-widen] to undo this command." - (interactive) - (cond ((not mh-tick-seq) - (error "Enable ticking by customizing `mh-tick-seq'")) - ((null (mh-seq-msgs (mh-find-seq mh-tick-seq))) - (message "No messages in tick sequence")) - (t (mh-narrow-to-seq mh-tick-seq)))) + +;; XXX Unused, delete, or create bind key? +(defun mh-rename-seq (sequence new-name) + "Rename SEQUENCE to have NEW-NAME." + (interactive (list (mh-read-seq "Old" t) + (intern (read-string "New sequence name: ")))) + (let ((old-seq (mh-find-seq sequence))) + (or old-seq + (error "Sequence %s does not exist" sequence)) + ;; Create new sequence first, since it might raise an error. + (mh-define-sequence new-name (mh-seq-msgs old-seq)) + (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) + (rplaca old-seq new-name))) (provide 'mh-seq) -;;; Local Variables: -;;; indent-tabs-mode: nil -;;; sentence-end-double-space: nil -;;; End: +;; Local Variables: +;; indent-tabs-mode: nil +;; sentence-end-double-space: nil +;; End: -;;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942 +;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942 ;;; mh-seq.el ends here