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