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