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