|
0
|
1 ;;; Thread support for VM
|
|
|
2 ;;; Copyright (C) 1994 Kyle E. Jones
|
|
|
3 ;;;
|
|
|
4 ;;; This program is free software; you can redistribute it and/or modify
|
|
|
5 ;;; it under the terms of the GNU General Public License as published by
|
|
|
6 ;;; the Free Software Foundation; either version 1, or (at your option)
|
|
|
7 ;;; any later version.
|
|
|
8 ;;;
|
|
|
9 ;;; This program is distributed in the hope that it will be useful,
|
|
|
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
12 ;;; GNU General Public License for more details.
|
|
|
13 ;;;
|
|
|
14 ;;; You should have received a copy of the GNU General Public License
|
|
|
15 ;;; along with this program; if not, write to the Free Software
|
|
|
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
17
|
|
|
18 (provide 'vm-thread)
|
|
|
19
|
|
|
20 (defun vm-toggle-threads-display ()
|
|
|
21 "Toggle the threads display on and off.
|
|
|
22 When the threads display is on, the folder will be sorted by
|
|
|
23 thread and thread indentation (via the %I summary format specifier)
|
|
|
24 will be visible."
|
|
|
25 (interactive)
|
|
|
26 (vm-select-folder-buffer)
|
|
|
27 (vm-check-for-killed-summary)
|
|
|
28 (vm-set-summary-redo-start-point t)
|
|
|
29 (setq vm-summary-show-threads (not vm-summary-show-threads))
|
|
|
30 (if vm-summary-show-threads
|
|
|
31 (vm-sort-messages "thread")
|
|
|
32 (vm-sort-messages "physical-order")))
|
|
|
33
|
|
|
34 (defun vm-build-threads (message-list)
|
|
|
35 (if (null vm-thread-obarray)
|
|
|
36 (setq vm-thread-obarray (make-vector 641 0)
|
|
|
37 vm-thread-subject-obarray (make-vector 641 0)))
|
|
|
38 (let ((mp (or message-list vm-message-list))
|
|
|
39 (n 0)
|
|
|
40 ;; Just for laughs, make the update interval vary.
|
|
|
41 (modulus (+ (% (vm-abs (random)) 11) 40))
|
|
|
42 ;; no need to schedule reindents of reparented messages
|
|
|
43 ;; unless there were already messages present.
|
|
|
44 (schedule-reindents message-list)
|
|
140
|
45 m parent parent-sym id id-sym date refs old-parent-sym)
|
|
0
|
46 (while mp
|
|
140
|
47 (setq m (car mp)
|
|
|
48 parent (vm-th-parent m)
|
|
|
49 id (vm-su-message-id m)
|
|
0
|
50 id-sym (intern id vm-thread-obarray)
|
|
140
|
51 date (vm-so-sortable-datestring m))
|
|
|
52 (put id-sym 'messages (cons m (get id-sym 'messages)))
|
|
0
|
53 (if (and (null (cdr (get id-sym 'messages)))
|
|
|
54 schedule-reindents)
|
|
|
55 (vm-thread-mark-for-summary-update (get id-sym 'children)))
|
|
|
56 (if parent
|
|
|
57 (progn
|
|
|
58 (setq parent-sym (intern parent vm-thread-obarray))
|
|
114
|
59 (cond ((or (not (boundp id-sym))
|
|
|
60 (null (symbol-value id-sym))
|
|
|
61 (eq (symbol-value id-sym) parent-sym))
|
|
|
62 (set id-sym parent-sym))
|
|
|
63 (t
|
|
|
64 (setq old-parent-sym (symbol-value id-sym))
|
|
|
65 (put old-parent-sym 'children
|
|
|
66 (let ((kids (get old-parent-sym 'children))
|
|
|
67 (msgs (get id-sym 'messages)))
|
|
|
68 (while msgs
|
|
140
|
69 (setq kids (delq m kids)
|
|
114
|
70 msgs (cdr msgs)))
|
|
|
71 kids ))
|
|
|
72 (set id-sym parent-sym)
|
|
|
73 (if schedule-reindents
|
|
|
74 (vm-thread-mark-for-summary-update
|
|
|
75 (get id-sym 'messages)))))
|
|
0
|
76 (put parent-sym 'children
|
|
140
|
77 (cons m (get parent-sym 'children))))
|
|
114
|
78 (if (not (boundp id-sym))
|
|
|
79 (set id-sym nil)))
|
|
|
80 ;; use the references header to set parenting information
|
|
|
81 ;; for ancestors of this message. This does not override
|
|
|
82 ;; a parent pointer for a message if it already exists.
|
|
140
|
83 (if (cdr (setq refs (vm-th-references m)))
|
|
114
|
84 (let (parent-sym id-sym msgs)
|
|
|
85 (setq parent-sym (intern (car refs) vm-thread-obarray)
|
|
|
86 refs (cdr refs))
|
|
|
87 (while refs
|
|
|
88 (setq id-sym (intern (car refs) vm-thread-obarray))
|
|
|
89 (if (and (boundp id-sym) (symbol-value id-sym))
|
|
|
90 nil
|
|
|
91 (set id-sym parent-sym)
|
|
|
92 (if (setq msgs (get id-sym 'messages))
|
|
|
93 (put parent-sym 'children
|
|
|
94 (append msgs (get parent-sym 'children))))
|
|
|
95 (if schedule-reindents
|
|
|
96 (vm-thread-mark-for-summary-update msgs)))
|
|
|
97 (setq parent-sym id-sym
|
|
|
98 refs (cdr refs)))))
|
|
0
|
99 (if vm-thread-using-subject
|
|
114
|
100 ;; inhibit-quit because we need to make sure the asets
|
|
|
101 ;; below are an atomic group.
|
|
0
|
102 (let* ((inhibit-quit t)
|
|
140
|
103 (subject (vm-so-sortable-subject m))
|
|
0
|
104 (subject-sym (intern subject vm-thread-subject-obarray)))
|
|
114
|
105 ;; if this subject never seen before create the
|
|
|
106 ;; information vector.
|
|
0
|
107 (if (not (boundp subject-sym))
|
|
|
108 (set subject-sym
|
|
140
|
109 (vector id-sym (vm-so-sortable-datestring m)
|
|
|
110 nil (list m)))
|
|
114
|
111 ;; this subject seen before
|
|
0
|
112 (aset (symbol-value subject-sym) 3
|
|
140
|
113 (cons m (aref (symbol-value subject-sym) 3)))
|
|
0
|
114 (if (string< date (aref (symbol-value subject-sym) 1))
|
|
|
115 (let* ((vect (symbol-value subject-sym))
|
|
|
116 (i-sym (aref vect 0)))
|
|
114
|
117 ;; optimization: if we know that this message
|
|
|
118 ;; already has a parent, then don't bother
|
|
|
119 ;; adding it to the list of child messages
|
|
|
120 ;; since we know that it will be threaded and
|
|
|
121 ;; unthreaded using the parent information.
|
|
0
|
122 (if (or (not (boundp i-sym))
|
|
|
123 (null (symbol-value i-sym)))
|
|
|
124 (aset vect 2 (append (get i-sym 'messages)
|
|
|
125 (aref vect 2))))
|
|
|
126 (aset vect 0 id-sym)
|
|
|
127 (aset vect 1 date)
|
|
|
128 ;; this loops _and_ recurses and I'm worried
|
|
|
129 ;; about it going into a spin someday. So I
|
|
|
130 ;; unblock interrupts here. It's not critical
|
|
|
131 ;; that it finish... the summary will just be out
|
|
|
132 ;; of sync.
|
|
|
133 (if schedule-reindents
|
|
|
134 (let ((inhibit-quit nil))
|
|
|
135 (vm-thread-mark-for-summary-update (aref vect 2)))))
|
|
114
|
136 ;; optimization: if we know that this message
|
|
|
137 ;; already has a parent, then don't bother adding
|
|
|
138 ;; it to the list of child messages, since we
|
|
|
139 ;; know that it will be threaded and unthreaded
|
|
|
140 ;; using the parent information.
|
|
0
|
141 (if (null parent)
|
|
|
142 (aset (symbol-value subject-sym) 2
|
|
140
|
143 (cons m (aref (symbol-value subject-sym) 2))))))))
|
|
0
|
144 (setq mp (cdr mp) n (1+ n))
|
|
|
145 (if (zerop (% n modulus))
|
|
102
|
146 (message "Building threads... %d" n)))
|
|
0
|
147 (if (> n modulus)
|
|
102
|
148 (message "Building threads... done"))))
|
|
0
|
149
|
|
|
150 (defun vm-thread-mark-for-summary-update (message-list)
|
|
140
|
151 (let (m)
|
|
|
152 (while message-list
|
|
|
153 (setq m (car message-list))
|
|
|
154 ;; if thread-list is null then we've already marked this
|
|
|
155 ;; message, or it doesn't need marking.
|
|
|
156 (if (null (vm-thread-list-of m))
|
|
|
157 nil
|
|
|
158 (vm-mark-for-summary-update m t)
|
|
|
159 (vm-set-thread-list-of m nil)
|
|
|
160 (vm-set-thread-indentation-of m nil)
|
|
|
161 (vm-thread-mark-for-summary-update
|
|
|
162 (get (intern (vm-su-message-id m) vm-thread-obarray)
|
|
|
163 'children)))
|
|
|
164 (setq message-list (cdr message-list)))))
|
|
0
|
165
|
|
|
166 (defun vm-thread-list (message)
|
|
|
167 (let ((done nil)
|
|
|
168 (m message)
|
|
|
169 thread-list id-sym subject-sym loop-sym root-date)
|
|
|
170 (save-excursion
|
|
|
171 (set-buffer (vm-buffer-of m))
|
|
|
172 (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
|
|
|
173 thread-list (list id-sym))
|
|
|
174 (fillarray vm-thread-loop-obarray 0)
|
|
|
175 (while (not done)
|
|
|
176 (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
|
|
|
177 (if (boundp loop-sym)
|
|
|
178 ;; loop detected, bail...
|
|
98
|
179 (setq done t)
|
|
0
|
180 (set loop-sym t)
|
|
|
181 (if (and (boundp id-sym) (symbol-value id-sym))
|
|
|
182 (progn
|
|
|
183 (setq id-sym (symbol-value id-sym)
|
|
|
184 thread-list (cons id-sym thread-list)
|
|
|
185 m (car (get id-sym 'messages))))
|
|
|
186 (if (null m)
|
|
|
187 (setq done t)
|
|
|
188 (if (null vm-thread-using-subject)
|
|
|
189 nil
|
|
|
190 (setq subject-sym
|
|
|
191 (intern (vm-so-sortable-subject m)
|
|
|
192 vm-thread-subject-obarray))
|
|
|
193 (if (or (not (boundp subject-sym))
|
|
|
194 (eq (aref (symbol-value subject-sym) 0) id-sym))
|
|
|
195 (setq done t)
|
|
|
196 (setq id-sym (aref (symbol-value subject-sym) 0)
|
|
|
197 thread-list (cons id-sym thread-list)
|
|
|
198 m (car (get id-sym 'messages)))))))))
|
|
|
199 ;; save the date of the oldest message in this thread
|
|
|
200 (setq root-date (get id-sym 'oldest-date))
|
|
|
201 (if (or (null root-date)
|
|
|
202 (string< (vm-so-sortable-datestring message) root-date))
|
|
|
203 (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
|
|
|
204 thread-list )))
|
|
|
205
|
|
|
206 ;; remove message struct from thread data.
|
|
|
207 ;;
|
|
|
208 ;; optional second arg non-nil means forget information that
|
|
114
|
209 ;; might be different if the message contents changed.
|
|
0
|
210 ;;
|
|
114
|
211 ;; message must be a real (non-virtual) message
|
|
0
|
212 (defun vm-unthread-message (message &optional message-changing)
|
|
|
213 (save-excursion
|
|
|
214 (let ((mp (cons message (vm-virtual-messages-of message)))
|
|
140
|
215 m id-sym subject-sym vect p-sym)
|
|
0
|
216 (while mp
|
|
140
|
217 (setq m (car mp))
|
|
0
|
218 (let ((inhibit-quit t))
|
|
140
|
219 (vm-set-thread-list-of m nil)
|
|
|
220 (vm-set-thread-indentation-of m nil)
|
|
|
221 (set-buffer (vm-buffer-of m))
|
|
|
222 (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
|
|
|
223 subject-sym (intern (vm-so-sortable-subject m)
|
|
0
|
224 vm-thread-subject-obarray))
|
|
|
225 (if (boundp id-sym)
|
|
|
226 (progn
|
|
140
|
227 (put id-sym 'messages (delq m (get id-sym 'messages)))
|
|
0
|
228 (vm-thread-mark-for-summary-update (get id-sym 'children))
|
|
|
229 (setq p-sym (symbol-value id-sym))
|
|
|
230 (and p-sym (put p-sym 'children
|
|
140
|
231 (delq m (get p-sym 'children))))
|
|
0
|
232 (if message-changing
|
|
|
233 (set id-sym nil))))
|
|
|
234 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
|
|
|
235 (if (not (eq id-sym (aref vect 0)))
|
|
140
|
236 (aset vect 2 (delq m (aref vect 2)))
|
|
0
|
237 (if message-changing
|
|
|
238 (if (null (cdr (aref vect 3)))
|
|
|
239 (makunbound subject-sym)
|
|
|
240 (let ((p (aref vect 3))
|
|
|
241 oldest-msg oldest-date children)
|
|
|
242 (setq oldest-msg (car p)
|
|
|
243 oldest-date (vm-so-sortable-datestring (car p))
|
|
|
244 p (cdr p))
|
|
|
245 (while p
|
|
|
246 (if (and (string-lessp (vm-so-sortable-datestring (car p))
|
|
|
247 oldest-date)
|
|
140
|
248 (not (eq m (car p))))
|
|
0
|
249 (setq oldest-msg (car p)
|
|
|
250 oldest-date (vm-so-sortable-datestring (car p))))
|
|
|
251 (setq p (cdr p)))
|
|
|
252 (aset vect 0 (intern (vm-su-message-id oldest-msg)
|
|
|
253 vm-thread-obarray))
|
|
|
254 (aset vect 1 oldest-date)
|
|
|
255 (setq children (delq oldest-msg (aref vect 2)))
|
|
|
256 (aset vect 2 children)
|
|
140
|
257 (aset vect 3 (delq m (aref vect 3)))
|
|
0
|
258 ;; I'm not sure there aren't situations
|
|
|
259 ;; where this might loop forever.
|
|
|
260 (let ((inhibit-quit nil))
|
|
|
261 (vm-thread-mark-for-summary-update children))))))))
|
|
|
262 (setq mp (cdr mp))))))
|
|
|
263
|
|
114
|
264 (defun vm-th-references (m)
|
|
|
265 (or (vm-references-of m)
|
|
|
266 (vm-set-references-of
|
|
|
267 m
|
|
|
268 (let (references)
|
|
|
269 (setq references (vm-get-header-contents m "References:" " "))
|
|
|
270 (and references (vm-parse references "[^<]*\\(<[^>]+>\\)"))))))
|
|
|
271
|
|
0
|
272 (defun vm-th-parent (m)
|
|
|
273 (or (vm-parent-of m)
|
|
|
274 (vm-set-parent-of
|
|
|
275 m
|
|
114
|
276 (or (car (vm-last (vm-th-references m)))
|
|
0
|
277 (let (in-reply-to)
|
|
98
|
278 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " "))
|
|
0
|
279 (and in-reply-to
|
|
|
280 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
|
|
|
281
|
|
|
282 (defun vm-th-thread-indentation (m)
|
|
|
283 (or (vm-thread-indentation-of m)
|
|
|
284 (let ((p (vm-th-thread-list m)))
|
|
|
285 (while (and p (null (get (car p) 'messages)))
|
|
|
286 (setq p (cdr p)))
|
|
|
287 (vm-set-thread-indentation-of m (1- (length p)))
|
|
|
288 (vm-thread-indentation-of m))))
|
|
|
289
|
|
|
290 (defun vm-th-thread-list (m)
|
|
|
291 (or (vm-thread-list-of m)
|
|
|
292 (progn
|
|
|
293 (vm-set-thread-list-of m (vm-thread-list m))
|
|
|
294 (vm-thread-list-of m))))
|
