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