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