Mercurial > emacs
annotate lisp/mh-e/mh-thread.el @ 82603:d0c9cce4628c
* net/tramp.el (top): Require cl.el, when `copy-tree' is not available
otherwise.
(tramp-get-remote-path): New defun. Replace occurences of
`tramp-default-remote-path' by this function.
(tramp-set-remote-path): Move most of the code to
`tramp-get-remote-path'.
(tramp-get-ls-command, tramp-get-remote-id): Don't check for not
existing directories, this is done already in
`tramp-get-remote-path'.
author | Michael Albinus <michael.albinus@gmx.de> |
---|---|
date | Wed, 22 Aug 2007 05:47:42 +0000 |
parents | 800dd75c042b |
children | 3c2488d0ebd9 |
rev | line source |
---|---|
68465 | 1 ;;; mh-thread.el --- MH-E threading support |
2 | |
75347 | 3 ;; Copyright (C) 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. |
68465 | 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 | |
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 | |
78231
800dd75c042b
Switch license to GPLv3 or later.
Glenn Morris <rgm@gnu.org>
parents:
75347
diff
changeset
|
14 ;; the Free Software Foundation; either version 3, or (at your option) |
68465 | 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., 51 Franklin Street, Fifth Floor, | |
25 ;; Boston, MA 02110-1301, USA. | |
26 | |
27 ;;; Commentary: | |
28 | |
29 ;; The threading portion of this files tries to implement the | |
30 ;; algorithm described at: | |
31 ;; http://www.jwz.org/doc/threading.html | |
32 ;; It also begins to implement the IMAP Threading extension RFC. The | |
33 ;; implementation lacks the reference and subject canonicalization of | |
34 ;; the RFC. | |
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 | |
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 | |
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 | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
299 (point) (mh-line-end-position))) |
68465 | 300 0) |
301 (beginning-of-line) | |
302 (backward-char) | |
303 (return)) | |
304 (forward-line))) | |
305 (list begin (point))))) | |
306 | |
307 | |
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." | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
459 (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
|
460 (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
|
461 (mh-line-end-position)))) |
68465 | 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 | |
497 (cond ((equal subject "") (values subject subject-pruned-flag)) | |
498 (t (values | |
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 | |
68529
7daec5f4a289
* mh-alias.el (mh-alias-gecos-name): Use mh-replace-regexp-in-string
Bill Wohler <wohler@newt.com>
parents:
68470
diff
changeset
|
602 (prog1 (buffer-substring (point) (mh-line-end-position)) |
68465 | 603 (forward-line))) |
604 (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
|
605 (id (prog1 (buffer-substring (point) (mh-line-end-position)) |
68465 | 606 (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
|
607 (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
|
608 (buffer-substring (point) (mh-line-end-position)) |
68465 | 609 (forward-line))) |
610 (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
|
611 (mh-line-end-position)) |
68465 | 612 (forward-line))) |
613 (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
|
614 (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
|
615 (point) (mh-line-end-position)) |
68465 | 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) | |
622 (mh-thread-prune-subject subject)) | |
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." | |
650 (flet ((mh-get-table (symbol) | |
651 (save-excursion | |
652 (set-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)))) | |
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 | |
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 | |
68470 | 885 ;; arch-tag: b10e62f5-f028-4e04-873e-89d0e069b3d5 |
68465 | 886 ;;; mh-thread.el ends here |