Mercurial > emacs
annotate lisp/mh-e/mh-thread.el @ 105755:cc6727b235b0
* nxml/nxml-mode.el (nxml-balanced-close-start-tag): Use the value
of xmltok-start before the end tag was inserted (Bug#2840).
author | Chong Yidong <cyd@stupidchicken.com> |
---|---|
date | Sat, 24 Oct 2009 21:32:19 +0000 |
parents | 6837adfb2772 |
children | 00c0adbb54a9 |
rev | line source |
---|---|
68465 | 1 ;;; mh-thread.el --- MH-E threading support |
2 | |
101484
ec23bb963b19
Follow Glenn's lead and update format of Copyright.
Bill Wohler <wohler@newt.com>
parents:
100908
diff
changeset
|
3 ;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008, 2009 |
ec23bb963b19
Follow Glenn's lead and update format of Copyright.
Bill Wohler <wohler@newt.com>
parents:
100908
diff
changeset
|
4 ;; Free Software Foundation, Inc. |
68465 | 5 |
6 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu> | |
7 ;; Maintainer: Bill Wohler <wohler@newt.com> | |
8 ;; Keywords: mail | |
9 ;; See: mh-e.el | |
10 | |
11 ;; This file is part of GNU Emacs. | |
12 | |
94663
90c9ebd43589
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79713
diff
changeset
|
13 ;; GNU Emacs is free software: you can redistribute it and/or modify |
68465 | 14 ;; it under the terms of the GNU General Public License as published by |
94663
90c9ebd43589
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79713
diff
changeset
|
15 ;; the Free Software Foundation, either version 3 of the License, or |
90c9ebd43589
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79713
diff
changeset
|
16 ;; (at your option) any later version. |
68465 | 17 |
18 ;; GNU Emacs is distributed in the hope that it will be useful, | |
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
21 ;; GNU General Public License for more details. | |
22 | |
23 ;; You should have received a copy of the GNU General Public License | |
94663
90c9ebd43589
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
79713
diff
changeset
|
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
68465 | 25 |
26 ;;; Commentary: | |
27 | |
28 ;; The threading portion of this files tries to implement the | |
29 ;; algorithm described at: | |
30 ;; http://www.jwz.org/doc/threading.html | |
31 ;; It also begins to implement the IMAP Threading extension RFC. The | |
32 ;; implementation lacks the reference and subject canonicalization of | |
33 ;; the RFC. | |
34 | |
35 ;; In the presentation buffer, children messages are shown indented | |
36 ;; with either [ ] or < > around them. Square brackets ([ ]) denote | |
37 ;; that the algorithm can point out some headers which when taken | |
38 ;; together implies that the unindented message is an ancestor of the | |
39 ;; indented message. If no such proof exists then angles (< >) are | |
40 ;; used. | |
41 | |
42 ;; If threading is slow on your machine, compile this file. Of all the | |
43 ;; files in MH-E, this one really benefits from compilation. | |
44 | |
45 ;; Some issues and problems are as follows: | |
46 | |
47 ;; (1) Scan truncates the fields at length 512. So longer | |
48 ;; references: headers get mutilated. The same kind of MH | |
49 ;; format string works when composing messages. Is there a way | |
50 ;; to avoid this? My scan command is as follows: | |
51 ;; scan +folder -width 10000 \ | |
52 ;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" | |
53 ;; I would really appreciate it if someone would help me with this. | |
54 | |
55 ;; (2) Implement heuristics to recognize message identifiers in | |
56 ;; In-Reply-To: header. Right now it just assumes that the last | |
57 ;; text between angles (< and >) is the message identifier. | |
58 ;; There is the chance that this will incorrectly use an email | |
59 ;; address like a message identifier. | |
60 | |
61 ;; (3) Error checking of found message identifiers should be done. | |
62 | |
63 ;; (4) Since this breaks the assumption that message indices | |
64 ;; increase as one goes down the buffer, the binary search | |
65 ;; based mh-goto-msg doesn't work. I have a simpler replacement | |
66 ;; which may be less efficient. | |
67 | |
68 ;; (5) Better canonicalizing for message identifier and subject | |
69 ;; strings. | |
70 | |
71 ;;; Change Log: | |
72 | |
73 ;;; Code: | |
74 | |
75 (require 'mh-e) | |
76 (require 'mh-scan) | |
77 | |
78 (mh-defstruct (mh-thread-message (:conc-name mh-message-) | |
79 (:constructor mh-thread-make-message)) | |
80 (id nil) | |
81 (references ()) | |
82 (subject "") | |
83 (subject-re-p nil)) | |
84 | |
85 (mh-defstruct (mh-thread-container (:conc-name mh-container-) | |
86 (:constructor mh-thread-make-container)) | |
87 message parent children | |
88 (real-child-p t)) | |
89 | |
90 (defvar mh-thread-id-hash nil | |
91 "Hashtable used to canonicalize message identifiers.") | |
92 (make-variable-buffer-local 'mh-thread-id-hash) | |
93 | |
94 (defvar mh-thread-subject-hash nil | |
95 "Hashtable used to canonicalize subject strings.") | |
96 (make-variable-buffer-local 'mh-thread-subject-hash) | |
97 | |
98 (defvar mh-thread-id-table nil | |
99 "Thread ID table maps from message identifiers to message containers.") | |
100 (make-variable-buffer-local 'mh-thread-id-table) | |
101 | |
102 (defvar mh-thread-index-id-map nil | |
103 "Table to look up message identifier from message index.") | |
104 (make-variable-buffer-local 'mh-thread-index-id-map) | |
105 | |
106 (defvar mh-thread-id-index-map nil | |
107 "Table to look up message index number from message identifier.") | |
108 (make-variable-buffer-local 'mh-thread-id-index-map) | |
109 | |
110 (defvar mh-thread-subject-container-hash nil | |
111 "Hashtable used to group messages by subject.") | |
112 (make-variable-buffer-local 'mh-thread-subject-container-hash) | |
113 | |
114 (defvar mh-thread-duplicates nil | |
115 "Hashtable used to associate messages with the same message identifier.") | |
116 (make-variable-buffer-local 'mh-thread-duplicates) | |
117 | |
118 (defvar mh-thread-history () | |
119 "Variable to remember the transformations to the thread tree. | |
120 When new messages are added, these transformations are rewound, | |
121 then the links are added from the newly seen messages. Finally | |
122 the transformations are redone to get the new thread tree. This | |
123 makes incremental threading easier.") | |
124 (make-variable-buffer-local 'mh-thread-history) | |
125 | |
126 (defvar mh-thread-body-width nil | |
127 "Width of scan substring that contains subject and body of message.") | |
128 | |
129 | |
130 | |
131 ;;; MH-Folder Commands | |
132 | |
133 ;;;###mh-autoload | |
134 (defun mh-thread-ancestor (&optional thread-root-flag) | |
135 "Display ancestor of current message. | |
136 | |
137 If you do not care for the way a particular thread has turned, | |
138 you can move up the chain of messages with this command. This | |
139 command can also take a prefix argument THREAD-ROOT-FLAG to jump | |
140 to the message that started everything." | |
141 (interactive "P") | |
142 (beginning-of-line) | |
143 (cond ((not (memq 'unthread mh-view-ops)) | |
144 (error "Folder isn't threaded")) | |
145 ((eobp) | |
146 (error "No message at point"))) | |
147 (let ((current-level (mh-thread-current-indentation-level))) | |
148 (cond (thread-root-flag | |
149 (while (mh-thread-immediate-ancestor)) | |
150 (mh-maybe-show)) | |
151 ((equal current-level 1) | |
152 (message "Message has no ancestor")) | |
153 (t (mh-thread-immediate-ancestor) | |
154 (mh-maybe-show))))) | |
155 | |
156 ;;;###mh-autoload | |
157 (defun mh-thread-delete () | |
158 "Delete thread." | |
159 (interactive) | |
160 (cond ((not (memq 'unthread mh-view-ops)) | |
161 (error "Folder isn't threaded")) | |
162 ((eobp) | |
163 (error "No message at point")) | |
164 (t (let ((region (mh-thread-find-children))) | |
165 (mh-iterate-on-messages-in-region () (car region) (cadr region) | |
166 (mh-delete-a-msg nil)) | |
167 (mh-next-msg))))) | |
168 | |
169 ;;;###mh-autoload | |
170 (defun mh-thread-next-sibling (&optional previous-flag) | |
171 "Display next sibling. | |
172 | |
173 With non-nil optional argument PREVIOUS-FLAG jump to the previous | |
174 sibling." | |
175 (interactive) | |
176 (cond ((not (memq 'unthread mh-view-ops)) | |
177 (error "Folder isn't threaded")) | |
178 ((eobp) | |
179 (error "No message at point"))) | |
180 (beginning-of-line) | |
181 (let ((point (point)) | |
182 (done nil) | |
183 (my-level (mh-thread-current-indentation-level))) | |
184 (while (and (not done) | |
185 (equal (forward-line (if previous-flag -1 1)) 0) | |
186 (not (eobp))) | |
187 (let ((level (mh-thread-current-indentation-level))) | |
188 (cond ((equal level my-level) | |
189 (setq done 'success)) | |
190 ((< level my-level) | |
191 (message "No %s sibling" (if previous-flag "previous" "next")) | |
192 (setq done 'failure))))) | |
193 (cond ((eq done 'success) (mh-maybe-show)) | |
194 ((eq done 'failure) (goto-char point)) | |
195 (t (message "No %s sibling" (if previous-flag "previous" "next")) | |
196 (goto-char point))))) | |
197 | |
198 ;;;###mh-autoload | |
199 (defun mh-thread-previous-sibling () | |
200 "Display previous sibling." | |
201 (interactive) | |
202 (mh-thread-next-sibling t)) | |
203 | |
204 ;;;###mh-autoload | |
205 (defun mh-thread-refile (folder) | |
206 "Refile (output) thread into FOLDER." | |
207 (interactive (list (intern (mh-prompt-for-refile-folder)))) | |
208 (cond ((not (memq 'unthread mh-view-ops)) | |
209 (error "Folder isn't threaded")) | |
210 ((eobp) | |
211 (error "No message at point")) | |
212 (t (let ((region (mh-thread-find-children))) | |
213 (mh-iterate-on-messages-in-region () (car region) (cadr region) | |
214 (mh-refile-a-msg nil folder)) | |
215 (mh-next-msg))))) | |
216 | |
217 ;;;###mh-autoload | |
218 (defun mh-toggle-threads () | |
219 "Toggle threaded view of folder." | |
220 (interactive) | |
221 (let ((msg-at-point (mh-get-msg-num nil)) | |
222 (old-buffer-modified-flag (buffer-modified-p)) | |
223 (buffer-read-only nil)) | |
224 (cond ((memq 'unthread mh-view-ops) | |
225 (unless (mh-valid-view-change-operation-p 'unthread) | |
226 (error "Can't unthread folder")) | |
227 (let ((msg-list ())) | |
228 (goto-char (point-min)) | |
229 (while (not (eobp)) | |
230 (let ((index (mh-get-msg-num nil))) | |
231 (when index | |
232 (push index msg-list))) | |
233 (forward-line)) | |
234 (mh-scan-folder mh-current-folder | |
235 (mapcar #'(lambda (x) (format "%s" x)) | |
236 (mh-coalesce-msg-list msg-list)) | |
237 t)) | |
238 (when mh-index-data | |
239 (mh-index-insert-folder-headers) | |
240 (mh-notate-cur))) | |
241 (t (mh-thread-folder) | |
242 (push 'unthread mh-view-ops))) | |
243 (when msg-at-point (mh-goto-msg msg-at-point t t)) | |
244 (set-buffer-modified-p old-buffer-modified-flag) | |
245 (mh-recenter nil))) | |
246 | |
247 | |
248 | |
249 ;;; Support Routines | |
250 | |
251 (defun mh-thread-current-indentation-level () | |
252 "Find the number of spaces by which current message is indented." | |
253 (save-excursion | |
254 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
255 mh-scan-date-width 1)) | |
256 (level 0)) | |
257 (beginning-of-line) | |
258 (forward-char address-start-offset) | |
259 (while (char-equal (char-after) ? ) | |
260 (incf level) | |
261 (forward-char)) | |
262 level))) | |
263 | |
264 (defun mh-thread-immediate-ancestor () | |
265 "Jump to immediate ancestor in thread tree." | |
266 (beginning-of-line) | |
267 (let ((point (point)) | |
268 (ancestor-level (- (mh-thread-current-indentation-level) 2)) | |
269 (done nil)) | |
270 (if (< ancestor-level 0) | |
271 nil | |
272 (while (and (not done) (equal (forward-line -1) 0)) | |
273 (when (equal ancestor-level (mh-thread-current-indentation-level)) | |
274 (setq done t))) | |
275 (unless done | |
276 (goto-char point)) | |
277 done))) | |
278 | |
279 (defun mh-thread-find-children () | |
280 "Return a region containing the current message and its children. | |
281 The result is returned as a list of two elements. The first is | |
282 the point at the start of the region and the second is the point | |
283 at the end." | |
284 (beginning-of-line) | |
285 (if (eobp) | |
286 nil | |
287 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
288 mh-scan-date-width 1)) | |
289 (level (mh-thread-current-indentation-level)) | |
290 spaces begin) | |
291 (setq begin (point)) | |
292 (setq spaces (format (format "%%%ss" (1+ level)) "")) | |
293 (forward-line) | |
294 (block nil | |
295 (while (not (eobp)) | |
296 (forward-char address-start-offset) | |
297 (unless (equal (string-match spaces (buffer-substring-no-properties | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
298 (point) (mh-line-end-position))) |
68465 | 299 0) |
300 (beginning-of-line) | |
301 (backward-char) | |
302 (return)) | |
303 (forward-line))) | |
304 (list begin (point))))) | |
305 | |
306 | |
307 | |
308 ;;; Thread Creation | |
309 | |
310 (defun mh-thread-folder () | |
311 "Generate thread view of folder." | |
312 (message "Threading %s..." (buffer-name)) | |
313 (mh-thread-initialize) | |
314 (goto-char (point-min)) | |
315 (mh-remove-all-notation) | |
316 (let ((msg-list ())) | |
317 (mh-iterate-on-range msg (cons (point-min) (point-max)) | |
318 (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) | |
319 (push msg msg-list)) | |
320 (let* ((range (mh-coalesce-msg-list msg-list)) | |
321 (thread-tree (mh-thread-generate (buffer-name) range))) | |
322 (delete-region (point-min) (point-max)) | |
323 (mh-thread-print-scan-lines thread-tree) | |
324 (mh-notate-user-sequences) | |
325 (mh-notate-deleted-and-refiled) | |
326 (mh-notate-cur) | |
327 (message "Threading %s...done" (buffer-name))))) | |
328 | |
329 ;;;###mh-autoload | |
330 (defun mh-thread-inc (folder start-point) | |
331 "Update thread tree for FOLDER. | |
332 All messages after START-POINT are added to the thread tree." | |
333 (mh-thread-rewind-pruning) | |
334 (mh-remove-all-notation) | |
335 (goto-char start-point) | |
336 (let ((msg-list ())) | |
337 (while (not (eobp)) | |
338 (let ((index (mh-get-msg-num nil))) | |
339 (when (numberp index) | |
340 (push index msg-list) | |
341 (setf (gethash index mh-thread-scan-line-map) | |
342 (mh-thread-parse-scan-line))) | |
343 (forward-line))) | |
344 (let ((thread-tree (mh-thread-generate folder msg-list)) | |
345 (buffer-read-only nil) | |
346 (old-buffer-modified-flag (buffer-modified-p))) | |
347 (delete-region (point-min) (point-max)) | |
348 (mh-thread-print-scan-lines thread-tree) | |
349 (mh-notate-user-sequences) | |
350 (mh-notate-deleted-and-refiled) | |
351 (mh-notate-cur) | |
352 (set-buffer-modified-p old-buffer-modified-flag)))) | |
353 | |
354 (defmacro mh-thread-initialize-hash (var test) | |
355 "Initialize the hash table in VAR. | |
356 TEST is the test to use when creating a new hash table." | |
357 (unless (symbolp var) (error "Expected a symbol: %s" var)) | |
358 `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) | |
359 | |
360 (defun mh-thread-initialize () | |
361 "Make new hash tables, or clear them if already present." | |
362 (mh-thread-initialize-hash mh-thread-id-hash #'equal) | |
363 (mh-thread-initialize-hash mh-thread-subject-hash #'equal) | |
364 (mh-thread-initialize-hash mh-thread-id-table #'eq) | |
365 (mh-thread-initialize-hash mh-thread-id-index-map #'eq) | |
366 (mh-thread-initialize-hash mh-thread-index-id-map #'eql) | |
367 (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) | |
368 (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) | |
369 (mh-thread-initialize-hash mh-thread-duplicates #'eq) | |
370 (setq mh-thread-history ())) | |
371 | |
372 (defsubst mh-thread-id-container (id) | |
373 "Given ID, return the corresponding container in `mh-thread-id-table'. | |
374 If no container exists then a suitable container is created and | |
375 the id-table is updated." | |
376 (when (not id) | |
377 (error "1")) | |
378 (or (gethash id mh-thread-id-table) | |
379 (setf (gethash id mh-thread-id-table) | |
380 (let ((message (mh-thread-make-message :id id))) | |
381 (mh-thread-make-container :message message))))) | |
382 | |
383 (defsubst mh-thread-remove-parent-link (child) | |
384 "Remove parent link of CHILD if it exists." | |
385 (let* ((child-container (if (mh-thread-container-p child) | |
386 child (mh-thread-id-container child))) | |
387 (parent-container (mh-container-parent child-container))) | |
388 (when parent-container | |
389 (setf (mh-container-children parent-container) | |
390 (loop for elem in (mh-container-children parent-container) | |
391 unless (eq child-container elem) collect elem)) | |
392 (setf (mh-container-parent child-container) nil)))) | |
393 | |
394 (defsubst mh-thread-add-link (parent child &optional at-end-p) | |
395 "Add links so that PARENT becomes a parent of CHILD. | |
396 Doesn't make any changes if CHILD is already an ancestor of | |
397 PARENT. If optional argument AT-END-P is non-nil, the CHILD is | |
398 added to the end of the children list of PARENT." | |
399 (let ((parent-container (cond ((null parent) nil) | |
400 ((mh-thread-container-p parent) parent) | |
401 (t (mh-thread-id-container parent)))) | |
402 (child-container (if (mh-thread-container-p child) | |
403 child (mh-thread-id-container child)))) | |
404 (when (and parent-container | |
405 (not (mh-thread-ancestor-p child-container parent-container)) | |
406 (not (mh-thread-ancestor-p parent-container child-container))) | |
407 (mh-thread-remove-parent-link child-container) | |
408 (cond ((not at-end-p) | |
409 (push child-container (mh-container-children parent-container))) | |
410 ((null (mh-container-children parent-container)) | |
411 (push child-container (mh-container-children parent-container))) | |
412 (t (let ((last-child (mh-container-children parent-container))) | |
413 (while (cdr last-child) | |
414 (setq last-child (cdr last-child))) | |
415 (setcdr last-child (cons child-container nil))))) | |
416 (setf (mh-container-parent child-container) parent-container)) | |
417 (unless parent-container | |
418 (mh-thread-remove-parent-link child-container)))) | |
419 | |
420 (defun mh-thread-rewind-pruning () | |
421 "Restore the thread tree to its state before pruning." | |
422 (while mh-thread-history | |
423 (let ((action (pop mh-thread-history))) | |
424 (cond ((eq (car action) 'DROP) | |
425 (mh-thread-remove-parent-link (cadr action)) | |
426 (mh-thread-add-link (caddr action) (cadr action))) | |
427 ((eq (car action) 'PROMOTE) | |
428 (let ((node (cadr action)) | |
429 (parent (caddr action)) | |
430 (children (cdddr action))) | |
431 (dolist (child children) | |
432 (mh-thread-remove-parent-link child) | |
433 (mh-thread-add-link node child)) | |
434 (mh-thread-add-link parent node))) | |
435 ((eq (car action) 'SUBJECT) | |
436 (let ((node (cadr action))) | |
437 (mh-thread-remove-parent-link node) | |
438 (setf (mh-container-real-child-p node) t))))))) | |
439 | |
440 (defun mh-thread-ancestor-p (ancestor successor) | |
441 "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. | |
442 In the limit, the function returns t if ANCESTOR and SUCCESSOR | |
443 are the same containers." | |
444 (block nil | |
445 (while successor | |
446 (when (eq ancestor successor) (return t)) | |
447 (setq successor (mh-container-parent successor))) | |
448 nil)) | |
449 | |
450 ;; Another and may be better approach would be to generate all the info from | |
451 ;; the scan which generates the threading info. For now this will have to do. | |
452 ;;;###mh-autoload | |
453 (defun mh-thread-parse-scan-line (&optional string) | |
454 "Parse a scan line. | |
455 If optional argument STRING is given then that is assumed to be | |
456 the scan line. Otherwise uses the line at point as the scan line | |
457 to parse." | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
458 (let* ((string (or string (buffer-substring-no-properties |
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
459 (mh-line-beginning-position) |
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
460 (mh-line-end-position)))) |
68465 | 461 (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) |
462 (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) | |
463 (first-string (substring string 0 address-start))) | |
464 (list first-string | |
465 (substring string address-start (- body-start 2)) | |
466 (substring string body-start) | |
467 string))) | |
468 | |
469 (defsubst mh-thread-canonicalize-id (id) | |
470 "Produce canonical string representation for ID. | |
471 This allows cheap string comparison with EQ." | |
472 (or (and (equal id "") (copy-sequence "")) | |
473 (gethash id mh-thread-id-hash) | |
474 (setf (gethash id mh-thread-id-hash) id))) | |
475 | |
476 (defsubst mh-thread-prune-subject (subject) | |
477 "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. | |
478 If the result after pruning is not the empty string then it is | |
479 canonicalized so that subjects can be tested for equality with | |
480 eq. This is done so that all the messages without a subject are | |
481 not put into a single thread." | |
482 (let ((case-fold-search t) | |
483 (subject-pruned-flag nil)) | |
484 ;; Prune subject leader | |
485 (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" | |
486 subject) | |
487 (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) | |
488 (setq subject-pruned-flag t) | |
489 (setq subject (substring subject (match-end 0)))) | |
490 ;; Prune subject trailer | |
491 (while (or (string-match "(fwd)$" subject) | |
492 (string-match "[ \t]+$" subject)) | |
493 (setq subject-pruned-flag t) | |
494 (setq subject (substring subject 0 (match-beginning 0)))) | |
495 ;; Canonicalize subject only if it is non-empty | |
102537
6837adfb2772
m-v: use lists to pass things around rather than values.
Deepak Goel <deego@gnufans.org>
parents:
101484
diff
changeset
|
496 (cond ((equal subject "") (list subject subject-pruned-flag)) |
6837adfb2772
m-v: use lists to pass things around rather than values.
Deepak Goel <deego@gnufans.org>
parents:
101484
diff
changeset
|
497 (t (list |
68465 | 498 (or (gethash subject mh-thread-subject-hash) |
499 (setf (gethash subject mh-thread-subject-hash) subject)) | |
500 subject-pruned-flag))))) | |
501 | |
502 (defsubst mh-thread-group-by-subject (roots) | |
503 "Group the set of message containers, ROOTS based on subject. | |
504 Bug: Check for and make sure that something without Re: is made | |
505 the parent in preference to something that has it." | |
506 (clrhash mh-thread-subject-container-hash) | |
507 (let ((results ())) | |
508 (dolist (root roots) | |
509 (let* ((subject (mh-thread-container-subject root)) | |
510 (parent (gethash subject mh-thread-subject-container-hash))) | |
511 (cond (parent (mh-thread-remove-parent-link root) | |
512 (mh-thread-add-link parent root t) | |
513 (setf (mh-container-real-child-p root) nil) | |
514 (push `(SUBJECT ,root) mh-thread-history)) | |
515 (t | |
516 (setf (gethash subject mh-thread-subject-container-hash) root) | |
517 (push root results))))) | |
518 (nreverse results))) | |
519 | |
520 (defun mh-thread-container-subject (container) | |
521 "Return the subject of CONTAINER. | |
522 If CONTAINER is empty return the subject info of one of its | |
523 children." | |
524 (cond ((and (mh-container-message container) | |
525 (mh-message-id (mh-container-message container))) | |
526 (mh-message-subject (mh-container-message container))) | |
527 (t (block nil | |
528 (dolist (kid (mh-container-children container)) | |
529 (when (and (mh-container-message kid) | |
530 (mh-message-id (mh-container-message kid))) | |
531 (let ((kid-message (mh-container-message kid))) | |
532 (return (mh-message-subject kid-message))))) | |
533 (error "This can't happen"))))) | |
534 | |
535 (defsubst mh-thread-update-id-index-maps (id index) | |
536 "Message with id, ID is the message in INDEX. | |
537 The function also checks for duplicate messages (that is multiple | |
538 messages with the same ID). These messages are put in the | |
539 `mh-thread-duplicates' hash table." | |
540 (let ((old-index (gethash id mh-thread-id-index-map))) | |
541 (when old-index (push old-index (gethash id mh-thread-duplicates))) | |
542 (setf (gethash id mh-thread-id-index-map) index) | |
543 (setf (gethash index mh-thread-index-id-map) id))) | |
544 | |
545 (defsubst mh-thread-get-message-container (message) | |
546 "Return container which has MESSAGE in it. | |
547 If there is no container present then a new container is | |
548 allocated." | |
549 (let* ((id (mh-message-id message)) | |
550 (container (gethash id mh-thread-id-table))) | |
551 (cond (container (setf (mh-container-message container) message) | |
552 container) | |
553 (t (setf (gethash id mh-thread-id-table) | |
554 (mh-thread-make-container :message message)))))) | |
555 | |
556 (defsubst mh-thread-get-message (id subject-re-p subject refs) | |
557 "Return appropriate message. | |
558 Otherwise update message already present to have the proper ID, | |
559 SUBJECT-RE-P, SUBJECT and REFS fields." | |
560 (let* ((container (gethash id mh-thread-id-table)) | |
561 (message (if container (mh-container-message container) nil))) | |
562 (cond (message | |
563 (setf (mh-message-subject-re-p message) subject-re-p) | |
564 (setf (mh-message-subject message) subject) | |
565 (setf (mh-message-id message) id) | |
566 (setf (mh-message-references message) refs) | |
567 message) | |
568 (container | |
569 (setf (mh-container-message container) | |
570 (mh-thread-make-message :id id :references refs | |
571 :subject subject | |
572 :subject-re-p subject-re-p))) | |
573 (t (let ((message (mh-thread-make-message :id id :references refs | |
574 :subject-re-p subject-re-p | |
575 :subject subject))) | |
576 (prog1 message | |
577 (mh-thread-get-message-container message))))))) | |
578 | |
579 (defvar mh-message-id-regexp "^<.*@.*>$" | |
580 "Regexp to recognize whether a string is a message identifier.") | |
581 | |
582 ;;;###mh-autoload | |
583 (defun mh-thread-generate (folder msg-list) | |
584 "Scan FOLDER to get info for threading. | |
585 Only information about messages in MSG-LIST are added to the tree." | |
586 (with-temp-buffer | |
587 (mh-thread-set-tables folder) | |
588 (when msg-list | |
589 (apply | |
590 #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil | |
591 "-width" "10000" "-format" | |
592 "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" | |
593 folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) | |
594 (goto-char (point-min)) | |
595 (let ((roots ()) | |
596 (case-fold-search t)) | |
597 (block nil | |
598 (while (not (eobp)) | |
599 (block process-message | |
600 (let* ((index-line | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
601 (prog1 (buffer-substring (point) (mh-line-end-position)) |
68465 | 602 (forward-line))) |
603 (index (string-to-number index-line)) | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
604 (id (prog1 (buffer-substring (point) (mh-line-end-position)) |
68465 | 605 (forward-line))) |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
606 (refs (prog1 |
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
607 (buffer-substring (point) (mh-line-end-position)) |
68465 | 608 (forward-line))) |
609 (in-reply-to (prog1 (buffer-substring (point) | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
610 (mh-line-end-position)) |
68465 | 611 (forward-line))) |
612 (subject (prog1 | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
613 (buffer-substring |
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
614 (point) (mh-line-end-position)) |
68465 | 615 (forward-line))) |
616 (subject-re-p nil)) | |
617 (unless (gethash index mh-thread-scan-line-map) | |
618 (return-from process-message)) | |
619 (unless (integerp index) (return)) ;Error message here | |
620 (multiple-value-setq (subject subject-re-p) | |
102537
6837adfb2772
m-v: use lists to pass things around rather than values.
Deepak Goel <deego@gnufans.org>
parents:
101484
diff
changeset
|
621 (values-list (mh-thread-prune-subject subject))) |
68465 | 622 (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) |
623 (setq refs (loop for x in (append (split-string refs) in-reply-to) | |
624 when (string-match mh-message-id-regexp x) | |
625 collect x)) | |
626 (setq id (mh-thread-canonicalize-id id)) | |
627 (mh-thread-update-id-index-maps id index) | |
628 (setq refs (mapcar #'mh-thread-canonicalize-id refs)) | |
629 (mh-thread-get-message id subject-re-p subject refs) | |
630 (do ((ancestors refs (cdr ancestors))) | |
631 ((null (cdr ancestors)) | |
632 (when (car ancestors) | |
633 (mh-thread-remove-parent-link id) | |
634 (mh-thread-add-link (car ancestors) id))) | |
635 (mh-thread-add-link (car ancestors) (cadr ancestors))))))) | |
636 (maphash #'(lambda (k v) | |
637 (declare (ignore k)) | |
638 (when (null (mh-container-parent v)) | |
639 (push v roots))) | |
640 mh-thread-id-table) | |
641 (setq roots (mh-thread-prune-containers roots)) | |
642 (prog1 (setq roots (mh-thread-group-by-subject roots)) | |
643 (let ((history mh-thread-history)) | |
644 (set-buffer folder) | |
645 (setq mh-thread-history history)))))) | |
646 | |
647 (defun mh-thread-set-tables (folder) | |
648 "Use the tables of FOLDER in current buffer." | |
649 (flet ((mh-get-table (symbol) | |
650 (save-excursion | |
651 (set-buffer folder) | |
652 (symbol-value symbol)))) | |
653 (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) | |
654 (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) | |
655 (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) | |
656 (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) | |
657 (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) | |
658 (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) | |
659 (setq mh-thread-subject-container-hash | |
660 (mh-get-table 'mh-thread-subject-container-hash)) | |
661 (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) | |
662 (setq mh-thread-history (mh-get-table 'mh-thread-history)))) | |
663 | |
664 (defun mh-thread-process-in-reply-to (reply-to-header) | |
665 "Extract message id's from REPLY-TO-HEADER. | |
666 Ideally this should have some regexp which will try to guess if a | |
667 string between < and > is a message id and not an email address. | |
668 For now it will take the last string inside angles." | |
669 (let ((end (mh-search-from-end ?> reply-to-header))) | |
670 (when (numberp end) | |
671 (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) | |
672 (when (numberp begin) | |
673 (list (substring reply-to-header begin (1+ end)))))))) | |
674 | |
675 (defun mh-thread-prune-containers (roots) | |
676 "Prune empty containers in the containers ROOTS." | |
677 (let ((dfs-ordered-nodes ()) | |
678 (work-list roots)) | |
679 (while work-list | |
680 (let ((node (pop work-list))) | |
681 (dolist (child (mh-container-children node)) | |
682 (push child work-list)) | |
683 (push node dfs-ordered-nodes))) | |
684 (while dfs-ordered-nodes | |
685 (let ((node (pop dfs-ordered-nodes))) | |
686 (cond ((gethash (mh-message-id (mh-container-message node)) | |
687 mh-thread-id-index-map) | |
688 ;; Keep it | |
689 (setf (mh-container-children node) | |
690 (mh-thread-sort-containers (mh-container-children node)))) | |
691 ((and (mh-container-children node) | |
692 (or (null (cdr (mh-container-children node))) | |
693 (mh-container-parent node))) | |
694 ;; Promote kids | |
695 (let ((children ())) | |
696 (dolist (kid (mh-container-children node)) | |
697 (mh-thread-remove-parent-link kid) | |
698 (mh-thread-add-link (mh-container-parent node) kid) | |
699 (push kid children)) | |
700 (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) | |
701 mh-thread-history) | |
702 (mh-thread-remove-parent-link node))) | |
703 ((mh-container-children node) | |
704 ;; Promote the first orphan to parent and add the other kids as | |
705 ;; his children | |
706 (setf (mh-container-children node) | |
707 (mh-thread-sort-containers (mh-container-children node))) | |
708 (let ((new-parent (car (mh-container-children node))) | |
709 (other-kids (cdr (mh-container-children node)))) | |
710 (mh-thread-remove-parent-link new-parent) | |
711 (dolist (kid other-kids) | |
712 (mh-thread-remove-parent-link kid) | |
713 (setf (mh-container-real-child-p kid) nil) | |
714 (mh-thread-add-link new-parent kid t)) | |
715 (push `(PROMOTE ,node ,(mh-container-parent node) | |
716 ,new-parent ,@other-kids) | |
717 mh-thread-history) | |
718 (mh-thread-remove-parent-link node))) | |
719 (t | |
720 ;; Drop it | |
721 (push `(DROP ,node ,(mh-container-parent node)) | |
722 mh-thread-history) | |
723 (mh-thread-remove-parent-link node))))) | |
724 (let ((results ())) | |
725 (maphash #'(lambda (k v) | |
726 (declare (ignore k)) | |
727 (when (and (null (mh-container-parent v)) | |
728 (gethash (mh-message-id (mh-container-message v)) | |
729 mh-thread-id-index-map)) | |
730 (push v results))) | |
731 mh-thread-id-table) | |
732 (mh-thread-sort-containers results)))) | |
733 | |
734 (defun mh-thread-sort-containers (containers) | |
735 "Sort a list of message CONTAINERS to be in ascending order wrt index." | |
736 (sort containers | |
737 #'(lambda (x y) | |
738 (when (and (mh-container-message x) (mh-container-message y)) | |
739 (let* ((id-x (mh-message-id (mh-container-message x))) | |
740 (id-y (mh-message-id (mh-container-message y))) | |
741 (index-x (gethash id-x mh-thread-id-index-map)) | |
742 (index-y (gethash id-y mh-thread-id-index-map))) | |
743 (and (integerp index-x) (integerp index-y) | |
744 (< index-x index-y))))))) | |
745 | |
746 (defvar mh-thread-last-ancestor) | |
747 | |
748 ;;;###mh-autoload | |
749 (defun mh-thread-print-scan-lines (thread-tree) | |
750 "Print scan lines in THREAD-TREE in threaded mode." | |
751 (let ((mh-thread-body-width (- (window-width) mh-cmd-note | |
752 (1- mh-scan-field-subject-start-offset))) | |
753 (mh-thread-last-ancestor nil)) | |
754 (if (null mh-index-data) | |
755 (mh-thread-generate-scan-lines thread-tree -2) | |
756 (loop for x in (mh-index-group-by-folder) | |
757 do (let* ((old-map mh-thread-scan-line-map) | |
758 (mh-thread-scan-line-map (make-hash-table))) | |
759 (setq mh-thread-last-ancestor nil) | |
760 (loop for msg in (cdr x) | |
761 do (let ((v (gethash msg old-map))) | |
762 (when v | |
763 (setf (gethash msg mh-thread-scan-line-map) v)))) | |
764 (when (> (hash-table-count mh-thread-scan-line-map) 0) | |
765 (insert (if (bobp) "" "\n") (car x) "\n") | |
766 (mh-thread-generate-scan-lines thread-tree -2)))) | |
767 (mh-index-create-imenu-index)))) | |
768 | |
769 (defun mh-thread-generate-scan-lines (tree level) | |
770 "Generate scan lines. | |
771 TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps | |
772 message indices to the corresponding scan lines and LEVEL used to | |
773 determine indentation of the message." | |
774 (cond ((null tree) nil) | |
775 ((mh-thread-container-p tree) | |
776 (let* ((message (mh-container-message tree)) | |
777 (id (mh-message-id message)) | |
778 (index (gethash id mh-thread-id-index-map)) | |
779 (duplicates (gethash id mh-thread-duplicates)) | |
780 (new-level (+ level 2)) | |
781 (dupl-flag t) | |
782 (force-angle-flag nil) | |
783 (increment-level-flag nil)) | |
784 (dolist (scan-line (mapcar (lambda (x) | |
785 (gethash x mh-thread-scan-line-map)) | |
786 (reverse (cons index duplicates)))) | |
787 (when scan-line | |
788 (when (and dupl-flag (equal level 0) | |
789 (mh-thread-ancestor-p mh-thread-last-ancestor tree)) | |
790 (setq level (+ level 2) | |
791 new-level (+ new-level 2) | |
792 force-angle-flag t)) | |
793 (when (equal level 0) | |
794 (setq mh-thread-last-ancestor tree) | |
795 (while (mh-container-parent mh-thread-last-ancestor) | |
796 (setq mh-thread-last-ancestor | |
797 (mh-container-parent mh-thread-last-ancestor)))) | |
798 (let* ((lev (if dupl-flag level new-level)) | |
799 (square-flag (or (and (mh-container-real-child-p tree) | |
800 (not force-angle-flag) | |
801 dupl-flag) | |
802 (equal lev 0)))) | |
803 (insert (car scan-line) | |
804 (format (format "%%%ss" lev) "") | |
805 (if square-flag "[" "<") | |
806 (cadr scan-line) | |
807 (if square-flag "]" ">") | |
808 (truncate-string-to-width | |
809 (caddr scan-line) (- mh-thread-body-width lev)) | |
810 "\n")) | |
811 (setq increment-level-flag t) | |
812 (setq dupl-flag nil))) | |
813 (unless increment-level-flag (setq new-level level)) | |
814 (dolist (child (mh-container-children tree)) | |
815 (mh-thread-generate-scan-lines child new-level)))) | |
816 (t (let ((nlevel (+ level 2))) | |
817 (dolist (ch tree) | |
818 (mh-thread-generate-scan-lines ch nlevel)))))) | |
819 | |
820 | |
821 | |
822 ;;; Additional Utilities | |
823 | |
824 ;;;###mh-autoload | |
825 (defun mh-thread-update-scan-line-map (msg notation offset) | |
826 "In threaded view update `mh-thread-scan-line-map'. | |
827 MSG is the message being notated with NOTATION at OFFSET." | |
828 (let* ((msg (or msg (mh-get-msg-num nil))) | |
829 (cur-scan-line (and mh-thread-scan-line-map | |
830 (gethash msg mh-thread-scan-line-map))) | |
831 (old-scan-lines (loop for map in mh-thread-scan-line-map-stack | |
832 collect (and map (gethash msg map))))) | |
833 (when cur-scan-line | |
834 (setf (aref (car cur-scan-line) offset) notation)) | |
835 (dolist (line old-scan-lines) | |
836 (when line (setf (aref (car line) offset) notation))))) | |
837 | |
838 ;;;###mh-autoload | |
839 (defun mh-thread-find-msg-subject (msg) | |
840 "Find canonicalized subject of MSG. | |
841 This function can only be used the folder is threaded." | |
842 (ignore-errors | |
843 (mh-message-subject | |
844 (mh-container-message (gethash (gethash msg mh-thread-index-id-map) | |
845 mh-thread-id-table))))) | |
846 | |
847 ;;;###mh-autoload | |
848 (defun mh-thread-add-spaces (count) | |
849 "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." | |
850 (let ((spaces (format (format "%%%ss" count) ""))) | |
851 (while (not (eobp)) | |
852 (let* ((msg-num (mh-get-msg-num nil)) | |
853 (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) | |
854 (when (numberp msg-num) | |
855 (setf (gethash msg-num mh-thread-scan-line-map) | |
856 (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) | |
857 (forward-line 1)))) | |
858 | |
859 ;;;###mh-autoload | |
860 (defun mh-thread-forget-message (index) | |
861 "Forget the message INDEX from the threading tables." | |
862 (let* ((id (gethash index mh-thread-index-id-map)) | |
863 (id-index (gethash id mh-thread-id-index-map)) | |
864 (duplicates (gethash id mh-thread-duplicates))) | |
865 (remhash index mh-thread-index-id-map) | |
866 (remhash index mh-thread-scan-line-map) | |
867 (cond ((and (eql index id-index) (null duplicates)) | |
868 (remhash id mh-thread-id-index-map)) | |
869 ((eql index id-index) | |
870 (setf (gethash id mh-thread-id-index-map) (car duplicates)) | |
871 (setf (gethash (car duplicates) mh-thread-index-id-map) id) | |
872 (setf (gethash id mh-thread-duplicates) (cdr duplicates))) | |
873 (t | |
874 (setf (gethash id mh-thread-duplicates) | |
875 (remove index duplicates)))))) | |
876 | |
877 (provide 'mh-thread) | |
878 | |
879 ;; Local Variables: | |
880 ;; indent-tabs-mode: nil | |
881 ;; sentence-end-double-space: nil | |
882 ;; End: | |
883 | |
68470 | 884 ;; arch-tag: b10e62f5-f028-4e04-873e-89d0e069b3d5 |
68465 | 885 ;;; mh-thread.el ends here |