diff options
author | Bill Wohler <wohler@newt.com> | 2004-07-13 03:06:25 +0000 |
---|---|---|
committer | Bill Wohler <wohler@newt.com> | 2004-07-13 03:06:25 +0000 |
commit | a66894d8b489dfdfafc2058cd181fefbb894fbf0 (patch) | |
tree | 39c692b4da2f58c1f9830381b0befa1ec3d56b87 /lisp/mh-e/mh-seq.el | |
parent | 0117451de7e30adf240f369f26b7667dbf3788bf (diff) | |
download | emacs-a66894d8b489dfdfafc2058cd181fefbb894fbf0.tar.gz |
Upgraded to MH-E version 7.4.4.
See etc/MH-E-NEWS and lisp/mh-e/ChangeLog for details.
Diffstat (limited to 'lisp/mh-e/mh-seq.el')
-rw-r--r-- | lisp/mh-e/mh-seq.el | 616 |
1 files changed, 436 insertions, 180 deletions
diff --git a/lisp/mh-e/mh-seq.el b/lisp/mh-e/mh-seq.el index e441466a7b4..20950d36c4c 100644 --- a/lisp/mh-e/mh-seq.el +++ b/lisp/mh-e/mh-seq.el @@ -1,6 +1,6 @@ ;;; mh-seq.el --- MH-E sequences support -;; Copyright (C) 1993, 1995, 2001, 02, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1993, 1995, 2001, 02, 03, 2004 Free Software Foundation, Inc. ;; Author: Bill Wohler <wohler@newt.com> ;; Maintainer: Bill Wohler <wohler@newt.com> @@ -70,7 +70,8 @@ ;;; Code: -(require 'cl) +(require 'mh-utils) +(mh-require-cl) (require 'mh-e) ;; Shush the byte-compiler @@ -110,7 +111,7 @@ "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 +(defvar mh-thread-scan-line-map-stack 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 @@ -131,7 +132,7 @@ redone to get the new thread tree. This makes incremental threading easier.") (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-scan-line-map-stack) (make-variable-buffer-local 'mh-thread-subject-container-hash) (make-variable-buffer-local 'mh-thread-duplicates) (make-variable-buffer-local 'mh-thread-history) @@ -140,14 +141,19 @@ redone to get the new thread tree. This makes incremental threading easier.") (defun mh-delete-seq (sequence) "Delete the SEQUENCE." (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 (defvar view-exit-action) @@ -221,16 +227,15 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." (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)) @@ -252,29 +257,31 @@ Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." (error "No messages in sequence `%s'" (symbol-name sequence)))))) ;;;###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. + +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)) + (original-msgs (mh-seq-msgs (mh-find-seq sequence))) + (folders (list mh-current-folder)) (msg-list ())) - (mh-iterate-on-msg-or-seq m msg-or-seq + (mh-iterate-on-range m range (push m msg-list) - (mh-notate nil note-seq (1+ mh-cmd-note))) + (unless (memq m original-msgs) + (mh-add-sequence-notation m internal-seq-flag))) (mh-add-msgs-to-seq msg-list sequence nil t) (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. @@ -284,33 +291,46 @@ OP is one of 'widen and 'unthread." (t nil))) ;;;###mh-autoload -(defun mh-widen () - "Remove restrictions from current folder, thereby showing all messages." - (interactive) +(defun mh-widen (&optional all-flag) + "Remove last restriction from current folder. +If optional prefix argument ALL-FLAG is non-nil, then unwind to the beginning +of the view stack thereby showing all messages that the buffer originally +contained." + (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 @@ -319,6 +339,7 @@ OP is one of 'widen and 'unthread." ;; FIXME? We may want to clear all notations and add one for current-message ;; and process user sequences. +;;;###mh-autoload (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 @@ -342,13 +363,15 @@ refiled are present in `mh-refile-list'." ;;; of the form: ;;; ((seq-name msgs ...) (seq-name msgs ...) ...) +(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." (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) @@ -360,7 +383,8 @@ defaults to the first sequence containing the current message." (if default (format "[%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) @@ -370,6 +394,126 @@ defaults to the first sequence containing the current message." (error "No messages in sequence `%s'" seq)) seq)) +;;; Functions to read ranges with completion... +(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) + +(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))))) + +;;;###mh-autoload +(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)) + (default (cond ((or (eq default t) (stringp default)) default) + ((symbolp default) (symbol-name default)))) + (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))) + (str (cond ((and guess large + (setq default (format "last:%s" mh-large-folder) + prompt (format "%s (folder has %s messages)" + prompt (car counts))) + nil)) + ((and guess (not large) (setq default "all") nil)) + ((eq default nil) "") + (t (format "[%s] " 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: %s" prompt str) + '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-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 (car (read-from-string (match-string 1))) result)) + (nreverse result))))) + (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)))) @@ -427,7 +571,7 @@ uses `overlay-arrow-position' to put a marker in the fringe." (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) @@ -458,17 +602,15 @@ 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))))))) @@ -509,32 +651,36 @@ If VAR is nil then the loop is executed without any binding." (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) +(defmacro mh-iterate-on-range (var range &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. +VAR is bound to each message in turn in a loop over RANGE, which can be a +message number, a list of message numbers, a sequence, a region in a cons +cell, or a MH range (something like last:20) in a string. In each iteration, +BODY is executed. -The parameter MSG-OR-SEQ is usually created with `mh-interactive-msg-or-seq' +The parameter RANGE is usually created with `mh-interactive-range' 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)) ()) + `(cond ((numberp ,range) + (when (mh-goto-msg ,range t t) + (let ,(if binding-needed-flag `((,var ,range)) ()) ,@body))) - ((and (consp ,msg-or-seq) - (numberp (car ,msg-or-seq)) (numberp (cdr ,msg-or-seq))) + ((and (consp ,range) + (numberp (car ,range)) (numberp (cdr ,range))) (mh-iterate-on-messages-in-region ,var - (car ,msg-or-seq) (cdr ,msg-or-seq) + (car ,range) (cdr ,range) ,@body)) - (t (let ((,msgs (if (and ,msg-or-seq (symbolp ,msg-or-seq)) - (mh-seq-to-msgs ,msg-or-seq) - ,msg-or-seq)) + (t (let ((,msgs (cond ((and ,range (symbolp ,range)) + (mh-seq-to-msgs ,range)) + ((stringp ,range) + (mh-translate-range mh-current-folder + ,range)) + (t ,range))) (,seq-hash-table (make-hash-table))) (dolist (msg ,msgs) (setf (gethash msg ,seq-hash-table) t)) @@ -543,38 +689,39 @@ in order to provide a uniform interface to MH-E functions." (let ,(if binding-needed-flag `((,var v)) ()) ,@body)))))))) -(put 'mh-iterate-on-msg-or-seq 'lisp-indent-hook 'defun) +(put 'mh-iterate-on-range 'lisp-indent-hook 'defun) ;;;###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 +(defun mh-range-to-msg-list (range) + "Return a list of messages for RANGE. +RANGE 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 + (mh-iterate-on-range msg range (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. +(defun mh-interactive-range (range-prompt) + "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. -If optional prefix argument provided, then prompt for message sequence with -SEQUENCE-PROMPT and return sequence. + +If optional prefix argument is provided, then prompt for message range with +RANGE-PROMPT. A list of messages in that range is returned. + +If a MH range is given, say something like last:20, then a list containing +the messages in that range is returned. + Otherwise, the message number at point is returned. -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)))) +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)) + (t (mh-get-msg-num t)))) ;;;###mh-autoload (defun mh-region-to-msg-list (begin end) @@ -591,6 +738,8 @@ provide a uniform interface to MH-E functions." ;;; Commands to handle new 'subject sequence. ;;; Or "Poor man's threading" by psg. +;;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number +;;; 41 for the max size of the subject part. Avoiding this would be desirable. (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. @@ -601,6 +750,21 @@ Return number of messages put in the sequence: 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 (memq 'unthread mh-view-ops) + (mh-subject-to-sequence-threaded all) + (mh-subject-to-sequence-unthreaded all))) + +(defun mh-subject-to-sequence-unthreaded (all) + "Put all following messages with same subject in sequence 'subject. +This function only works with an unthreaded folder. 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. + +Return number of messages put in the sequence: + + 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 @@ -628,8 +792,7 @@ Return number of messages put in the sequence: ;; 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)) + (if (assoc 'subject 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 @@ -639,6 +802,39 @@ Return number of messages put in the sequence: (t 0)))))) +(defun mh-subject-to-sequence-threaded (all) + "Put all messages with the same subject in the 'subject sequence. +This function works when the folder is threaded. In this situation the subject +could get truncated and so the normal matching doesn't work. + +The parameter ALL is non-nil then all the messages in the buffer are +considered, otherwise only the messages after the current one are taken into +account." + (let* ((cur (mh-get-msg-num nil)) + (subject (mh-thread-find-msg-subject cur)) + region msgs) + (if (null subject) + (and (message "No subject line") nil) + (setq region (cons (if all (point-min) (point)) (point-max))) + (mh-iterate-on-range msg region + (when (eq (mh-thread-find-msg-subject msg) subject) + (push msg msgs))) + (setq msgs (sort msgs #'mh-lessp)) + (if (null msgs) + 0 + (when (assoc 'subject mh-seq-list) + (mh-delete-seq 'subject)) + (mh-add-msgs-to-seq msgs 'subject) + (length msgs))))) + +(defun mh-thread-find-msg-subject (msg) + "Find canonicalized subject of MSG. +This function can only be used the folder is threaded." + (ignore-errors + (mh-message-subject + (mh-container-message (gethash (gethash msg mh-thread-index-id-map) + mh-thread-id-table))))) + ;;;###mh-autoload (defun mh-narrow-to-subject () "Narrow to a sequence containing all following messages with same subject." @@ -657,6 +853,99 @@ Return number of messages put in the sequence: (if (numberp num) (mh-goto-msg num t t)))))) +(defun mh-read-pick-regexp (default) + "With prefix arg read a pick regexp. +If no prefix arg is given, then return DEFAULT." + (let ((default-string (loop for x in default concat (format " %s" x)))) + (if (or current-prefix-arg (equal default-string "")) + (delete "" (split-string (read-string "Pick regexp: " default-string))) + default))) + +;;;###mh-autoload +(defun mh-narrow-to-from (&optional regexp) + "Limit to messages with the same From header field as the message at point. +With a prefix argument, prompt for the regular expression, REGEXP given to +pick." + (interactive + (list (mh-read-pick-regexp (mh-current-message-header-field 'from)))) + (mh-narrow-to-header-field 'from regexp)) + +;;;###mh-autoload +(defun mh-narrow-to-cc (&optional regexp) + "Limit to messages with the same Cc header field as the message at point. +With a prefix argument, prompt for the regular expression, REGEXP given to +pick." + (interactive + (list (mh-read-pick-regexp (mh-current-message-header-field 'cc)))) + (mh-narrow-to-header-field 'cc regexp)) + +;;;###mh-autoload +(defun mh-narrow-to-to (&optional regexp) + "Limit to messages with the same To header field as the message at point. +With a prefix argument, prompt for the regular expression, REGEXP given to +pick." + (interactive + (list (mh-read-pick-regexp (mh-current-message-header-field 'to)))) + (mh-narrow-to-header-field 'to regexp)) + +(defun mh-narrow-to-header-field (header-field regexp) + "Limit to messages whose HEADER-FIELD match REGEXP. +The MH command pick is used to do the match." + (let ((folder mh-current-folder) + (original (mh-coalesce-msg-list + (mh-range-to-msg-list (cons (point-min) (point-max))))) + (msg-list ())) + (with-temp-buffer + (apply #'mh-exec-cmd-output "pick" nil folder + (append original (list "-list") regexp)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((num (read-from-string + (buffer-substring (point) (line-end-position))))) + (when (numberp (car num)) (push (car num) msg-list)) + (forward-line)))) + (if (null msg-list) + (message "No matches") + (when (assoc 'header mh-seq-list) (mh-delete-seq 'header)) + (mh-add-msgs-to-seq msg-list 'header) + (mh-narrow-to-seq 'header)))) + +(defun mh-current-message-header-field (header-field) + "Return a pick regexp to match HEADER-FIELD of the message at point." + (let ((num (mh-get-msg-num nil))) + (when num + (let ((folder mh-current-folder)) + (with-temp-buffer + (insert-file-contents-literally (mh-msg-filename num folder)) + (goto-char (point-min)) + (when (search-forward "\n\n" nil t) + (narrow-to-region (point-min) (point))) + (let* ((field (or (message-fetch-field (format "%s" header-field)) + "")) + (field-option (format "-%s" header-field)) + (patterns (loop for x in (split-string field "[ ]*,[ ]*") + unless (equal x "") + collect (if (string-match "<\\(.*@.*\\)>" x) + (match-string 1 x) + x)))) + (when patterns + (loop with accum = `(,field-option ,(car patterns)) + for e in (cdr patterns) + do (setq accum `(,field-option ,e "-or" ,@accum)) + finally return accum)))))))) + +;;;###mh-autoload +(defun mh-narrow-to-range (range) + "Limit to messages in RANGE. + +Check the documentation of `mh-interactive-range' to see how RANGE is read in +interactive use." + (interactive (list (mh-interactive-range "Narrow to"))) + (when (assoc 'range mh-seq-list) (mh-delete-seq 'range)) + (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range) + (mh-narrow-to-seq 'range)) + + ;;;###mh-autoload (defun mh-delete-subject () "Mark all following messages with same subject to be deleted. @@ -689,28 +978,23 @@ subject for deletion." ;;; Message threading: +(defmacro mh-thread-initialize-hash (var test) + "Initialize the hash table in VAR. +TEST is the test to use when creating a new hash table." + (unless (symbolp var) (error "Expected a symbol: %s" var)) + `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) + (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 ())))) + "Make new hash tables, or clear them if already present." + (mh-thread-initialize-hash mh-thread-id-hash #'equal) + (mh-thread-initialize-hash mh-thread-subject-hash #'equal) + (mh-thread-initialize-hash mh-thread-id-table #'eq) + (mh-thread-initialize-hash mh-thread-id-index-map #'eq) + (mh-thread-initialize-hash mh-thread-index-id-map #'eql) + (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) + (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) + (mh-thread-initialize-hash mh-thread-duplicates #'eq) + (setq mh-thread-history ())) (defsubst mh-thread-id-container (id) "Given ID, return the corresponding container in `mh-thread-id-table'. @@ -959,7 +1243,7 @@ preference to something that has it." (push root results))))) (nreverse results))) -(defsubst mh-thread-process-in-reply-to (reply-to-header) +(defun 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 @@ -1071,6 +1355,7 @@ Only information about messages in MSG-LIST are added to the tree." "Update thread tree for FOLDER. All messages after START-POINT are added to the thread tree." (mh-thread-rewind-pruning) + (mh-remove-all-notation) (goto-char start-point) (let ((msg-list ())) (while (not (eobp)) @@ -1085,7 +1370,6 @@ All messages after START-POINT are added to the thread tree." (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)))) @@ -1150,18 +1434,30 @@ 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)) ? )) + (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) + (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) + (first-string (substring string 0 address-start))) (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)) + (substring string address-start (- body-start 2)) + (substring string body-start) string))) ;;;###mh-autoload +(defun mh-thread-update-scan-line-map (msg notation offset) + "In threaded view update `mh-thread-scan-line-map'. +MSG is the message being notated with NOTATION at OFFSET." + (let* ((msg (or msg (mh-get-msg-num nil))) + (cur-scan-line (and mh-thread-scan-line-map + (gethash msg mh-thread-scan-line-map))) + (old-scan-lines (loop for map in mh-thread-scan-line-map-stack + collect (and map (gethash msg map)))) + (notation (if (stringp notation) (aref notation 0) notation))) + (when cur-scan-line + (setf (aref (car cur-scan-line) offset) notation)) + (dolist (line old-scan-lines) + (when line (setf (aref (car line) offset) notation))))) + +;;;###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) ""))) @@ -1197,14 +1493,11 @@ Otherwise uses the line at point as the scan line to parse." (message "Threading %s..." (buffer-name)) (mh-thread-initialize) (goto-char (point-min)) + (mh-remove-all-notation) (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)) + (mh-iterate-on-range msg (cons (point-min) (point-max)) + (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) + (push msg msg-list)) (let* ((range (mh-coalesce-msg-list msg-list)) (thread-tree (mh-thread-generate (buffer-name) range))) (delete-region (point-min) (point-max)) @@ -1403,68 +1696,31 @@ start of the region and the second is the point at the end." ;; Tick mark handling -;; Functions to highlight and unhighlight ticked messages. -(defun mh-tick-add-overlay () - "Add tick overlay to current line." - (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)))))) - -;;;###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))))) +(defun mh-toggle-tick (range) + "Toggle tick mark of all messages in RANGE." + (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))) - (mh-iterate-on-messages-in-region msg begin end + (tick-seq-msgs (mh-seq-msgs tick-seq)) + (ticked ()) + (unticked ())) + (mh-iterate-on-range msg range (cond ((member msg tick-seq-msgs) - (mh-undefine-sequence mh-tick-seq (list msg)) + (push msg unticked) (setcdr tick-seq (delq msg (cdr tick-seq))) (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) - (mh-tick-remove-overlay)) + (mh-remove-sequence-notation msg t)) (t - (mh-add-msgs-to-seq (list msg) mh-tick-seq nil t) + (push msg ticked) (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)))))) + (mh-add-sequence-notation msg t)))) + (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-narrow-to-tick () |