HCoop / bpt / emacs.git / blame
| Commit | Line | Data |
|---|---|---|
| bdcfe844 | 1 | ;;; mh-seq.el --- MH-E sequences support |
| c26cf6c8 | 2 | |
| e495eaec | 3 | ;; Copyright (C) 1993, 1995, |
| deceef67 | 4 | ;; 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
| a1b4049d BW |
5 | |
| 6 | ;; Author: Bill Wohler <wohler@newt.com> | |
| 7 | ;; Maintainer: Bill Wohler <wohler@newt.com> | |
| 8 | ;; Keywords: mail | |
| 9 | ;; See: mh-e.el | |
| c26cf6c8 | 10 | |
| 60370d40 | 11 | ;; This file is part of GNU Emacs. |
| c26cf6c8 | 12 | |
| 9b7bc076 | 13 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| c26cf6c8 RS |
14 | ;; it under the terms of the GNU General Public License as published by |
| 15 | ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 | ;; any later version. | |
| 17 | ||
| 9b7bc076 | 18 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| c26cf6c8 RS |
19 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 21 | ;; GNU General Public License for more details. | |
| 22 | ||
| 23 | ;; You should have received a copy of the GNU General Public License | |
| b578f267 | 24 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 3a35cf56 LK |
25 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 26 | ;; Boston, MA 02110-1301, USA. | |
| c26cf6c8 RS |
27 | |
| 28 | ;;; Commentary: | |
| bdcfe844 BW |
29 | ;; |
| 30 | ;; This tries to implement the algorithm described at: | |
| 31 | ;; http://www.jwz.org/doc/threading.html | |
| 32 | ;; It is also a start to implementing the IMAP Threading extension RFC. The | |
| 33 | ;; implementation lacks the reference and subject canonicalization of the | |
| 34 | ;; RFC. | |
| 35 | ;; | |
| 36 | ;; In the presentation buffer, children messages are shown indented with | |
| 37 | ;; either [ ] or < > around them. Square brackets ([ ]) denote that the | |
| 38 | ;; algorithm can point out some headers which when taken together implies | |
| 39 | ;; that the unindented message is an ancestor of the indented message. If | |
| 40 | ;; no such proof exists then angles (< >) are used. | |
| 41 | ;; | |
| 42 | ;; Some issues and problems are as follows: | |
| 43 | ;; | |
| 44 | ;; (1) Scan truncates the fields at length 512. So longer references: | |
| 45 | ;; headers get mutilated. The same kind of MH format string works when | |
| 46 | ;; composing messages. Is there a way to avoid this? My scan command | |
| 47 | ;; is as follows: | |
| 48 | ;; scan +folder -width 10000 \ | |
| 49 | ;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" | |
| 50 | ;; I would really appreciate it if someone would help me with this. | |
| 51 | ;; | |
| 3d7ca223 BW |
52 | ;; (2) Implement heuristics to recognize message identifiers in |
| 53 | ;; In-Reply-To: header. Right now it just assumes that the last text | |
| 54 | ;; between angles (< and >) is the message identifier. There is the | |
| 55 | ;; chance that this will incorrectly use an email address like a | |
| 56 | ;; message identifier. | |
| bdcfe844 | 57 | ;; |
| 3d7ca223 | 58 | ;; (3) Error checking of found message identifiers should be done. |
| bdcfe844 BW |
59 | ;; |
| 60 | ;; (4) Since this breaks the assumption that message indices increase as | |
| 61 | ;; one goes down the buffer, the binary search based mh-goto-msg | |
| 62 | ;; doesn't work. I have a simpler replacement which may be less | |
| 63 | ;; efficient. | |
| 64 | ;; | |
| 3d7ca223 | 65 | ;; (5) Better canonicalizing for message identifier and subject strings. |
| bdcfe844 | 66 | ;; |
| c26cf6c8 | 67 | |
| bdcfe844 | 68 | ;; Internal support for MH-E package. |
| c26cf6c8 | 69 | |
| 847b8219 KH |
70 | ;;; Change Log: |
| 71 | ||
| c26cf6c8 RS |
72 | ;;; Code: |
| 73 | ||
| f0d73c14 | 74 | (eval-when-compile (require 'mh-acros)) |
| a66894d8 | 75 | (mh-require-cl) |
| c26cf6c8 RS |
76 | (require 'mh-e) |
| 77 | ||
| bdcfe844 BW |
78 | ;; Shush the byte-compiler |
| 79 | (defvar tool-bar-mode) | |
| 80 | ||
| 81 | ;;; Data structures (used in message threading)... | |
| f0d73c14 BW |
82 | (mh-defstruct (mh-thread-message (:conc-name mh-message-) |
| 83 | (:constructor mh-thread-make-message)) | |
| bdcfe844 BW |
84 | (id nil) |
| 85 | (references ()) | |
| 86 | (subject "") | |
| 87 | (subject-re-p nil)) | |
| 88 | ||
| f0d73c14 BW |
89 | (mh-defstruct (mh-thread-container (:conc-name mh-container-) |
| 90 | (:constructor mh-thread-make-container)) | |
| bdcfe844 BW |
91 | message parent children |
| 92 | (real-child-p t)) | |
| 93 | ||
| 94 | ||
| 847b8219 | 95 | ;;; Internal variables: |
| bdcfe844 BW |
96 | (defvar mh-last-seq-used nil |
| 97 | "Name of seq to which a msg was last added.") | |
| 847b8219 | 98 | |
| bdcfe844 BW |
99 | (defvar mh-non-seq-mode-line-annotation nil |
| 100 | "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") | |
| 847b8219 | 101 | |
| bdcfe844 BW |
102 | ;;; Maps and hashes... |
| 103 | (defvar mh-thread-id-hash nil | |
| 3d7ca223 | 104 | "Hashtable used to canonicalize message identifiers.") |
| bdcfe844 BW |
105 | (defvar mh-thread-subject-hash nil |
| 106 | "Hashtable used to canonicalize subject strings.") | |
| 107 | (defvar mh-thread-id-table nil | |
| 3d7ca223 | 108 | "Thread ID table maps from message identifiers to message containers.") |
| bdcfe844 | 109 | (defvar mh-thread-id-index-map nil |
| 3d7ca223 | 110 | "Table to look up message index number from message identifier.") |
| bdcfe844 | 111 | (defvar mh-thread-index-id-map nil |
| 3d7ca223 | 112 | "Table to look up message identifier from message index.") |
| bdcfe844 BW |
113 | (defvar mh-thread-scan-line-map nil |
| 114 | "Map of message index to various parts of the scan line.") | |
| a66894d8 | 115 | (defvar mh-thread-scan-line-map-stack nil |
| bdcfe844 BW |
116 | "Old map of message index to various parts of the scan line. |
| 117 | This is the original map that is stored when the folder is narrowed.") | |
| 118 | (defvar mh-thread-subject-container-hash nil | |
| 119 | "Hashtable used to group messages by subject.") | |
| 120 | (defvar mh-thread-duplicates nil | |
| 3d7ca223 | 121 | "Hashtable used to associate messages with the same message identifier.") |
| bdcfe844 BW |
122 | (defvar mh-thread-history () |
| 123 | "Variable to remember the transformations to the thread tree. | |
| 124 | When new messages are added, these transformations are rewound, then the | |
| 125 | links are added from the newly seen messages. Finally the transformations are | |
| 126 | redone to get the new thread tree. This makes incremental threading easier.") | |
| 127 | (defvar mh-thread-body-width nil | |
| 128 | "Width of scan substring that contains subject and body of message.") | |
| c26cf6c8 | 129 | |
| bdcfe844 BW |
130 | (make-variable-buffer-local 'mh-thread-id-hash) |
| 131 | (make-variable-buffer-local 'mh-thread-subject-hash) | |
| 132 | (make-variable-buffer-local 'mh-thread-id-table) | |
| 133 | (make-variable-buffer-local 'mh-thread-id-index-map) | |
| 134 | (make-variable-buffer-local 'mh-thread-index-id-map) | |
| 135 | (make-variable-buffer-local 'mh-thread-scan-line-map) | |
| a66894d8 | 136 | (make-variable-buffer-local 'mh-thread-scan-line-map-stack) |
| bdcfe844 BW |
137 | (make-variable-buffer-local 'mh-thread-subject-container-hash) |
| 138 | (make-variable-buffer-local 'mh-thread-duplicates) | |
| 139 | (make-variable-buffer-local 'mh-thread-history) | |
| c26cf6c8 | 140 | |
| c3d9274a | 141 | ;;;###mh-autoload |
| 847b8219 | 142 | (defun mh-delete-seq (sequence) |
| be33fce4 BW |
143 | "Delete SEQUENCE. |
| 144 | ||
| 145 | You are prompted for the sequence to delete. Note that this deletes only the | |
| 146 | sequence, not the messages in the sequence. If you want to delete the | |
| 147 | messages, use \"\\[universal-argument] \\[mh-delete-msg]\"." | |
| c26cf6c8 | 148 | (interactive (list (mh-read-seq-default "Delete" t))) |
| a66894d8 BW |
149 | (let ((msg-list (mh-seq-to-msgs sequence)) |
| 150 | (internal-flag (mh-internal-seq sequence)) | |
| 151 | (folders-changed (list mh-current-folder))) | |
| 152 | (mh-iterate-on-range msg sequence | |
| 153 | (mh-remove-sequence-notation msg internal-flag)) | |
| 3d7ca223 BW |
154 | (mh-undefine-sequence sequence '("all")) |
| 155 | (mh-delete-seq-locally sequence) | |
| a66894d8 BW |
156 | (when mh-index-data |
| 157 | (setq folders-changed | |
| 158 | (append folders-changed | |
| 159 | (mh-index-delete-from-sequence sequence msg-list)))) | |
| 160 | (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) | |
| 161 | (apply #'mh-speed-flists t folders-changed)))) | |
| c26cf6c8 | 162 | |
| bdcfe844 BW |
163 | ;; Avoid compiler warnings |
| 164 | (defvar view-exit-action) | |
| c26cf6c8 | 165 | |
| c3d9274a BW |
166 | ;;;###mh-autoload |
| 167 | (defun mh-list-sequences () | |
| be33fce4 BW |
168 | "List all sequences in folder. |
| 169 | The list appears in a buffer named \"*MH-E Sequences*\"." | |
| c3d9274a BW |
170 | (interactive) |
| 171 | (let ((folder mh-current-folder) | |
| 3d7ca223 | 172 | (temp-buffer mh-sequences-buffer) |
| c3d9274a BW |
173 | (seq-list mh-seq-list) |
| 174 | (max-len 0)) | |
| c26cf6c8 RS |
175 | (with-output-to-temp-buffer temp-buffer |
| 176 | (save-excursion | |
| c3d9274a BW |
177 | (set-buffer temp-buffer) |
| 178 | (erase-buffer) | |
| 179 | (message "Listing sequences ...") | |
| 180 | (insert "Sequences in folder " folder ":\n") | |
| 181 | (let ((seq-list seq-list)) | |
| 182 | (while seq-list | |
| 183 | (setq max-len | |
| 184 | (max (length (symbol-name (mh-seq-name (pop seq-list)))) | |
| 185 | max-len))) | |
| 186 | (setq max-len (+ 2 max-len))) | |
| 187 | (while seq-list | |
| 188 | (let ((name (mh-seq-name (car seq-list))) | |
| 189 | (sorted-seq-msgs | |
| 190 | (mh-coalesce-msg-list | |
| 191 | (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))) | |
| 192 | name-spec) | |
| 193 | (insert (setq name-spec (format (format "%%%ss:" max-len) name))) | |
| 194 | (while sorted-seq-msgs | |
| 195 | (let ((next-element (format " %s" (pop sorted-seq-msgs)))) | |
| 196 | (when (>= (+ (current-column) (length next-element)) | |
| 197 | (window-width)) | |
| 198 | (insert "\n") | |
| 199 | (insert (format (format "%%%ss" (length name-spec)) ""))) | |
| 200 | (insert next-element))) | |
| 201 | (insert "\n")) | |
| 202 | (setq seq-list (cdr seq-list))) | |
| 203 | (goto-char (point-min)) | |
| e495eaec | 204 | (view-mode-enter) |
| c3d9274a BW |
205 | (setq view-exit-action 'kill-buffer) |
| 206 | (message "Listing sequences...done"))))) | |
| 207 | ||
| 208 | ;;;###mh-autoload | |
| 847b8219 | 209 | (defun mh-msg-is-in-seq (message) |
| f0d73c14 BW |
210 | "Display the sequences in which the current message appears. |
| 211 | Use a prefix argument to display the sequences in which another MESSAGE | |
| 212 | appears." | |
| 213 | (interactive "P") | |
| 214 | (if (not message) | |
| 215 | (setq message (mh-get-msg-num t))) | |
| bdcfe844 | 216 | (let* ((dest-folder (loop for seq in mh-refile-list |
| f0d73c14 BW |
217 | when (member message (cdr seq)) return (car seq) |
| 218 | finally return nil)) | |
| bdcfe844 BW |
219 | (deleted-flag (unless dest-folder (member message mh-delete-list)))) |
| 220 | (message "Message %d%s is in sequences: %s" | |
| 221 | message | |
| 222 | (cond (dest-folder (format " (to be refiled to %s)" dest-folder)) | |
| 223 | (deleted-flag (format " (to be deleted)")) | |
| 224 | (t "")) | |
| 225 | (mapconcat 'concat | |
| 226 | (mh-list-to-string (mh-seq-containing-msg message t)) | |
| 227 | " ")))) | |
| c26cf6c8 | 228 | |
| 924df208 BW |
229 | ;; Avoid compiler warning |
| 230 | (defvar tool-bar-map) | |
| 231 | ||
| a10f4ace BW |
232 | (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) |
| 233 | ||
| c3d9274a | 234 | ;;;###mh-autoload |
| 847b8219 | 235 | (defun mh-narrow-to-seq (sequence) |
| be33fce4 BW |
236 | "Restrict display to messages in SEQUENCE. |
| 237 | ||
| 238 | You are prompted for the name of the sequence. What this command does is show | |
| 239 | only those messages that are in the selected sequence in the MH-Folder buffer. | |
| 240 | In addition, it limits further MH-E searches to just those messages. | |
| 241 | ||
| 242 | When you want to widen the view to all your messages again, use \\[mh-widen]." | |
| c26cf6c8 | 243 | (interactive (list (mh-read-seq "Narrow to" t))) |
| 847b8219 KH |
244 | (with-mh-folder-updating (t) |
| 245 | (cond ((mh-seq-to-msgs sequence) | |
| bdcfe844 | 246 | (mh-remove-all-notation) |
| c3d9274a | 247 | (let ((eob (point-max)) |
| bdcfe844 | 248 | (msg-at-cursor (mh-get-msg-num nil))) |
| a66894d8 | 249 | (push mh-thread-scan-line-map mh-thread-scan-line-map-stack) |
| bdcfe844 | 250 | (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) |
| c3d9274a | 251 | (mh-copy-seq-to-eob sequence) |
| a66894d8 BW |
252 | (push (buffer-substring-no-properties (point-min) eob) |
| 253 | mh-folder-view-stack) | |
| 254 | (delete-region (point-min) eob) | |
| bdcfe844 | 255 | (mh-notate-deleted-and-refiled) |
| 3d7ca223 | 256 | (mh-notate-cur) |
| bdcfe844 | 257 | (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) |
| c3d9274a BW |
258 | (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) |
| 259 | (setq mh-mode-line-annotation (symbol-name sequence)) | |
| 260 | (mh-make-folder-mode-line) | |
| 261 | (mh-recenter nil) | |
| 924df208 BW |
262 | (when (and (boundp 'tool-bar-mode) tool-bar-mode) |
| 263 | (set (make-local-variable 'tool-bar-map) | |
| 264 | mh-folder-seq-tool-bar-map) | |
| 265 | (when (buffer-live-p (get-buffer mh-show-buffer)) | |
| 266 | (save-excursion | |
| 267 | (set-buffer (get-buffer mh-show-buffer)) | |
| 268 | (set (make-local-variable 'tool-bar-map) | |
| 269 | mh-show-seq-tool-bar-map)))) | |
| bdcfe844 | 270 | (push 'widen mh-view-ops))) |
| c3d9274a BW |
271 | (t |
| 272 | (error "No messages in sequence `%s'" (symbol-name sequence)))))) | |
| c26cf6c8 | 273 | |
| c3d9274a | 274 | ;;;###mh-autoload |
| a66894d8 BW |
275 | (defun mh-put-msg-in-seq (range sequence) |
| 276 | "Add RANGE to SEQUENCE. | |
| 277 | ||
| 278 | Check the documentation of `mh-interactive-range' to see how RANGE is read in | |
| 279 | interactive use." | |
| 280 | (interactive (list (mh-interactive-range "Add messages from") | |
| c3d9274a | 281 | (mh-read-seq-default "Add to" nil))) |
| a66894d8 BW |
282 | (unless (mh-valid-seq-p sequence) |
| 283 | (error "Can't put message in invalid sequence `%s'" sequence)) | |
| 924df208 | 284 | (let* ((internal-seq-flag (mh-internal-seq sequence)) |
| a66894d8 BW |
285 | (original-msgs (mh-seq-msgs (mh-find-seq sequence))) |
| 286 | (folders (list mh-current-folder)) | |
| f0d73c14 BW |
287 | (msg-list (mh-range-to-msg-list range))) |
| 288 | (mh-add-msgs-to-seq msg-list sequence nil t) | |
| a66894d8 | 289 | (mh-iterate-on-range m range |
| a66894d8 BW |
290 | (unless (memq m original-msgs) |
| 291 | (mh-add-sequence-notation m internal-seq-flag))) | |
| 3d7ca223 | 292 | (if (not internal-seq-flag) |
| 924df208 | 293 | (setq mh-last-seq-used sequence)) |
| a66894d8 BW |
294 | (when mh-index-data |
| 295 | (setq folders | |
| 296 | (append folders (mh-index-add-to-sequence sequence msg-list)))) | |
| 924df208 | 297 | (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p)) |
| a66894d8 | 298 | (apply #'mh-speed-flists t folders)))) |
| c26cf6c8 | 299 | |
| bdcfe844 BW |
300 | (defun mh-valid-view-change-operation-p (op) |
| 301 | "Check if the view change operation can be performed. | |
| 302 | OP is one of 'widen and 'unthread." | |
| 303 | (cond ((eq (car mh-view-ops) op) | |
| 304 | (pop mh-view-ops)) | |
| 305 | (t nil))) | |
| c26cf6c8 | 306 | |
| c3d9274a | 307 | ;;;###mh-autoload |
| a66894d8 | 308 | (defun mh-widen (&optional all-flag) |
| be33fce4 | 309 | "Remove last restriction. |
| f0d73c14 | 310 | If optional prefix argument ALL-FLAG is non-nil, remove all limits." |
| a66894d8 | 311 | (interactive "P") |
| a1b4049d | 312 | (let ((msg (mh-get-msg-num nil))) |
| a66894d8 BW |
313 | (when mh-folder-view-stack |
| 314 | (cond (all-flag | |
| 315 | (while (cdr mh-view-ops) | |
| 316 | (setq mh-view-ops (cdr mh-view-ops))) | |
| 317 | (when (eq (car mh-view-ops) 'widen) | |
| 318 | (setq mh-view-ops (cdr mh-view-ops)))) | |
| 319 | ((mh-valid-view-change-operation-p 'widen) nil) | |
| bdcfe844 BW |
320 | ((memq 'widen mh-view-ops) |
| 321 | (while (not (eq (car mh-view-ops) 'widen)) | |
| 322 | (setq mh-view-ops (cdr mh-view-ops))) | |
| a66894d8 | 323 | (setq mh-view-ops (cdr mh-view-ops))) |
| bdcfe844 | 324 | (t (error "Widening is not applicable"))) |
| a66894d8 BW |
325 | ;; If ALL-FLAG is non-nil then rewind stacks |
| 326 | (when all-flag | |
| 327 | (while (cdr mh-thread-scan-line-map-stack) | |
| 328 | (setq mh-thread-scan-line-map-stack | |
| 329 | (cdr mh-thread-scan-line-map-stack))) | |
| 330 | (while (cdr mh-folder-view-stack) | |
| 331 | (setq mh-folder-view-stack (cdr mh-folder-view-stack)))) | |
| 332 | (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack)) | |
| c26cf6c8 | 333 | (with-mh-folder-updating (t) |
| a1b4049d | 334 | (delete-region (point-min) (point-max)) |
| a66894d8 BW |
335 | (insert (pop mh-folder-view-stack)) |
| 336 | (mh-remove-all-notation) | |
| a1b4049d BW |
337 | (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) |
| 338 | (mh-make-folder-mode-line)) | |
| 339 | (if msg | |
| bdcfe844 BW |
340 | (mh-goto-msg msg t t)) |
| 341 | (mh-notate-deleted-and-refiled) | |
| 342 | (mh-notate-user-sequences) | |
| 3d7ca223 | 343 | (mh-notate-cur) |
| bdcfe844 | 344 | (mh-recenter nil))) |
| a66894d8 | 345 | (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode) |
| 924df208 BW |
346 | (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map) |
| 347 | (when (buffer-live-p (get-buffer mh-show-buffer)) | |
| 348 | (save-excursion | |
| 349 | (set-buffer (get-buffer mh-show-buffer)) | |
| 350 | (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map))))) | |
| c26cf6c8 | 351 | |
| a1b4049d BW |
352 | ;; FIXME? We may want to clear all notations and add one for current-message |
| 353 | ;; and process user sequences. | |
| a66894d8 | 354 | ;;;###mh-autoload |
| a1b4049d | 355 | (defun mh-notate-deleted-and-refiled () |
| bdcfe844 BW |
356 | "Notate messages marked for deletion or refiling. |
| 357 | Messages to be deleted are given by `mh-delete-list' while messages to be | |
| 358 | refiled are present in `mh-refile-list'." | |
| 3d7ca223 BW |
359 | (let ((refiled-hash (make-hash-table)) |
| 360 | (deleted-hash (make-hash-table))) | |
| 361 | (dolist (msg mh-delete-list) | |
| 362 | (setf (gethash msg deleted-hash) t)) | |
| 363 | (dolist (dest-msg-list mh-refile-list) | |
| 364 | (dolist (msg (cdr dest-msg-list)) | |
| 365 | (setf (gethash msg refiled-hash) t))) | |
| 366 | (mh-iterate-on-messages-in-region msg (point-min) (point-max) | |
| 367 | (cond ((gethash msg refiled-hash) | |
| 368 | (mh-notate nil mh-note-refiled mh-cmd-note)) | |
| 369 | ((gethash msg deleted-hash) | |
| 370 | (mh-notate nil mh-note-deleted mh-cmd-note)))))) | |
| bdcfe844 | 371 | |
| c26cf6c8 RS |
372 | \f |
| 373 | ||
| 374 | ;;; Commands to manipulate sequences. Sequences are stored in an alist | |
| 375 | ;;; of the form: | |
| c3d9274a | 376 | ;;; ((seq-name msgs ...) (seq-name msgs ...) ...) |
| c26cf6c8 | 377 | |
| a66894d8 BW |
378 | (defvar mh-sequence-history ()) |
| 379 | ||
| 380 | ;;;###mh-autoload | |
| c26cf6c8 | 381 | (defun mh-read-seq-default (prompt not-empty) |
| bdcfe844 BW |
382 | "Read and return sequence name with default narrowed or previous sequence. |
| 383 | PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a | |
| 384 | non-empty sequence is read." | |
| 847b8219 | 385 | (mh-read-seq prompt not-empty |
| a66894d8 | 386 | (or mh-last-seq-used |
| c3d9274a | 387 | (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) |
| c26cf6c8 | 388 | |
| c26cf6c8 | 389 | (defun mh-read-seq (prompt not-empty &optional default) |
| bdcfe844 BW |
390 | "Read and return a sequence name. |
| 391 | Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY | |
| 392 | flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' | |
| 393 | defaults to the first sequence containing the current message." | |
| c26cf6c8 | 394 | (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" |
| c3d9274a BW |
395 | (if default |
| 396 | (format "[%s] " default) | |
| 397 | "")) | |
| a66894d8 BW |
398 | (mh-seq-names mh-seq-list) |
| 399 | nil nil nil 'mh-sequence-history)) | |
| c3d9274a BW |
400 | (seq (cond ((equal input "%") |
| 401 | (car (mh-seq-containing-msg (mh-get-msg-num t) nil))) | |
| 402 | ((equal input "") default) | |
| 403 | (t (intern input)))) | |
| 404 | (msgs (mh-seq-to-msgs seq))) | |
| c26cf6c8 | 405 | (if (and (null msgs) not-empty) |
| c3d9274a | 406 | (error "No messages in sequence `%s'" seq)) |
| c26cf6c8 RS |
407 | seq)) |
| 408 | ||
| a66894d8 BW |
409 | ;;; Functions to read ranges with completion... |
| 410 | (defvar mh-range-seq-names) | |
| 411 | (defvar mh-range-history ()) | |
| 412 | (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map)) | |
| 413 | (define-key mh-range-completion-map " " 'self-insert-command) | |
| 414 | ||
| 415 | (defun mh-range-completion-function (string predicate flag) | |
| 416 | "Programmable completion of message ranges. | |
| 417 | STRING is the user input that is to be completed. PREDICATE if non-nil is a | |
| 418 | function used to filter the possible choices and FLAG determines whether the | |
| 419 | completion is over." | |
| 420 | (let* ((candidates mh-range-seq-names) | |
| 421 | (last-char (and (not (equal string "")) | |
| 422 | (aref string (1- (length string))))) | |
| 423 | (last-word (cond ((null last-char) "") | |
| 424 | ((memq last-char '(? ?- ?:)) "") | |
| 425 | (t (car (last (split-string string "[ -:]+")))))) | |
| 426 | (prefix (substring string 0 (- (length string) (length last-word))))) | |
| 427 | (cond ((eq flag nil) | |
| 428 | (let ((res (try-completion last-word candidates predicate))) | |
| 429 | (cond ((null res) nil) | |
| 430 | ((eq res t) t) | |
| 431 | (t (concat prefix res))))) | |
| 432 | ((eq flag t) | |
| 433 | (all-completions last-word candidates predicate)) | |
| 434 | ((eq flag 'lambda) | |
| 435 | (loop for x in candidates | |
| 436 | when (equal x last-word) return t | |
| 437 | finally return nil))))) | |
| 438 | ||
| 439 | ;;;###mh-autoload | |
| 440 | (defun mh-read-range (prompt &optional folder default | |
| 441 | expand-flag ask-flag number-as-range-flag) | |
| 442 | "Read a message range with PROMPT. | |
| 443 | ||
| 444 | If FOLDER is non-nil then a range is read from that folder, otherwise use | |
| 445 | `mh-current-folder'. | |
| 446 | ||
| 447 | If DEFAULT is a string then use that as default range to return. If DEFAULT is | |
| 448 | nil then ask user with default answer a range based on the sequences that seem | |
| 449 | relevant. Finally if DEFAULT is t, try to avoid prompting the user. Unseen | |
| 450 | messages, if present, are returned. If the folder has fewer than | |
| 451 | `mh-large-folder' messages then \"all\" messages are returned. Finally as a | |
| 452 | last resort prompt the user. | |
| 453 | ||
| 454 | If EXPAND-FLAG is non-nil then a list of message numbers corresponding to the | |
| 455 | input is returned. If this list is empty then an error is raised. If | |
| 456 | EXPAND-FLAG is nil just return the input string. In this case we don't check | |
| 457 | if the range is empty. | |
| 458 | ||
| 459 | If ASK-FLAG is non-nil, then the user is always queried for a range of | |
| 460 | messages. If ASK-FLAG is nil, then the function checks if the unseen sequence | |
| 461 | is non-empty. If that is the case, `mh-unseen-seq', or the list of messages in | |
| 462 | it depending on the value of EXPAND, is returned. Otherwise if the folder has | |
| 463 | fewer than `mh-large-folder' messages then the list of messages corresponding | |
| 464 | to \"all\" is returned. If neither of the above holds then as a last resort | |
| 465 | the user is queried for a range of messages. | |
| 466 | ||
| 467 | If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as input, it | |
| 468 | is interpreted as the range \"last:N\". | |
| 469 | ||
| 470 | This function replaces the existing function `mh-read-msg-range'. Calls to: | |
| 471 | (mh-read-msg-range folder flag) | |
| 472 | should be replaced with: | |
| 473 | (mh-read-range \"Suitable prompt\" folder t nil flag | |
| 474 | mh-interpret-number-as-range-flag)" | |
| 475 | (setq default (or default mh-last-seq-used | |
| 476 | (car (mh-seq-containing-msg (mh-get-msg-num nil) t))) | |
| 477 | prompt (format "%s range" prompt)) | |
| 478 | (let* ((folder (or folder mh-current-folder)) | |
| 479 | (default (cond ((or (eq default t) (stringp default)) default) | |
| 480 | ((symbolp default) (symbol-name default)))) | |
| 481 | (guess (eq default t)) | |
| 482 | (counts (and guess (mh-folder-size folder))) | |
| 483 | (unseen (and counts (> (cadr counts) 0))) | |
| 484 | (large (and counts mh-large-folder (> (car counts) mh-large-folder))) | |
| 485 | (str (cond ((and guess large | |
| 486 | (setq default (format "last:%s" mh-large-folder) | |
| 487 | prompt (format "%s (folder has %s messages)" | |
| 488 | prompt (car counts))) | |
| 489 | nil)) | |
| 490 | ((and guess (not large) (setq default "all") nil)) | |
| 491 | ((eq default nil) "") | |
| 492 | (t (format "[%s] " default)))) | |
| 493 | (minibuffer-local-completion-map mh-range-completion-map) | |
| 494 | (seq-list (if (eq folder mh-current-folder) | |
| 495 | mh-seq-list | |
| 496 | (mh-read-folder-sequences folder nil))) | |
| 497 | (mh-range-seq-names | |
| 498 | (append '(("first") ("last") ("all") ("prev") ("next")) | |
| 499 | (mh-seq-names seq-list))) | |
| 500 | (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq)) | |
| 501 | ((and (not ask-flag) (not large)) "all") | |
| 502 | (t (completing-read (format "%s: %s" prompt str) | |
| 503 | 'mh-range-completion-function nil nil | |
| 504 | nil 'mh-range-history default)))) | |
| 505 | msg-list) | |
| 506 | (when (and number-as-range-flag | |
| 507 | (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input)) | |
| 508 | (setq input (concat "last:" (match-string 1 input)))) | |
| 509 | (cond ((not expand-flag) input) | |
| 510 | ((assoc (intern input) seq-list) | |
| 511 | (cdr (assoc (intern input) seq-list))) | |
| 512 | ((setq msg-list (mh-translate-range folder input)) msg-list) | |
| 513 | (t (error "No messages in range `%s'" input))))) | |
| 514 | ||
| 515 | ;;;###mh-autoload | |
| 516 | (defun mh-translate-range (folder expr) | |
| 517 | "In FOLDER, translate the string EXPR to a list of messages numbers." | |
| 518 | (save-excursion | |
| 519 | (let ((strings (delete "" (split-string expr "[ \t\n]"))) | |
| 520 | (result ())) | |
| 521 | (ignore-errors | |
| 522 | (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings) | |
| 523 | (set-buffer mh-temp-buffer) | |
| 524 | (goto-char (point-min)) | |
| 525 | (while (re-search-forward "/\\([0-9]*\\)$" nil t) | |
| 526 | (push (car (read-from-string (match-string 1))) result)) | |
| 527 | (nreverse result))))) | |
| 528 | ||
| c26cf6c8 | 529 | (defun mh-seq-names (seq-list) |
| bdcfe844 BW |
530 | "Return an alist containing the names of the SEQ-LIST." |
| 531 | (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) | |
| c3d9274a | 532 | seq-list)) |
| c26cf6c8 | 533 | |
| c3d9274a | 534 | ;;;###mh-autoload |
| 847b8219 KH |
535 | (defun mh-rename-seq (sequence new-name) |
| 536 | "Rename SEQUENCE to have NEW-NAME." | |
| c26cf6c8 | 537 | (interactive (list (mh-read-seq "Old" t) |
| c3d9274a | 538 | (intern (read-string "New sequence name: ")))) |
| 847b8219 | 539 | (let ((old-seq (mh-find-seq sequence))) |
| c26cf6c8 | 540 | (or old-seq |
| c3d9274a | 541 | (error "Sequence %s does not exist" sequence)) |
| 847b8219 | 542 | ;; create new sequence first, since it might raise an error. |
| c26cf6c8 | 543 | (mh-define-sequence new-name (mh-seq-msgs old-seq)) |
| 847b8219 | 544 | (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) |
| c26cf6c8 RS |
545 | (rplaca old-seq new-name))) |
| 546 | ||
| 3d7ca223 BW |
547 | ;;;###mh-autoload |
| 548 | (defun mh-notate-cur () | |
| 549 | "Mark the MH sequence cur. | |
| 550 | In addition to notating the current message with `mh-note-cur' the function | |
| 551 | uses `overlay-arrow-position' to put a marker in the fringe." | |
| 552 | (let ((cur (car (mh-seq-to-msgs 'cur)))) | |
| 553 | (when (and cur (mh-goto-msg cur t t)) | |
| 3d7ca223 | 554 | (beginning-of-line) |
| 924df208 BW |
555 | (when (looking-at mh-scan-good-msg-regexp) |
| 556 | (mh-notate nil mh-note-cur mh-cmd-note)) | |
| 3d7ca223 BW |
557 | (setq mh-arrow-marker (set-marker mh-arrow-marker (point))) |
| 558 | (setq overlay-arrow-position mh-arrow-marker)))) | |
| c26cf6c8 | 559 | |
| c3d9274a | 560 | ;;;###mh-autoload |
| c26cf6c8 | 561 | (defun mh-add-to-sequence (seq msgs) |
| bdcfe844 | 562 | "The sequence SEQ is augmented with the messages in MSGS." |
| c26cf6c8 | 563 | ;; Add to a SEQUENCE each message the list of MSGS. |
| a66894d8 | 564 | (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq))) |
| c26cf6c8 | 565 | (if msgs |
| c3d9274a BW |
566 | (apply 'mh-exec-cmd "mark" mh-current-folder "-add" |
| 567 | "-sequence" (symbol-name seq) | |
| 568 | (mh-coalesce-msg-list msgs))))) | |
| c26cf6c8 | 569 | |
| 924df208 BW |
570 | (defvar mh-thread-last-ancestor) |
| 571 | ||
| bdcfe844 BW |
572 | (defun mh-copy-seq-to-eob (seq) |
| 573 | "Copy SEQ to the end of the buffer." | |
| 574 | ;; It is quite involved to write something which will work at any place in | |
| 575 | ;; the buffer, so we will write something which works only at the end of | |
| 576 | ;; the buffer. If we ever need to insert sequences in the middle of the | |
| 577 | ;; buffer, this will need to be fixed. | |
| 578 | (save-excursion | |
| 579 | (let* ((msgs (mh-seq-to-msgs seq)) | |
| 580 | (coalesced-msgs (mh-coalesce-msg-list msgs))) | |
| 581 | (goto-char (point-max)) | |
| 582 | (save-restriction | |
| 583 | (narrow-to-region (point) (point)) | |
| 584 | (mh-regenerate-headers coalesced-msgs t) | |
| c3d9274a BW |
585 | (cond ((memq 'unthread mh-view-ops) |
| 586 | ;; Populate restricted scan-line map | |
| a66894d8 BW |
587 | (mh-remove-all-notation) |
| 588 | (mh-iterate-on-range msg (cons (point-min) (point-max)) | |
| 589 | (setf (gethash msg mh-thread-scan-line-map) | |
| 590 | (mh-thread-parse-scan-line))) | |
| c3d9274a BW |
591 | ;; Remove scan lines and read results from pre-computed tree |
| 592 | (delete-region (point-min) (point-max)) | |
| 924df208 | 593 | (mh-thread-print-scan-lines |
| a66894d8 BW |
594 | (mh-thread-generate mh-current-folder ())) |
| 595 | (mh-notate-user-sequences)) | |
| c3d9274a BW |
596 | (mh-index-data |
| 597 | (mh-index-insert-folder-headers))))))) | |
| c26cf6c8 | 598 | |
| 3d7ca223 BW |
599 | ;;;###mh-autoload |
| 600 | (defmacro mh-iterate-on-messages-in-region (var begin end &rest body) | |
| 601 | "Iterate over region. | |
| 602 | VAR is bound to the message on the current line as we loop starting from BEGIN | |
| 603 | till END. In each step BODY is executed. | |
| 604 | ||
| 605 | If VAR is nil then the loop is executed without any binding." | |
| 606 | (unless (symbolp var) | |
| 607 | (error "Can not bind the non-symbol %s" var)) | |
| 608 | (let ((binding-needed-flag var)) | |
| 609 | `(save-excursion | |
| 610 | (goto-char ,begin) | |
| 924df208 | 611 | (beginning-of-line) |
| 3d7ca223 BW |
612 | (while (and (<= (point) ,end) (not (eobp))) |
| 613 | (when (looking-at mh-scan-valid-regexp) | |
| 614 | (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ()) | |
| 615 | ,@body)) | |
| 616 | (forward-line 1))))) | |
| 617 | ||
| 924df208 BW |
618 | (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun) |
| 619 | ||
| 620 | ;;;###mh-autoload | |
| a66894d8 | 621 | (defmacro mh-iterate-on-range (var range &rest body) |
| 924df208 BW |
622 | "Iterate an operation over a region or sequence. |
| 623 | ||
| a66894d8 BW |
624 | VAR is bound to each message in turn in a loop over RANGE, which can be a |
| 625 | message number, a list of message numbers, a sequence, a region in a cons | |
| 626 | cell, or a MH range (something like last:20) in a string. In each iteration, | |
| 627 | BODY is executed. | |
| 924df208 | 628 | |
| a66894d8 | 629 | The parameter RANGE is usually created with `mh-interactive-range' |
| 924df208 BW |
630 | in order to provide a uniform interface to MH-E functions." |
| 631 | (unless (symbolp var) | |
| 632 | (error "Can not bind the non-symbol %s" var)) | |
| 633 | (let ((binding-needed-flag var) | |
| 634 | (msgs (make-symbol "msgs")) | |
| 635 | (seq-hash-table (make-symbol "seq-hash-table"))) | |
| a66894d8 BW |
636 | `(cond ((numberp ,range) |
| 637 | (when (mh-goto-msg ,range t t) | |
| 638 | (let ,(if binding-needed-flag `((,var ,range)) ()) | |
| 924df208 | 639 | ,@body))) |
| a66894d8 BW |
640 | ((and (consp ,range) |
| 641 | (numberp (car ,range)) (numberp (cdr ,range))) | |
| 924df208 | 642 | (mh-iterate-on-messages-in-region ,var |
| a66894d8 | 643 | (car ,range) (cdr ,range) |
| 924df208 | 644 | ,@body)) |
| a66894d8 BW |
645 | (t (let ((,msgs (cond ((and ,range (symbolp ,range)) |
| 646 | (mh-seq-to-msgs ,range)) | |
| 647 | ((stringp ,range) | |
| 648 | (mh-translate-range mh-current-folder | |
| 649 | ,range)) | |
| 650 | (t ,range))) | |
| 924df208 BW |
651 | (,seq-hash-table (make-hash-table))) |
| 652 | (dolist (msg ,msgs) | |
| 653 | (setf (gethash msg ,seq-hash-table) t)) | |
| 654 | (mh-iterate-on-messages-in-region v (point-min) (point-max) | |
| 655 | (when (gethash v ,seq-hash-table) | |
| 656 | (let ,(if binding-needed-flag `((,var v)) ()) | |
| 657 | ,@body)))))))) | |
| 658 | ||
| a66894d8 | 659 | (put 'mh-iterate-on-range 'lisp-indent-hook 'defun) |
| 924df208 BW |
660 | |
| 661 | ;;;###mh-autoload | |
| a66894d8 BW |
662 | (defun mh-range-to-msg-list (range) |
| 663 | "Return a list of messages for RANGE. | |
| 664 | RANGE can be a message number, a list of message numbers, a sequence, or | |
| 924df208 BW |
665 | a region in a cons cell." |
| 666 | (let (msg-list) | |
| a66894d8 | 667 | (mh-iterate-on-range msg range |
| 924df208 BW |
668 | (push msg msg-list)) |
| 669 | (nreverse msg-list))) | |
| 670 | ||
| 671 | ;;;###mh-autoload | |
| f0d73c14 | 672 | (defun mh-interactive-range (range-prompt &optional default) |
| a66894d8 BW |
673 | "Return interactive specification for message, sequence, range or region. |
| 674 | By convention, the name of this argument is RANGE. | |
| 924df208 BW |
675 | |
| 676 | If variable `transient-mark-mode' is non-nil and the mark is active, then this | |
| 677 | function returns a cons-cell of the region. | |
| a66894d8 BW |
678 | |
| 679 | If optional prefix argument is provided, then prompt for message range with | |
| 680 | RANGE-PROMPT. A list of messages in that range is returned. | |
| 681 | ||
| 682 | If a MH range is given, say something like last:20, then a list containing | |
| 683 | the messages in that range is returned. | |
| 684 | ||
| f0d73c14 BW |
685 | If DEFAULT non-nil then it is returned. |
| 686 | ||
| 924df208 BW |
687 | Otherwise, the message number at point is returned. |
| 688 | ||
| a66894d8 BW |
689 | This function is usually used with `mh-iterate-on-range' in order to provide |
| 690 | a uniform interface to MH-E functions." | |
| 691 | (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end))) | |
| 692 | (current-prefix-arg (mh-read-range range-prompt nil nil t t)) | |
| f0d73c14 | 693 | (default default) |
| a66894d8 | 694 | (t (mh-get-msg-num t)))) |
| 924df208 | 695 | |
| a1b4049d | 696 | \f |
| bdcfe844 | 697 | |
| a1b4049d BW |
698 | ;;; Commands to handle new 'subject sequence. |
| 699 | ;;; Or "Poor man's threading" by psg. | |
| bdcfe844 | 700 | |
| a66894d8 BW |
701 | ;;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number |
| 702 | ;;; 41 for the max size of the subject part. Avoiding this would be desirable. | |
| bdcfe844 | 703 | (defun mh-subject-to-sequence (all) |
| a1b4049d BW |
704 | "Put all following messages with same subject in sequence 'subject. |
| 705 | If arg ALL is t, move to beginning of folder buffer to collect all messages. | |
| 706 | If arg ALL is nil, collect only messages fron current one on forward. | |
| bdcfe844 | 707 | |
| a66894d8 BW |
708 | Return number of messages put in the sequence: |
| 709 | ||
| 710 | nil -> there was no subject line. | |
| 711 | 0 -> there were no later messages with the same subject (sequence not made) | |
| 712 | >1 -> the total number of messages including current one." | |
| 713 | (if (memq 'unthread mh-view-ops) | |
| 714 | (mh-subject-to-sequence-threaded all) | |
| 715 | (mh-subject-to-sequence-unthreaded all))) | |
| 716 | ||
| 717 | (defun mh-subject-to-sequence-unthreaded (all) | |
| 718 | "Put all following messages with same subject in sequence 'subject. | |
| 719 | This function only works with an unthreaded folder. If arg ALL is t, move to | |
| 720 | beginning of folder buffer to collect all messages. If arg ALL is nil, collect | |
| 721 | only messages fron current one on forward. | |
| 722 | ||
| a1b4049d | 723 | Return number of messages put in the sequence: |
| bdcfe844 | 724 | |
| a1b4049d BW |
725 | nil -> there was no subject line. |
| 726 | 0 -> there were no later messages with the same subject (sequence not made) | |
| 727 | >1 -> the total number of messages including current one." | |
| 728 | (if (not (eq major-mode 'mh-folder-mode)) | |
| 729 | (error "Not in a folder buffer")) | |
| 730 | (save-excursion | |
| 731 | (beginning-of-line) | |
| 732 | (if (or (not (looking-at mh-scan-subject-regexp)) | |
| bdcfe844 BW |
733 | (not (match-string 3)) |
| 734 | (string-equal "" (match-string 3))) | |
| f0d73c14 | 735 | (progn (message "No subject line") |
| a1b4049d | 736 | nil) |
| bdcfe844 | 737 | (let ((subject (match-string-no-properties 3)) |
| a1b4049d BW |
738 | (list)) |
| 739 | (if (> (length subject) 41) | |
| 740 | (setq subject (substring subject 0 41))) | |
| 741 | (save-excursion | |
| 742 | (if all | |
| 743 | (goto-char (point-min))) | |
| 744 | (while (re-search-forward mh-scan-subject-regexp nil t) | |
| bdcfe844 | 745 | (let ((this-subject (match-string-no-properties 3))) |
| a1b4049d BW |
746 | (if (> (length this-subject) 41) |
| 747 | (setq this-subject (substring this-subject 0 41))) | |
| 748 | (if (string-equal this-subject subject) | |
| 749 | (setq list (cons (mh-get-msg-num t) list)))))) | |
| 750 | (cond | |
| 751 | (list | |
| 752 | ;; If we created a new sequence, add the initial message to it too. | |
| 753 | (if (not (member (mh-get-msg-num t) list)) | |
| 754 | (setq list (cons (mh-get-msg-num t) list))) | |
| a66894d8 | 755 | (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject)) |
| a1b4049d | 756 | ;; sort the result into a sequence |
| bdcfe844 | 757 | (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) |
| a1b4049d | 758 | (while sorted-list |
| bdcfe844 | 759 | (mh-add-msgs-to-seq (car sorted-list) 'subject nil) |
| a1b4049d BW |
760 | (setq sorted-list (cdr sorted-list))) |
| 761 | (safe-length list))) | |
| 762 | (t | |
| 763 | 0)))))) | |
| 764 | ||
| a66894d8 BW |
765 | (defun mh-subject-to-sequence-threaded (all) |
| 766 | "Put all messages with the same subject in the 'subject sequence. | |
| 767 | This function works when the folder is threaded. In this situation the subject | |
| 768 | could get truncated and so the normal matching doesn't work. | |
| 769 | ||
| 770 | The parameter ALL is non-nil then all the messages in the buffer are | |
| 771 | considered, otherwise only the messages after the current one are taken into | |
| 772 | account." | |
| 773 | (let* ((cur (mh-get-msg-num nil)) | |
| 774 | (subject (mh-thread-find-msg-subject cur)) | |
| 775 | region msgs) | |
| 776 | (if (null subject) | |
| 777 | (and (message "No subject line") nil) | |
| 778 | (setq region (cons (if all (point-min) (point)) (point-max))) | |
| 779 | (mh-iterate-on-range msg region | |
| 780 | (when (eq (mh-thread-find-msg-subject msg) subject) | |
| 781 | (push msg msgs))) | |
| 782 | (setq msgs (sort msgs #'mh-lessp)) | |
| 783 | (if (null msgs) | |
| 784 | 0 | |
| 785 | (when (assoc 'subject mh-seq-list) | |
| 786 | (mh-delete-seq 'subject)) | |
| 787 | (mh-add-msgs-to-seq msgs 'subject) | |
| 788 | (length msgs))))) | |
| 789 | ||
| 790 | (defun mh-thread-find-msg-subject (msg) | |
| 791 | "Find canonicalized subject of MSG. | |
| 792 | This function can only be used the folder is threaded." | |
| 793 | (ignore-errors | |
| 794 | (mh-message-subject | |
| 795 | (mh-container-message (gethash (gethash msg mh-thread-index-id-map) | |
| 796 | mh-thread-id-table))))) | |
| 797 | ||
| f0d73c14 BW |
798 | (defun mh-edit-pick-expr (default) |
| 799 | "With prefix arg edit a pick expression. | |
| a66894d8 BW |
800 | If no prefix arg is given, then return DEFAULT." |
| 801 | (let ((default-string (loop for x in default concat (format " %s" x)))) | |
| 802 | (if (or current-prefix-arg (equal default-string "")) | |
| e495eaec BW |
803 | (mh-pick-args-list (read-string "Pick expression: " |
| 804 | default-string)) | |
| a66894d8 BW |
805 | default))) |
| 806 | ||
| e495eaec BW |
807 | (defun mh-pick-args-list (s) |
| 808 | "Form list by grouping elements in string S suitable for pick arguments. | |
| 809 | For example, the string \"-subject a b c -from Joe User <user@domain.com>\" | |
| 810 | is converted to (\"-subject\" \"a b c\" \"-from\" | |
| 811 | \"Joe User <user@domain.com>\"" | |
| 812 | (let ((full-list (split-string s)) | |
| 813 | current-arg collection arg-list) | |
| 814 | (while full-list | |
| 815 | (setq current-arg (car full-list)) | |
| 816 | (if (null (string-match "^-" current-arg)) | |
| 817 | (setq collection | |
| 818 | (if (null collection) | |
| 819 | current-arg | |
| 820 | (format "%s %s" collection current-arg))) | |
| 821 | (when collection | |
| 822 | (setq arg-list (append arg-list (list collection))) | |
| 823 | (setq collection nil)) | |
| 824 | (setq arg-list (append arg-list (list current-arg)))) | |
| 825 | (setq full-list (cdr full-list))) | |
| 826 | (when collection | |
| 827 | (setq arg-list (append arg-list (list collection)))) | |
| 828 | arg-list)) | |
| 829 | ||
| a66894d8 | 830 | ;;;###mh-autoload |
| f0d73c14 BW |
831 | (defun mh-narrow-to-subject (&optional pick-expr) |
| 832 | "Limit to messages with same subject. | |
| 833 | With a prefix argument, edit PICK-EXPR. | |
| 834 | ||
| 835 | Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| a66894d8 | 836 | (interactive |
| f0d73c14 BW |
837 | (list (mh-edit-pick-expr (mh-current-message-header-field 'subject)))) |
| 838 | (mh-narrow-to-header-field 'subject pick-expr)) | |
| a66894d8 BW |
839 | |
| 840 | ;;;###mh-autoload | |
| f0d73c14 BW |
841 | (defun mh-narrow-to-from (&optional pick-expr) |
| 842 | "Limit to messages with the same `From:' field. | |
| 843 | With a prefix argument, edit PICK-EXPR. | |
| 844 | ||
| 845 | Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| a66894d8 | 846 | (interactive |
| f0d73c14 BW |
847 | (list (mh-edit-pick-expr (mh-current-message-header-field 'from)))) |
| 848 | (mh-narrow-to-header-field 'from pick-expr)) | |
| a66894d8 BW |
849 | |
| 850 | ;;;###mh-autoload | |
| f0d73c14 BW |
851 | (defun mh-narrow-to-cc (&optional pick-expr) |
| 852 | "Limit to messages with the same `Cc:' field. | |
| 853 | With a prefix argument, edit PICK-EXPR. | |
| 854 | ||
| 855 | Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| a66894d8 | 856 | (interactive |
| f0d73c14 BW |
857 | (list (mh-edit-pick-expr (mh-current-message-header-field 'cc)))) |
| 858 | (mh-narrow-to-header-field 'cc pick-expr)) | |
| a66894d8 | 859 | |
| f0d73c14 BW |
860 | ;;;###mh-autoload |
| 861 | (defun mh-narrow-to-to (&optional pick-expr) | |
| 862 | "Limit to messages with the same `To:' field. | |
| 863 | With a prefix argument, edit PICK-EXPR. | |
| 864 | ||
| 865 | Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| 866 | (interactive | |
| 867 | (list (mh-edit-pick-expr (mh-current-message-header-field 'to)))) | |
| 868 | (mh-narrow-to-header-field 'to pick-expr)) | |
| 869 | ||
| 870 | (defun mh-narrow-to-header-field (header-field pick-expr) | |
| 871 | "Limit to messages whose HEADER-FIELD match PICK-EXPR. | |
| a66894d8 BW |
872 | The MH command pick is used to do the match." |
| 873 | (let ((folder mh-current-folder) | |
| 874 | (original (mh-coalesce-msg-list | |
| 875 | (mh-range-to-msg-list (cons (point-min) (point-max))))) | |
| 876 | (msg-list ())) | |
| 877 | (with-temp-buffer | |
| 878 | (apply #'mh-exec-cmd-output "pick" nil folder | |
| f0d73c14 | 879 | (append original (list "-list") pick-expr)) |
| a66894d8 BW |
880 | (goto-char (point-min)) |
| 881 | (while (not (eobp)) | |
| 882 | (let ((num (read-from-string | |
| 883 | (buffer-substring (point) (line-end-position))))) | |
| 884 | (when (numberp (car num)) (push (car num) msg-list)) | |
| 885 | (forward-line)))) | |
| 886 | (if (null msg-list) | |
| 887 | (message "No matches") | |
| 888 | (when (assoc 'header mh-seq-list) (mh-delete-seq 'header)) | |
| 889 | (mh-add-msgs-to-seq msg-list 'header) | |
| 890 | (mh-narrow-to-seq 'header)))) | |
| 891 | ||
| 892 | (defun mh-current-message-header-field (header-field) | |
| 893 | "Return a pick regexp to match HEADER-FIELD of the message at point." | |
| 894 | (let ((num (mh-get-msg-num nil))) | |
| 895 | (when num | |
| 896 | (let ((folder mh-current-folder)) | |
| 897 | (with-temp-buffer | |
| 898 | (insert-file-contents-literally (mh-msg-filename num folder)) | |
| 899 | (goto-char (point-min)) | |
| 900 | (when (search-forward "\n\n" nil t) | |
| 901 | (narrow-to-region (point-min) (point))) | |
| 902 | (let* ((field (or (message-fetch-field (format "%s" header-field)) | |
| 903 | "")) | |
| 904 | (field-option (format "-%s" header-field)) | |
| 905 | (patterns (loop for x in (split-string field "[ ]*,[ ]*") | |
| 906 | unless (equal x "") | |
| 907 | collect (if (string-match "<\\(.*@.*\\)>" x) | |
| 908 | (match-string 1 x) | |
| 909 | x)))) | |
| 910 | (when patterns | |
| 911 | (loop with accum = `(,field-option ,(car patterns)) | |
| 912 | for e in (cdr patterns) | |
| 913 | do (setq accum `(,field-option ,e "-or" ,@accum)) | |
| 914 | finally return accum)))))))) | |
| 915 | ||
| 916 | ;;;###mh-autoload | |
| 917 | (defun mh-narrow-to-range (range) | |
| 918 | "Limit to messages in RANGE. | |
| 919 | ||
| 920 | Check the documentation of `mh-interactive-range' to see how RANGE is read in | |
| f0d73c14 BW |
921 | interactive use. |
| 922 | ||
| 923 | Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| a66894d8 BW |
924 | (interactive (list (mh-interactive-range "Narrow to"))) |
| 925 | (when (assoc 'range mh-seq-list) (mh-delete-seq 'range)) | |
| 926 | (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range) | |
| 927 | (mh-narrow-to-seq 'range)) | |
| 928 | ||
| 929 | ||
| c3d9274a | 930 | ;;;###mh-autoload |
| bdcfe844 BW |
931 | (defun mh-delete-subject () |
| 932 | "Mark all following messages with same subject to be deleted. | |
| 933 | This puts the messages in a sequence named subject. You can undo the last | |
| 934 | deletion marks using `mh-undo' with a prefix argument and then specifying the | |
| 935 | subject sequence." | |
| a1b4049d | 936 | (interactive) |
| bdcfe844 | 937 | (let ((count (mh-subject-to-sequence nil))) |
| a1b4049d BW |
938 | (cond |
| 939 | ((not count) ; No subject line, delete msg anyway | |
| 940 | (mh-delete-msg (mh-get-msg-num t))) | |
| 941 | ((= 0 count) ; No other msgs, delete msg anyway. | |
| f0d73c14 | 942 | (message "No other messages with same Subject following this one") |
| a1b4049d BW |
943 | (mh-delete-msg (mh-get-msg-num t))) |
| 944 | (t ; We have a subject sequence. | |
| 945 | (message "Marked %d messages for deletion" count) | |
| 946 | (mh-delete-msg 'subject))))) | |
| 947 | ||
| c3d9274a BW |
948 | ;;;###mh-autoload |
| 949 | (defun mh-delete-subject-or-thread () | |
| 950 | "Mark messages for deletion intelligently. | |
| 951 | If the folder is threaded then `mh-thread-delete' is used to mark the current | |
| 952 | message and all its descendants for deletion. Otherwise `mh-delete-subject' is | |
| 953 | used to mark the current message and all messages following it with the same | |
| 954 | subject for deletion." | |
| 955 | (interactive) | |
| 956 | (if (memq 'unthread mh-view-ops) | |
| 957 | (mh-thread-delete) | |
| 958 | (mh-delete-subject))) | |
| 959 | ||
| bdcfe844 BW |
960 | ;;; Message threading: |
| 961 | ||
| a66894d8 BW |
962 | (defmacro mh-thread-initialize-hash (var test) |
| 963 | "Initialize the hash table in VAR. | |
| 964 | TEST is the test to use when creating a new hash table." | |
| 965 | (unless (symbolp var) (error "Expected a symbol: %s" var)) | |
| 966 | `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) | |
| 967 | ||
| bdcfe844 | 968 | (defun mh-thread-initialize () |
| a66894d8 BW |
969 | "Make new hash tables, or clear them if already present." |
| 970 | (mh-thread-initialize-hash mh-thread-id-hash #'equal) | |
| 971 | (mh-thread-initialize-hash mh-thread-subject-hash #'equal) | |
| 972 | (mh-thread-initialize-hash mh-thread-id-table #'eq) | |
| 973 | (mh-thread-initialize-hash mh-thread-id-index-map #'eq) | |
| 974 | (mh-thread-initialize-hash mh-thread-index-id-map #'eql) | |
| 975 | (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) | |
| 976 | (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) | |
| 977 | (mh-thread-initialize-hash mh-thread-duplicates #'eq) | |
| 978 | (setq mh-thread-history ())) | |
| bdcfe844 BW |
979 | |
| 980 | (defsubst mh-thread-id-container (id) | |
| 981 | "Given ID, return the corresponding container in `mh-thread-id-table'. | |
| 982 | If no container exists then a suitable container is created and the id-table | |
| 983 | is updated." | |
| 984 | (when (not id) | |
| 985 | (error "1")) | |
| 986 | (or (gethash id mh-thread-id-table) | |
| 987 | (setf (gethash id mh-thread-id-table) | |
| 988 | (let ((message (mh-thread-make-message :id id))) | |
| 989 | (mh-thread-make-container :message message))))) | |
| 990 | ||
| 991 | (defsubst mh-thread-remove-parent-link (child) | |
| 992 | "Remove parent link of CHILD if it exists." | |
| 993 | (let* ((child-container (if (mh-thread-container-p child) | |
| 994 | child (mh-thread-id-container child))) | |
| 995 | (parent-container (mh-container-parent child-container))) | |
| 996 | (when parent-container | |
| 997 | (setf (mh-container-children parent-container) | |
| c3d9274a BW |
998 | (loop for elem in (mh-container-children parent-container) |
| 999 | unless (eq child-container elem) collect elem)) | |
| bdcfe844 BW |
1000 | (setf (mh-container-parent child-container) nil)))) |
| 1001 | ||
| 1002 | (defsubst mh-thread-add-link (parent child &optional at-end-p) | |
| 1003 | "Add links so that PARENT becomes a parent of CHILD. | |
| 1004 | Doesn't make any changes if CHILD is already an ancestor of PARENT. If | |
| 1005 | optional argument AT-END-P is non-nil, the CHILD is added to the end of the | |
| 1006 | children list of PARENT." | |
| 1007 | (let ((parent-container (cond ((null parent) nil) | |
| 1008 | ((mh-thread-container-p parent) parent) | |
| 1009 | (t (mh-thread-id-container parent)))) | |
| 1010 | (child-container (if (mh-thread-container-p child) | |
| 1011 | child (mh-thread-id-container child)))) | |
| 1012 | (when (and parent-container | |
| 1013 | (not (mh-thread-ancestor-p child-container parent-container)) | |
| 1014 | (not (mh-thread-ancestor-p parent-container child-container))) | |
| 1015 | (mh-thread-remove-parent-link child-container) | |
| 1016 | (cond ((not at-end-p) | |
| 1017 | (push child-container (mh-container-children parent-container))) | |
| 1018 | ((null (mh-container-children parent-container)) | |
| 1019 | (push child-container (mh-container-children parent-container))) | |
| 1020 | (t (let ((last-child (mh-container-children parent-container))) | |
| 1021 | (while (cdr last-child) | |
| 1022 | (setq last-child (cdr last-child))) | |
| 1023 | (setcdr last-child (cons child-container nil))))) | |
| 1024 | (setf (mh-container-parent child-container) parent-container)) | |
| 1025 | (unless parent-container | |
| 1026 | (mh-thread-remove-parent-link child-container)))) | |
| 1027 | ||
| 1028 | (defun mh-thread-ancestor-p (ancestor successor) | |
| 1029 | "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. | |
| 1030 | In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same | |
| 1031 | containers." | |
| 1032 | (block nil | |
| 1033 | (while successor | |
| 1034 | (when (eq ancestor successor) (return t)) | |
| 1035 | (setq successor (mh-container-parent successor))) | |
| 1036 | nil)) | |
| 1037 | ||
| 1038 | (defsubst mh-thread-get-message-container (message) | |
| 1039 | "Return container which has MESSAGE in it. | |
| 1040 | If there is no container present then a new container is allocated." | |
| 1041 | (let* ((id (mh-message-id message)) | |
| 1042 | (container (gethash id mh-thread-id-table))) | |
| 1043 | (cond (container (setf (mh-container-message container) message) | |
| 1044 | container) | |
| 1045 | (t (setf (gethash id mh-thread-id-table) | |
| 1046 | (mh-thread-make-container :message message)))))) | |
| 1047 | ||
| 1048 | (defsubst mh-thread-get-message (id subject-re-p subject refs) | |
| 1049 | "Return appropriate message. | |
| 1050 | Otherwise update message already present to have the proper ID, SUBJECT-RE-P, | |
| 1051 | SUBJECT and REFS fields." | |
| 1052 | (let* ((container (gethash id mh-thread-id-table)) | |
| 1053 | (message (if container (mh-container-message container) nil))) | |
| 1054 | (cond (message | |
| 1055 | (setf (mh-message-subject-re-p message) subject-re-p) | |
| 1056 | (setf (mh-message-subject message) subject) | |
| 1057 | (setf (mh-message-id message) id) | |
| 1058 | (setf (mh-message-references message) refs) | |
| 1059 | message) | |
| 1060 | (container | |
| 1061 | (setf (mh-container-message container) | |
| f0d73c14 BW |
1062 | (mh-thread-make-message :id id :references refs |
| 1063 | :subject subject | |
| 1064 | :subject-re-p subject-re-p))) | |
| 1065 | (t (let ((message (mh-thread-make-message :id id :references refs | |
| 1066 | :subject-re-p subject-re-p | |
| 1067 | :subject subject))) | |
| bdcfe844 BW |
1068 | (prog1 message |
| 1069 | (mh-thread-get-message-container message))))))) | |
| 1070 | ||
| 1071 | (defsubst mh-thread-canonicalize-id (id) | |
| 1072 | "Produce canonical string representation for ID. | |
| 1073 | This allows cheap string comparison with EQ." | |
| 1074 | (or (and (equal id "") (copy-sequence "")) | |
| 1075 | (gethash id mh-thread-id-hash) | |
| 1076 | (setf (gethash id mh-thread-id-hash) id))) | |
| 1077 | ||
| 1078 | (defsubst mh-thread-prune-subject (subject) | |
| 1079 | "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. | |
| 1080 | If the result after pruning is not the empty string then it is canonicalized | |
| 1081 | so that subjects can be tested for equality with eq. This is done so that all | |
| 1082 | the messages without a subject are not put into a single thread." | |
| 1083 | (let ((case-fold-search t) | |
| 1084 | (subject-pruned-flag nil)) | |
| 1085 | ;; Prune subject leader | |
| 1086 | (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" | |
| 1087 | subject) | |
| 1088 | (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) | |
| 1089 | (setq subject-pruned-flag t) | |
| 1090 | (setq subject (substring subject (match-end 0)))) | |
| 1091 | ;; Prune subject trailer | |
| 1092 | (while (or (string-match "(fwd)$" subject) | |
| 1093 | (string-match "[ \t]+$" subject)) | |
| 1094 | (setq subject-pruned-flag t) | |
| 1095 | (setq subject (substring subject 0 (match-beginning 0)))) | |
| 1096 | ;; Canonicalize subject only if it is non-empty | |
| 1097 | (cond ((equal subject "") (values subject subject-pruned-flag)) | |
| 1098 | (t (values | |
| 1099 | (or (gethash subject mh-thread-subject-hash) | |
| 1100 | (setf (gethash subject mh-thread-subject-hash) subject)) | |
| 1101 | subject-pruned-flag))))) | |
| 1102 | ||
| 1103 | (defun mh-thread-container-subject (container) | |
| 1104 | "Return the subject of CONTAINER. | |
| 1105 | If CONTAINER is empty return the subject info of one of its children." | |
| 1106 | (cond ((and (mh-container-message container) | |
| 1107 | (mh-message-id (mh-container-message container))) | |
| 1108 | (mh-message-subject (mh-container-message container))) | |
| 1109 | (t (block nil | |
| 1110 | (dolist (kid (mh-container-children container)) | |
| 1111 | (when (and (mh-container-message kid) | |
| 1112 | (mh-message-id (mh-container-message kid))) | |
| 1113 | (let ((kid-message (mh-container-message kid))) | |
| 1114 | (return (mh-message-subject kid-message))))) | |
| 1115 | (error "This can't happen!"))))) | |
| 1116 | ||
| 1117 | (defun mh-thread-rewind-pruning () | |
| 1118 | "Restore the thread tree to its state before pruning." | |
| 1119 | (while mh-thread-history | |
| 1120 | (let ((action (pop mh-thread-history))) | |
| 1121 | (cond ((eq (car action) 'DROP) | |
| 1122 | (mh-thread-remove-parent-link (cadr action)) | |
| 1123 | (mh-thread-add-link (caddr action) (cadr action))) | |
| 1124 | ((eq (car action) 'PROMOTE) | |
| 1125 | (let ((node (cadr action)) | |
| 1126 | (parent (caddr action)) | |
| 1127 | (children (cdddr action))) | |
| 1128 | (dolist (child children) | |
| 1129 | (mh-thread-remove-parent-link child) | |
| 1130 | (mh-thread-add-link node child)) | |
| 1131 | (mh-thread-add-link parent node))) | |
| 1132 | ((eq (car action) 'SUBJECT) | |
| 1133 | (let ((node (cadr action))) | |
| 1134 | (mh-thread-remove-parent-link node) | |
| 1135 | (setf (mh-container-real-child-p node) t))))))) | |
| 1136 | ||
| 1137 | (defun mh-thread-prune-containers (roots) | |
| c3d9274a | 1138 | "Prune empty containers in the containers ROOTS." |
| bdcfe844 BW |
1139 | (let ((dfs-ordered-nodes ()) |
| 1140 | (work-list roots)) | |
| 1141 | (while work-list | |
| 1142 | (let ((node (pop work-list))) | |
| 1143 | (dolist (child (mh-container-children node)) | |
| 1144 | (push child work-list)) | |
| 1145 | (push node dfs-ordered-nodes))) | |
| 1146 | (while dfs-ordered-nodes | |
| 1147 | (let ((node (pop dfs-ordered-nodes))) | |
| 1148 | (cond ((gethash (mh-message-id (mh-container-message node)) | |
| 1149 | mh-thread-id-index-map) | |
| 1150 | ;; Keep it | |
| 1151 | (setf (mh-container-children node) | |
| 1152 | (mh-thread-sort-containers (mh-container-children node)))) | |
| 1153 | ((and (mh-container-children node) | |
| 1154 | (or (null (cdr (mh-container-children node))) | |
| 1155 | (mh-container-parent node))) | |
| 1156 | ;; Promote kids | |
| 1157 | (let ((children ())) | |
| 1158 | (dolist (kid (mh-container-children node)) | |
| 1159 | (mh-thread-remove-parent-link kid) | |
| 1160 | (mh-thread-add-link (mh-container-parent node) kid) | |
| 1161 | (push kid children)) | |
| 1162 | (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) | |
| 1163 | mh-thread-history) | |
| 1164 | (mh-thread-remove-parent-link node))) | |
| 1165 | ((mh-container-children node) | |
| 1166 | ;; Promote the first orphan to parent and add the other kids as | |
| 1167 | ;; his children | |
| 1168 | (setf (mh-container-children node) | |
| 1169 | (mh-thread-sort-containers (mh-container-children node))) | |
| 1170 | (let ((new-parent (car (mh-container-children node))) | |
| 1171 | (other-kids (cdr (mh-container-children node)))) | |
| 1172 | (mh-thread-remove-parent-link new-parent) | |
| 1173 | (dolist (kid other-kids) | |
| 1174 | (mh-thread-remove-parent-link kid) | |
| 1175 | (setf (mh-container-real-child-p kid) nil) | |
| 1176 | (mh-thread-add-link new-parent kid t)) | |
| 1177 | (push `(PROMOTE ,node ,(mh-container-parent node) | |
| 1178 | ,new-parent ,@other-kids) | |
| 1179 | mh-thread-history) | |
| 1180 | (mh-thread-remove-parent-link node))) | |
| 1181 | (t | |
| 1182 | ;; Drop it | |
| 1183 | (push `(DROP ,node ,(mh-container-parent node)) | |
| 1184 | mh-thread-history) | |
| 1185 | (mh-thread-remove-parent-link node))))) | |
| 1186 | (let ((results ())) | |
| 1187 | (maphash #'(lambda (k v) | |
| 1188 | (declare (ignore k)) | |
| 1189 | (when (and (null (mh-container-parent v)) | |
| 1190 | (gethash (mh-message-id (mh-container-message v)) | |
| 1191 | mh-thread-id-index-map)) | |
| 1192 | (push v results))) | |
| 1193 | mh-thread-id-table) | |
| 1194 | (mh-thread-sort-containers results)))) | |
| 1195 | ||
| 1196 | (defun mh-thread-sort-containers (containers) | |
| 1197 | "Sort a list of message CONTAINERS to be in ascending order wrt index." | |
| 1198 | (sort containers | |
| 1199 | #'(lambda (x y) | |
| 1200 | (when (and (mh-container-message x) (mh-container-message y)) | |
| 1201 | (let* ((id-x (mh-message-id (mh-container-message x))) | |
| 1202 | (id-y (mh-message-id (mh-container-message y))) | |
| 1203 | (index-x (gethash id-x mh-thread-id-index-map)) | |
| 1204 | (index-y (gethash id-y mh-thread-id-index-map))) | |
| 1205 | (and (integerp index-x) (integerp index-y) | |
| 1206 | (< index-x index-y))))))) | |
| 1207 | ||
| 1208 | (defsubst mh-thread-group-by-subject (roots) | |
| 1209 | "Group the set of message containers, ROOTS based on subject. | |
| 1210 | Bug: Check for and make sure that something without Re: is made the parent in | |
| 1211 | preference to something that has it." | |
| 1212 | (clrhash mh-thread-subject-container-hash) | |
| 1213 | (let ((results ())) | |
| 1214 | (dolist (root roots) | |
| 1215 | (let* ((subject (mh-thread-container-subject root)) | |
| 1216 | (parent (gethash subject mh-thread-subject-container-hash))) | |
| 1217 | (cond (parent (mh-thread-remove-parent-link root) | |
| 1218 | (mh-thread-add-link parent root t) | |
| 1219 | (setf (mh-container-real-child-p root) nil) | |
| 1220 | (push `(SUBJECT ,root) mh-thread-history)) | |
| 1221 | (t | |
| 1222 | (setf (gethash subject mh-thread-subject-container-hash) root) | |
| 1223 | (push root results))))) | |
| 1224 | (nreverse results))) | |
| 1225 | ||
| a66894d8 | 1226 | (defun mh-thread-process-in-reply-to (reply-to-header) |
| bdcfe844 BW |
1227 | "Extract message id's from REPLY-TO-HEADER. |
| 1228 | Ideally this should have some regexp which will try to guess if a string | |
| 1229 | between < and > is a message id and not an email address. For now it will | |
| 1230 | take the last string inside angles." | |
| c3d9274a | 1231 | (let ((end (mh-search-from-end ?> reply-to-header))) |
| bdcfe844 | 1232 | (when (numberp end) |
| c3d9274a | 1233 | (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) |
| bdcfe844 BW |
1234 | (when (numberp begin) |
| 1235 | (list (substring reply-to-header begin (1+ end)))))))) | |
| 1236 | ||
| 1237 | (defun mh-thread-set-tables (folder) | |
| 1238 | "Use the tables of FOLDER in current buffer." | |
| 1239 | (flet ((mh-get-table (symbol) | |
| c3d9274a BW |
1240 | (save-excursion |
| 1241 | (set-buffer folder) | |
| 1242 | (symbol-value symbol)))) | |
| bdcfe844 BW |
1243 | (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) |
| 1244 | (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) | |
| 1245 | (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) | |
| 1246 | (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) | |
| 1247 | (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) | |
| 1248 | (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) | |
| 1249 | (setq mh-thread-subject-container-hash | |
| 1250 | (mh-get-table 'mh-thread-subject-container-hash)) | |
| 1251 | (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) | |
| 1252 | (setq mh-thread-history (mh-get-table 'mh-thread-history)))) | |
| 1253 | ||
| 1254 | (defsubst mh-thread-update-id-index-maps (id index) | |
| 1255 | "Message with id, ID is the message in INDEX. | |
| 1256 | The function also checks for duplicate messages (that is multiple messages | |
| 1257 | with the same ID). These messages are put in the `mh-thread-duplicates' hash | |
| 1258 | table." | |
| 1259 | (let ((old-index (gethash id mh-thread-id-index-map))) | |
| 1260 | (when old-index (push old-index (gethash id mh-thread-duplicates))) | |
| 1261 | (setf (gethash id mh-thread-id-index-map) index) | |
| 1262 | (setf (gethash index mh-thread-index-id-map) id))) | |
| 1263 | ||
| 1264 | \f | |
| 1265 | ||
| 1266 | ;;; Generate Threads... | |
| 1267 | ||
| 3d7ca223 BW |
1268 | (defvar mh-message-id-regexp "^<.*@.*>$" |
| 1269 | "Regexp to recognize whether a string is a message identifier.") | |
| 1270 | ||
| bdcfe844 BW |
1271 | (defun mh-thread-generate (folder msg-list) |
| 1272 | "Scan FOLDER to get info for threading. | |
| 1273 | Only information about messages in MSG-LIST are added to the tree." | |
| 3d7ca223 | 1274 | (with-temp-buffer |
| bdcfe844 | 1275 | (mh-thread-set-tables folder) |
| bdcfe844 BW |
1276 | (when msg-list |
| 1277 | (apply | |
| 1278 | #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil | |
| 1279 | "-width" "10000" "-format" | |
| 1280 | "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" | |
| c3d9274a | 1281 | folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) |
| bdcfe844 BW |
1282 | (goto-char (point-min)) |
| 1283 | (let ((roots ()) | |
| 1284 | (case-fold-search t)) | |
| 1285 | (block nil | |
| 1286 | (while (not (eobp)) | |
| 1287 | (block process-message | |
| 1288 | (let* ((index-line | |
| c3d9274a BW |
1289 | (prog1 (buffer-substring (point) (line-end-position)) |
| 1290 | (forward-line))) | |
| bdcfe844 BW |
1291 | (index (car (read-from-string index-line))) |
| 1292 | (id (prog1 (buffer-substring (point) (line-end-position)) | |
| 1293 | (forward-line))) | |
| 1294 | (refs (prog1 (buffer-substring (point) (line-end-position)) | |
| 1295 | (forward-line))) | |
| 1296 | (in-reply-to (prog1 (buffer-substring (point) | |
| 1297 | (line-end-position)) | |
| 1298 | (forward-line))) | |
| 1299 | (subject (prog1 | |
| 1300 | (buffer-substring (point) (line-end-position)) | |
| 1301 | (forward-line))) | |
| 1302 | (subject-re-p nil)) | |
| 1303 | (unless (gethash index mh-thread-scan-line-map) | |
| 1304 | (return-from process-message)) | |
| 1305 | (unless (integerp index) (return)) ;Error message here | |
| 1306 | (multiple-value-setq (subject subject-re-p) | |
| 1307 | (mh-thread-prune-subject subject)) | |
| 1308 | (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) | |
| 3d7ca223 BW |
1309 | (setq refs (loop for x in (append (split-string refs) in-reply-to) |
| 1310 | when (string-match mh-message-id-regexp x) | |
| 1311 | collect x)) | |
| bdcfe844 BW |
1312 | (setq id (mh-thread-canonicalize-id id)) |
| 1313 | (mh-thread-update-id-index-maps id index) | |
| 1314 | (setq refs (mapcar #'mh-thread-canonicalize-id refs)) | |
| 1315 | (mh-thread-get-message id subject-re-p subject refs) | |
| 1316 | (do ((ancestors refs (cdr ancestors))) | |
| 1317 | ((null (cdr ancestors)) | |
| 1318 | (when (car ancestors) | |
| 1319 | (mh-thread-remove-parent-link id) | |
| 1320 | (mh-thread-add-link (car ancestors) id))) | |
| 1321 | (mh-thread-add-link (car ancestors) (cadr ancestors))))))) | |
| 1322 | (maphash #'(lambda (k v) | |
| 1323 | (declare (ignore k)) | |
| 1324 | (when (null (mh-container-parent v)) | |
| 1325 | (push v roots))) | |
| 1326 | mh-thread-id-table) | |
| 1327 | (setq roots (mh-thread-prune-containers roots)) | |
| 1328 | (prog1 (setq roots (mh-thread-group-by-subject roots)) | |
| 1329 | (let ((history mh-thread-history)) | |
| 1330 | (set-buffer folder) | |
| 1331 | (setq mh-thread-history history)))))) | |
| 1332 | ||
| c3d9274a | 1333 | ;;;###mh-autoload |
| bdcfe844 BW |
1334 | (defun mh-thread-inc (folder start-point) |
| 1335 | "Update thread tree for FOLDER. | |
| 1336 | All messages after START-POINT are added to the thread tree." | |
| 1337 | (mh-thread-rewind-pruning) | |
| a66894d8 | 1338 | (mh-remove-all-notation) |
| bdcfe844 BW |
1339 | (goto-char start-point) |
| 1340 | (let ((msg-list ())) | |
| 1341 | (while (not (eobp)) | |
| 1342 | (let ((index (mh-get-msg-num nil))) | |
| c3d9274a BW |
1343 | (when (numberp index) |
| 1344 | (push index msg-list) | |
| 1345 | (setf (gethash index mh-thread-scan-line-map) | |
| 1346 | (mh-thread-parse-scan-line))) | |
| bdcfe844 BW |
1347 | (forward-line))) |
| 1348 | (let ((thread-tree (mh-thread-generate folder msg-list)) | |
| 1349 | (buffer-read-only nil) | |
| 1350 | (old-buffer-modified-flag (buffer-modified-p))) | |
| 1351 | (delete-region (point-min) (point-max)) | |
| 924df208 | 1352 | (mh-thread-print-scan-lines thread-tree) |
| e495eaec | 1353 | (mh-notate-user-sequences) |
| bdcfe844 | 1354 | (mh-notate-deleted-and-refiled) |
| 3d7ca223 | 1355 | (mh-notate-cur) |
| bdcfe844 BW |
1356 | (set-buffer-modified-p old-buffer-modified-flag)))) |
| 1357 | ||
| 1358 | (defun mh-thread-generate-scan-lines (tree level) | |
| 1359 | "Generate scan lines. | |
| 1360 | TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices | |
| 1361 | to the corresponding scan lines and LEVEL used to determine indentation of | |
| 1362 | the message." | |
| 1363 | (cond ((null tree) nil) | |
| 1364 | ((mh-thread-container-p tree) | |
| 1365 | (let* ((message (mh-container-message tree)) | |
| 1366 | (id (mh-message-id message)) | |
| 1367 | (index (gethash id mh-thread-id-index-map)) | |
| 1368 | (duplicates (gethash id mh-thread-duplicates)) | |
| 1369 | (new-level (+ level 2)) | |
| 1370 | (dupl-flag t) | |
| c3d9274a | 1371 | (force-angle-flag nil) |
| bdcfe844 BW |
1372 | (increment-level-flag nil)) |
| 1373 | (dolist (scan-line (mapcar (lambda (x) | |
| 1374 | (gethash x mh-thread-scan-line-map)) | |
| 1375 | (reverse (cons index duplicates)))) | |
| 1376 | (when scan-line | |
| c3d9274a BW |
1377 | (when (and dupl-flag (equal level 0) |
| 1378 | (mh-thread-ancestor-p mh-thread-last-ancestor tree)) | |
| 1379 | (setq level (+ level 2) | |
| 1380 | new-level (+ new-level 2) | |
| 1381 | force-angle-flag t)) | |
| 1382 | (when (equal level 0) | |
| 1383 | (setq mh-thread-last-ancestor tree) | |
| 1384 | (while (mh-container-parent mh-thread-last-ancestor) | |
| 1385 | (setq mh-thread-last-ancestor | |
| 1386 | (mh-container-parent mh-thread-last-ancestor)))) | |
| 3d7ca223 BW |
1387 | (let* ((lev (if dupl-flag level new-level)) |
| 1388 | (square-flag (or (and (mh-container-real-child-p tree) | |
| 1389 | (not force-angle-flag) | |
| 1390 | dupl-flag) | |
| 1391 | (equal lev 0)))) | |
| 1392 | (insert (car scan-line) | |
| 1393 | (format (format "%%%ss" lev) "") | |
| 1394 | (if square-flag "[" "<") | |
| 1395 | (cadr scan-line) | |
| 1396 | (if square-flag "]" ">") | |
| 1397 | (truncate-string-to-width | |
| 1398 | (caddr scan-line) (- mh-thread-body-width lev)) | |
| 1399 | "\n")) | |
| bdcfe844 BW |
1400 | (setq increment-level-flag t) |
| 1401 | (setq dupl-flag nil))) | |
| 1402 | (unless increment-level-flag (setq new-level level)) | |
| 1403 | (dolist (child (mh-container-children tree)) | |
| 1404 | (mh-thread-generate-scan-lines child new-level)))) | |
| 1405 | (t (let ((nlevel (+ level 2))) | |
| 1406 | (dolist (ch tree) | |
| 1407 | (mh-thread-generate-scan-lines ch nlevel)))))) | |
| 1408 | ||
| 1409 | ;; Another and may be better approach would be to generate all the info from | |
| 1410 | ;; the scan which generates the threading info. For now this will have to do. | |
| 1411 | (defun mh-thread-parse-scan-line (&optional string) | |
| 1412 | "Parse a scan line. | |
| 1413 | If optional argument STRING is given then that is assumed to be the scan line. | |
| 1414 | Otherwise uses the line at point as the scan line to parse." | |
| 1415 | (let* ((string (or string | |
| 1416 | (buffer-substring-no-properties (line-beginning-position) | |
| 1417 | (line-end-position)))) | |
| a66894d8 BW |
1418 | (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) |
| 1419 | (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) | |
| 1420 | (first-string (substring string 0 address-start))) | |
| bdcfe844 | 1421 | (list first-string |
| a66894d8 BW |
1422 | (substring string address-start (- body-start 2)) |
| 1423 | (substring string body-start) | |
| bdcfe844 BW |
1424 | string))) |
| 1425 | ||
| a66894d8 BW |
1426 | ;;;###mh-autoload |
| 1427 | (defun mh-thread-update-scan-line-map (msg notation offset) | |
| 1428 | "In threaded view update `mh-thread-scan-line-map'. | |
| 1429 | MSG is the message being notated with NOTATION at OFFSET." | |
| 1430 | (let* ((msg (or msg (mh-get-msg-num nil))) | |
| 1431 | (cur-scan-line (and mh-thread-scan-line-map | |
| 1432 | (gethash msg mh-thread-scan-line-map))) | |
| 1433 | (old-scan-lines (loop for map in mh-thread-scan-line-map-stack | |
| f0d73c14 | 1434 | collect (and map (gethash msg map))))) |
| a66894d8 BW |
1435 | (when cur-scan-line |
| 1436 | (setf (aref (car cur-scan-line) offset) notation)) | |
| 1437 | (dolist (line old-scan-lines) | |
| 1438 | (when line (setf (aref (car line) offset) notation))))) | |
| 1439 | ||
| c3d9274a | 1440 | ;;;###mh-autoload |
| bdcfe844 BW |
1441 | (defun mh-thread-add-spaces (count) |
| 1442 | "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." | |
| 1443 | (let ((spaces (format (format "%%%ss" count) ""))) | |
| 1444 | (while (not (eobp)) | |
| 1445 | (let* ((msg-num (mh-get-msg-num nil)) | |
| 1446 | (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) | |
| c3d9274a BW |
1447 | (when (numberp msg-num) |
| 1448 | (setf (gethash msg-num mh-thread-scan-line-map) | |
| 1449 | (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) | |
| bdcfe844 BW |
1450 | (forward-line 1)))) |
| 1451 | ||
| 924df208 BW |
1452 | (defun mh-thread-print-scan-lines (thread-tree) |
| 1453 | "Print scan lines in THREAD-TREE in threaded mode." | |
| 1454 | (let ((mh-thread-body-width (- (window-width) mh-cmd-note | |
| 1455 | (1- mh-scan-field-subject-start-offset))) | |
| 1456 | (mh-thread-last-ancestor nil)) | |
| 1457 | (if (null mh-index-data) | |
| 1458 | (mh-thread-generate-scan-lines thread-tree -2) | |
| 1459 | (loop for x in (mh-index-group-by-folder) | |
| 1460 | do (let* ((old-map mh-thread-scan-line-map) | |
| 1461 | (mh-thread-scan-line-map (make-hash-table))) | |
| 1462 | (setq mh-thread-last-ancestor nil) | |
| 1463 | (loop for msg in (cdr x) | |
| 1464 | do (let ((v (gethash msg old-map))) | |
| 1465 | (when v | |
| 1466 | (setf (gethash msg mh-thread-scan-line-map) v)))) | |
| 1467 | (when (> (hash-table-count mh-thread-scan-line-map) 0) | |
| 1468 | (insert (if (bobp) "" "\n") (car x) "\n") | |
| f0d73c14 BW |
1469 | (mh-thread-generate-scan-lines thread-tree -2)))) |
| 1470 | (mh-index-create-imenu-index)))) | |
| 924df208 | 1471 | |
| bdcfe844 BW |
1472 | (defun mh-thread-folder () |
| 1473 | "Generate thread view of folder." | |
| 1474 | (message "Threading %s..." (buffer-name)) | |
| 1475 | (mh-thread-initialize) | |
| 1476 | (goto-char (point-min)) | |
| a66894d8 | 1477 | (mh-remove-all-notation) |
| 3d7ca223 | 1478 | (let ((msg-list ())) |
| a66894d8 BW |
1479 | (mh-iterate-on-range msg (cons (point-min) (point-max)) |
| 1480 | (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) | |
| 1481 | (push msg msg-list)) | |
| 3d7ca223 BW |
1482 | (let* ((range (mh-coalesce-msg-list msg-list)) |
| 1483 | (thread-tree (mh-thread-generate (buffer-name) range))) | |
| 1484 | (delete-region (point-min) (point-max)) | |
| 924df208 | 1485 | (mh-thread-print-scan-lines thread-tree) |
| 3d7ca223 BW |
1486 | (mh-notate-user-sequences) |
| 1487 | (mh-notate-deleted-and-refiled) | |
| 1488 | (mh-notate-cur) | |
| 1489 | (message "Threading %s...done" (buffer-name))))) | |
| bdcfe844 | 1490 | |
| c3d9274a | 1491 | ;;;###mh-autoload |
| bdcfe844 | 1492 | (defun mh-toggle-threads () |
| 3d7ca223 | 1493 | "Toggle threaded view of folder." |
| a1b4049d | 1494 | (interactive) |
| c3d9274a BW |
1495 | (let ((msg-at-point (mh-get-msg-num nil)) |
| 1496 | (old-buffer-modified-flag (buffer-modified-p)) | |
| 1497 | (buffer-read-only nil)) | |
| 3d7ca223 | 1498 | (cond ((memq 'unthread mh-view-ops) |
| bdcfe844 BW |
1499 | (unless (mh-valid-view-change-operation-p 'unthread) |
| 1500 | (error "Can't unthread folder")) | |
| 3d7ca223 BW |
1501 | (let ((msg-list ())) |
| 1502 | (goto-char (point-min)) | |
| 1503 | (while (not (eobp)) | |
| 924df208 | 1504 | (let ((index (mh-get-msg-num nil))) |
| 3d7ca223 BW |
1505 | (when index |
| 1506 | (push index msg-list))) | |
| 1507 | (forward-line)) | |
| 1508 | (mh-scan-folder mh-current-folder | |
| 1509 | (mapcar #'(lambda (x) (format "%s" x)) | |
| 1510 | (mh-coalesce-msg-list msg-list)) | |
| 1511 | t)) | |
| c3d9274a | 1512 | (when mh-index-data |
| 3d7ca223 BW |
1513 | (mh-index-insert-folder-headers) |
| 1514 | (mh-notate-cur))) | |
| bdcfe844 BW |
1515 | (t (mh-thread-folder) |
| 1516 | (push 'unthread mh-view-ops))) | |
| 1517 | (when msg-at-point (mh-goto-msg msg-at-point t t)) | |
| c3d9274a | 1518 | (set-buffer-modified-p old-buffer-modified-flag) |
| bdcfe844 BW |
1519 | (mh-recenter nil))) |
| 1520 | ||
| c3d9274a | 1521 | ;;;###mh-autoload |
| bdcfe844 BW |
1522 | (defun mh-thread-forget-message (index) |
| 1523 | "Forget the message INDEX from the threading tables." | |
| 1524 | (let* ((id (gethash index mh-thread-index-id-map)) | |
| 1525 | (id-index (gethash id mh-thread-id-index-map)) | |
| 1526 | (duplicates (gethash id mh-thread-duplicates))) | |
| 1527 | (remhash index mh-thread-index-id-map) | |
| 924df208 | 1528 | (remhash index mh-thread-scan-line-map) |
| bdcfe844 BW |
1529 | (cond ((and (eql index id-index) (null duplicates)) |
| 1530 | (remhash id mh-thread-id-index-map)) | |
| 1531 | ((eql index id-index) | |
| 1532 | (setf (gethash id mh-thread-id-index-map) (car duplicates)) | |
| 1533 | (setf (gethash (car duplicates) mh-thread-index-id-map) id) | |
| 1534 | (setf (gethash id mh-thread-duplicates) (cdr duplicates))) | |
| 1535 | (t | |
| 1536 | (setf (gethash id mh-thread-duplicates) | |
| 1537 | (remove index duplicates)))))) | |
| 1538 | ||
| c3d9274a BW |
1539 | \f |
| 1540 | ||
| 1541 | ;;; Operations on threads | |
| 1542 | ||
| 1543 | (defun mh-thread-current-indentation-level () | |
| 1544 | "Find the number of spaces by which current message is indented." | |
| 1545 | (save-excursion | |
| 1546 | (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
| 1547 | mh-scan-date-width 1)) | |
| 1548 | (level 0)) | |
| 1549 | (beginning-of-line) | |
| 1550 | (forward-char address-start-offset) | |
| 1551 | (while (char-equal (char-after) ? ) | |
| 1552 | (incf level) | |
| 1553 | (forward-char)) | |
| 1554 | level))) | |
| 1555 | ||
| 1556 | ;;;###mh-autoload | |
| 1557 | (defun mh-thread-next-sibling (&optional previous-flag) | |
| 1558 | "Jump to next sibling. | |
| 1559 | With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." | |
| 1560 | (interactive) | |
| 1561 | (cond ((not (memq 'unthread mh-view-ops)) | |
| 1562 | (error "Folder isn't threaded")) | |
| 1563 | ((eobp) | |
| 1564 | (error "No message at point"))) | |
| 1565 | (beginning-of-line) | |
| 1566 | (let ((point (point)) | |
| 1567 | (done nil) | |
| 1568 | (my-level (mh-thread-current-indentation-level))) | |
| 1569 | (while (and (not done) | |
| 1570 | (equal (forward-line (if previous-flag -1 1)) 0) | |
| 1571 | (not (eobp))) | |
| 1572 | (let ((level (mh-thread-current-indentation-level))) | |
| 1573 | (cond ((equal level my-level) | |
| 1574 | (setq done 'success)) | |
| 1575 | ((< level my-level) | |
| 1576 | (message "No %s sibling" (if previous-flag "previous" "next")) | |
| 1577 | (setq done 'failure))))) | |
| 1578 | (cond ((eq done 'success) (mh-maybe-show)) | |
| 1579 | ((eq done 'failure) (goto-char point)) | |
| 1580 | (t (message "No %s sibling" (if previous-flag "previous" "next")) | |
| 1581 | (goto-char point))))) | |
| 1582 | ||
| 1583 | ;;;###mh-autoload | |
| 1584 | (defun mh-thread-previous-sibling () | |
| 1585 | "Jump to previous sibling." | |
| 1586 | (interactive) | |
| 1587 | (mh-thread-next-sibling t)) | |
| 1588 | ||
| 1589 | (defun mh-thread-immediate-ancestor () | |
| 1590 | "Jump to immediate ancestor in thread tree." | |
| 1591 | (beginning-of-line) | |
| 1592 | (let ((point (point)) | |
| 1593 | (ancestor-level (- (mh-thread-current-indentation-level) 2)) | |
| 1594 | (done nil)) | |
| 1595 | (if (< ancestor-level 0) | |
| 1596 | nil | |
| 1597 | (while (and (not done) (equal (forward-line -1) 0)) | |
| 1598 | (when (equal ancestor-level (mh-thread-current-indentation-level)) | |
| 1599 | (setq done t))) | |
| 1600 | (unless done | |
| 1601 | (goto-char point)) | |
| 1602 | done))) | |
| 1603 | ||
| 1604 | ;;;###mh-autoload | |
| 1605 | (defun mh-thread-ancestor (&optional thread-root-flag) | |
| 1606 | "Jump to the ancestor of current message. | |
| 1607 | If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the | |
| 1608 | thread tree the message belongs to." | |
| 1609 | (interactive "P") | |
| 1610 | (beginning-of-line) | |
| 1611 | (cond ((not (memq 'unthread mh-view-ops)) | |
| 1612 | (error "Folder isn't threaded")) | |
| 1613 | ((eobp) | |
| 1614 | (error "No message at point"))) | |
| 1615 | (let ((current-level (mh-thread-current-indentation-level))) | |
| 1616 | (cond (thread-root-flag | |
| 1617 | (while (mh-thread-immediate-ancestor)) | |
| 1618 | (mh-maybe-show)) | |
| 1619 | ((equal current-level 1) | |
| 1620 | (message "Message has no ancestor")) | |
| 1621 | (t (mh-thread-immediate-ancestor) | |
| 1622 | (mh-maybe-show))))) | |
| 1623 | ||
| 1624 | (defun mh-thread-find-children () | |
| 1625 | "Return a region containing the current message and its children. | |
| 1626 | The result is returned as a list of two elements. The first is the point at the | |
| 1627 | start of the region and the second is the point at the end." | |
| 1628 | (beginning-of-line) | |
| 1629 | (if (eobp) | |
| 1630 | nil | |
| 1631 | (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
| 1632 | mh-scan-date-width 1)) | |
| 1633 | (level (mh-thread-current-indentation-level)) | |
| 1634 | spaces begin) | |
| 1635 | (setq begin (point)) | |
| 1636 | (setq spaces (format (format "%%%ss" (1+ level)) "")) | |
| 1637 | (forward-line) | |
| 1638 | (block nil | |
| 1639 | (while (not (eobp)) | |
| 1640 | (forward-char address-start-offset) | |
| 1641 | (unless (equal (string-match spaces (buffer-substring-no-properties | |
| 1642 | (point) (line-end-position))) | |
| 1643 | 0) | |
| 1644 | (beginning-of-line) | |
| 1645 | (backward-char) | |
| 1646 | (return)) | |
| 1647 | (forward-line))) | |
| 1648 | (list begin (point))))) | |
| 1649 | ||
| 1650 | ;;;###mh-autoload | |
| 1651 | (defun mh-thread-delete () | |
| 1652 | "Mark current message and all its children for subsequent deletion." | |
| 1653 | (interactive) | |
| 1654 | (cond ((not (memq 'unthread mh-view-ops)) | |
| 1655 | (error "Folder isn't threaded")) | |
| 1656 | ((eobp) | |
| 1657 | (error "No message at point")) | |
| 3d7ca223 BW |
1658 | (t (let ((region (mh-thread-find-children))) |
| 1659 | (mh-iterate-on-messages-in-region () (car region) (cadr region) | |
| 1660 | (mh-delete-a-msg nil)) | |
| 1661 | (mh-next-msg))))) | |
| c3d9274a | 1662 | |
| c3d9274a BW |
1663 | ;;;###mh-autoload |
| 1664 | (defun mh-thread-refile (folder) | |
| 1665 | "Mark current message and all its children for refiling to FOLDER." | |
| 3d7ca223 | 1666 | (interactive (list (intern (mh-prompt-for-refile-folder)))) |
| c3d9274a BW |
1667 | (cond ((not (memq 'unthread mh-view-ops)) |
| 1668 | (error "Folder isn't threaded")) | |
| 1669 | ((eobp) | |
| 1670 | (error "No message at point")) | |
| 3d7ca223 BW |
1671 | (t (let ((region (mh-thread-find-children))) |
| 1672 | (mh-iterate-on-messages-in-region () (car region) (cadr region) | |
| 1673 | (mh-refile-a-msg nil folder)) | |
| 1674 | (mh-next-msg))))) | |
| c3d9274a | 1675 | |
| 924df208 BW |
1676 | \f |
| 1677 | ||
| 1678 | ;; Tick mark handling | |
| 1679 | ||
| 924df208 | 1680 | ;;;###mh-autoload |
| a66894d8 | 1681 | (defun mh-toggle-tick (range) |
| be33fce4 BW |
1682 | "Toggle tick mark of all messages in RANGE. |
| 1683 | ||
| 1684 | This command adds messages to the \"tick\" sequence (which you can customize | |
| 1685 | via the option `mh-tick-seq'). This sequence can be viewed later with the | |
| 1686 | \\[mh-index-ticked-messages] command. | |
| 1687 | ||
| 1688 | Check the documentation of `mh-interactive-range' to see how RANGE is read in | |
| 1689 | interactive use." | |
| a66894d8 | 1690 | (interactive (list (mh-interactive-range "Tick"))) |
| 924df208 BW |
1691 | (unless mh-tick-seq |
| 1692 | (error "Enable ticking by customizing `mh-tick-seq'")) | |
| 1693 | (let* ((tick-seq (mh-find-seq mh-tick-seq)) | |
| a66894d8 BW |
1694 | (tick-seq-msgs (mh-seq-msgs tick-seq)) |
| 1695 | (ticked ()) | |
| 1696 | (unticked ())) | |
| 1697 | (mh-iterate-on-range msg range | |
| 924df208 | 1698 | (cond ((member msg tick-seq-msgs) |
| a66894d8 | 1699 | (push msg unticked) |
| 924df208 BW |
1700 | (setcdr tick-seq (delq msg (cdr tick-seq))) |
| 1701 | (when (null (cdr tick-seq)) (setq mh-last-seq-used nil)) | |
| f0d73c14 | 1702 | (mh-remove-sequence-notation msg (mh-colors-in-use-p))) |
| 924df208 | 1703 | (t |
| a66894d8 | 1704 | (push msg ticked) |
| 924df208 | 1705 | (setq mh-last-seq-used mh-tick-seq) |
| f0d73c14 BW |
1706 | (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list))) |
| 1707 | (mh-add-sequence-notation msg (mh-colors-in-use-p)))))) | |
| a66894d8 BW |
1708 | (mh-add-msgs-to-seq ticked mh-tick-seq nil t) |
| 1709 | (mh-undefine-sequence mh-tick-seq unticked) | |
| 1710 | (when mh-index-data | |
| 1711 | (mh-index-add-to-sequence mh-tick-seq ticked) | |
| 1712 | (mh-index-delete-from-sequence mh-tick-seq unticked)))) | |
| 924df208 BW |
1713 | |
| 1714 | ;;;###mh-autoload | |
| 1715 | (defun mh-narrow-to-tick () | |
| be33fce4 | 1716 | "Limit to ticked messages. |
| f0d73c14 | 1717 | |
| be33fce4 BW |
1718 | What this command does is show only those messages that are in the \"tick\" |
| 1719 | sequence (which you can customize via the `mh-tick-seq' option) in the | |
| 1720 | MH-Folder buffer. In addition, it limits further MH-E searches to just those | |
| 1721 | messages. When you want to widen the view to all your messages again, use | |
| 1722 | \\[mh-widen]." | |
| 924df208 BW |
1723 | (interactive) |
| 1724 | (cond ((not mh-tick-seq) | |
| 1725 | (error "Enable ticking by customizing `mh-tick-seq'")) | |
| 1726 | ((null (mh-seq-msgs (mh-find-seq mh-tick-seq))) | |
| f0d73c14 | 1727 | (message "No messages in %s sequence" mh-tick-seq)) |
| 924df208 BW |
1728 | (t (mh-narrow-to-seq mh-tick-seq)))) |
| 1729 | ||
| bdcfe844 BW |
1730 | (provide 'mh-seq) |
| 1731 | ||
| 1732 | ;;; Local Variables: | |
| c3d9274a | 1733 | ;;; indent-tabs-mode: nil |
| bdcfe844 BW |
1734 | ;;; sentence-end-double-space: nil |
| 1735 | ;;; End: | |
| a1b4049d | 1736 | |
| ab5796a9 | 1737 | ;;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942 |
| 60370d40 | 1738 | ;;; mh-seq.el ends here |