1
;;; Thread support for VM
2
;;; Copyright (C) 1994, 2001 Kyle E. Jones
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)
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.
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.
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)
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")))
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))
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)
45
m parent parent-sym id id-sym date refs old-parent-sym)
48
parent (vm-th-parent m)
49
id (vm-su-message-id m)
50
id-sym (intern id vm-thread-obarray)
51
date (vm-so-sortable-datestring m))
52
(put id-sym 'messages (cons m (get id-sym 'messages)))
53
(if (and (null (cdr (get id-sym 'messages)))
55
(vm-thread-mark-for-summary-update (get id-sym 'children)))
58
(setq parent-sym (intern parent vm-thread-obarray))
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))
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)))
69
(setq kids (delq (car msgs) kids)
72
(set id-sym parent-sym)
73
(if schedule-reindents
74
(vm-thread-mark-for-summary-update
75
(get id-sym 'messages)))))
76
(put parent-sym 'children
77
(cons m (get parent-sym 'children))))
78
(if (not (boundp id-sym))
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.
83
(if (cdr (setq refs (vm-th-references m)))
84
(let (parent-sym id-sym msgs)
85
(setq parent-sym (intern (car refs) vm-thread-obarray)
88
(setq id-sym (intern (car refs) vm-thread-obarray))
89
(if (and (boundp id-sym) (symbol-value id-sym))
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
99
(setq mp (cdr mp) n (1+ n))
100
(if (zerop (% n modulus))
101
(message "Building threads (by reference)... %d" n)))
102
(if vm-thread-using-subject
104
(setq n 0 mp (or message-list vm-message-list))
107
parent (vm-th-parent m)
108
id (vm-su-message-id m)
109
id-sym (intern id vm-thread-obarray)
110
date (vm-so-sortable-datestring m))
111
;; inhibit-quit because we need to make sure the asets
112
;; below are an atomic group.
113
(let* ((inhibit-quit t)
114
(subject (vm-so-sortable-subject m))
115
(subject-sym (intern subject vm-thread-subject-obarray)))
116
;; if this subject was never seen before create the
117
;; information vector.
118
(if (not (boundp subject-sym))
120
(vector id-sym (vm-so-sortable-datestring m)
122
;; this subject seen before
123
(aset (symbol-value subject-sym) 3
124
(cons m (aref (symbol-value subject-sym) 3)))
125
(if (string< date (aref (symbol-value subject-sym) 1))
126
(let* ((vect (symbol-value subject-sym))
127
(i-sym (aref vect 0)))
128
;; optimization: if we know that this message
129
;; already has a parent, then don't bother
130
;; adding it to the list of child messages
131
;; since we know that it will be threaded and
132
;; unthreaded using the parent information.
133
(if (or (not (boundp i-sym))
134
(null (symbol-value i-sym)))
135
(aset vect 2 (append (get i-sym 'messages)
139
;; this loops _and_ recurses and I'm worried
140
;; about it going into a spin someday. So I
141
;; unblock interrupts here. It's not critical
142
;; that it finish... the summary will just be out
144
(if schedule-reindents
145
(let ((inhibit-quit nil))
146
(vm-thread-mark-for-summary-update (aref vect 2)))))
147
;; optimization: if we know that this message
148
;; already has a parent, then don't bother adding
149
;; it to the list of child messages, since we
150
;; know that it will be threaded and unthreaded
151
;; using the parent information.
153
(aset (symbol-value subject-sym) 2
154
(cons m (aref (symbol-value subject-sym) 2)))))))
155
(setq mp (cdr mp) n (1+ n))
156
(if (zerop (% n modulus))
157
(message "Building threads (by subject)... %d" n)))))
159
(message "Building threads... done"))))
161
;; used by the thread sort code.
163
;; vm-th-thread-list initializes the oldest-date property on
164
;; the message-id symbols. Since this property is used as an
165
;; ordering key by the thread sort the oldest-date properties
166
;; must be computed before the sort begins, not during it.
167
;; Otherwise the sort won't be stable and there will be chaos.
168
(defun vm-build-thread-lists ()
169
(let ((mp vm-message-list))
171
(vm-th-thread-list (car mp))
172
(setq mp (cdr mp)))))
174
(defun vm-thread-mark-for-summary-update (message-list)
177
(setq m (car message-list))
178
;; if thread-list is null then we've already marked this
179
;; message, or it doesn't need marking.
180
(if (null (vm-thread-list-of m))
182
(vm-mark-for-summary-update m t)
183
(vm-set-thread-list-of m nil)
184
(vm-set-thread-indentation-of m nil)
185
(vm-thread-mark-for-summary-update
186
(get (intern (vm-su-message-id m) vm-thread-obarray)
188
(setq message-list (cdr message-list)))))
190
(defun vm-thread-list (message)
193
(loop-recovery-point nil)
194
thread-list id-sym subject-sym loop-sym root-date)
196
(set-buffer (vm-buffer-of m))
197
(fillarray vm-thread-loop-obarray 0)
198
(setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
199
thread-list (list id-sym))
200
(set (intern (symbol-name id-sym) vm-thread-loop-obarray) t)
202
;; save the date of the oldest message in this thread
203
(setq root-date (get id-sym 'oldest-date))
204
(if (or (null root-date)
205
(string< (vm-so-sortable-datestring message) root-date))
206
(put id-sym 'oldest-date (vm-so-sortable-datestring message)))
207
(if (and (boundp id-sym) (symbol-value id-sym))
209
(setq id-sym (symbol-value id-sym)
210
loop-sym (intern (symbol-name id-sym)
211
vm-thread-loop-obarray))
212
(if (boundp loop-sym)
213
;; loop detected, bail...
215
thread-list (or loop-recovery-point thread-list))
217
(setq thread-list (cons id-sym thread-list)
218
m (car (get id-sym 'messages)))))
221
(if (null vm-thread-using-subject)
224
(intern (vm-so-sortable-subject m)
225
vm-thread-subject-obarray))
226
(if (or (not (boundp subject-sym))
227
(eq (aref (symbol-value subject-sym) 0) id-sym))
229
(setq id-sym (aref (symbol-value subject-sym) 0)
230
;; seems to cause more trouble than it fixes
231
;; revisit this later.
232
;; loop-recovery-point (or loop-recovery-point
234
loop-sym (intern (symbol-name id-sym)
235
vm-thread-loop-obarray))
236
(if (boundp loop-sym)
237
;; loop detected, bail...
239
thread-list (or loop-recovery-point thread-list))
241
(setq thread-list (cons id-sym thread-list)
242
m (car (get id-sym 'messages)))))))))
245
;; remove message struct from thread data.
247
;; optional second arg non-nil means forget information that
248
;; might be different if the message contents changed.
250
;; message must be a real (non-virtual) message
251
(defun vm-unthread-message (message &optional message-changing)
253
(let ((mp (cons message (vm-virtual-messages-of message)))
254
m id-sym subject-sym vect p-sym)
257
(let ((inhibit-quit t))
258
(vm-set-thread-list-of m nil)
259
(vm-set-thread-indentation-of m nil)
260
(set-buffer (vm-buffer-of m))
261
(setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
262
subject-sym (intern (vm-so-sortable-subject m)
263
vm-thread-subject-obarray))
266
(put id-sym 'messages (delq m (get id-sym 'messages)))
267
(vm-thread-mark-for-summary-update (get id-sym 'children))
268
(setq p-sym (symbol-value id-sym))
269
(and p-sym (put p-sym 'children
270
(delq m (get p-sym 'children))))
273
(if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
274
(if (not (eq id-sym (aref vect 0)))
275
(aset vect 2 (delq m (aref vect 2)))
277
(if (null (cdr (aref vect 3)))
278
(makunbound subject-sym)
279
(let ((p (aref vect 3))
280
oldest-msg oldest-date children)
281
(setq oldest-msg (car p)
282
oldest-date (vm-so-sortable-datestring (car p))
285
(if (and (string-lessp (vm-so-sortable-datestring (car p))
287
(not (eq m (car p))))
288
(setq oldest-msg (car p)
289
oldest-date (vm-so-sortable-datestring (car p))))
291
(aset vect 0 (intern (vm-su-message-id oldest-msg)
293
(aset vect 1 oldest-date)
294
(setq children (delq oldest-msg (aref vect 2)))
295
(aset vect 2 children)
296
(aset vect 3 (delq m (aref vect 3)))
297
;; I'm not sure there aren't situations
298
;; where this might loop forever.
299
(let ((inhibit-quit nil))
300
(vm-thread-mark-for-summary-update children))))))))
301
(setq mp (cdr mp))))))
303
(defun vm-th-references (m)
304
(or (vm-references-of m)
305
(vm-set-references-of
308
(setq references (vm-get-header-contents m "References:" " "))
309
(and references (vm-parse references "[^<]*\\(<[^>]+>\\)"))))))
311
(defun vm-th-parent (m)
315
(or (car (vm-last (vm-th-references m)))
316
(let (in-reply-to ids id)
317
(setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ")
318
ids (and in-reply-to (vm-parse in-reply-to
319
"[^<]*\\(<[^>]+>\\)")))
321
(if (< (length id) (length (car ids)))
323
(setq ids (cdr ids)))
324
(and id (vm-set-references-of m (list id)))
327
(defun vm-th-thread-indentation (m)
328
(or (vm-thread-indentation-of m)
329
(let ((p (vm-th-thread-list m)))
330
(while (and p (null (get (car p) 'messages)))
332
(vm-set-thread-indentation-of m (1- (length p)))
333
(vm-thread-indentation-of m))))
335
(defun vm-th-thread-list (m)
336
(or (vm-thread-list-of m)
338
(vm-set-thread-list-of m (vm-thread-list m))
339
(vm-thread-list-of m))))
added
removed
vm-thread.el
