|
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)
|
|
70
|
45 parent parent-sym id id-sym date)
|
|
0
|
46 (while mp
|
|
70
|
47 (setq parent (vm-th-parent (car mp))
|
|
|
48 id (vm-su-message-id (car mp))
|
|
0
|
49 id-sym (intern id vm-thread-obarray)
|
|
70
|
50 date (vm-so-sortable-datestring (car mp)))
|
|
|
51 (put id-sym 'messages (cons (car mp) (get id-sym 'messages)))
|
|
0
|
52 (if (and (null (cdr (get id-sym 'messages)))
|
|
|
53 schedule-reindents)
|
|
|
54 (vm-thread-mark-for-summary-update (get id-sym 'children)))
|
|
|
55 (if parent
|
|
|
56 (progn
|
|
|
57 (setq parent-sym (intern parent vm-thread-obarray))
|
|
70
|
58 (if (not (boundp id-sym))
|
|
|
59 (set id-sym parent-sym))
|
|
0
|
60 (put parent-sym 'children
|
|
70
|
61 (cons (car mp) (get parent-sym 'children))))
|
|
|
62 (set id-sym nil))
|
|
|
63 ;; we need to make sure the asets below are an atomic group.
|
|
0
|
64 (if vm-thread-using-subject
|
|
|
65 (let* ((inhibit-quit t)
|
|
70
|
66 (subject (vm-so-sortable-subject (car mp)))
|
|
0
|
67 (subject-sym (intern subject vm-thread-subject-obarray)))
|
|
|
68 (if (not (boundp subject-sym))
|
|
|
69 (set subject-sym
|
|
70
|
70 (vector id-sym (vm-so-sortable-datestring (car mp))
|
|
|
71 nil (list (car mp))))
|
|
0
|
72 (aset (symbol-value subject-sym) 3
|
|
70
|
73 (cons (car mp) (aref (symbol-value subject-sym) 3)))
|
|
0
|
74 (if (string< date (aref (symbol-value subject-sym) 1))
|
|
|
75 (let* ((vect (symbol-value subject-sym))
|
|
|
76 (i-sym (aref vect 0)))
|
|
|
77 (if (or (not (boundp i-sym))
|
|
|
78 (null (symbol-value i-sym)))
|
|
|
79 (aset vect 2 (append (get i-sym 'messages)
|
|
|
80 (aref vect 2))))
|
|
|
81 (aset vect 0 id-sym)
|
|
|
82 (aset vect 1 date)
|
|
|
83 ;; this loops _and_ recurses and I'm worried
|
|
|
84 ;; about it going into a spin someday. So I
|
|
|
85 ;; unblock interrupts here. It's not critical
|
|
|
86 ;; that it finish... the summary will just be out
|
|
|
87 ;; of sync.
|
|
|
88 (if schedule-reindents
|
|
|
89 (let ((inhibit-quit nil))
|
|
|
90 (vm-thread-mark-for-summary-update (aref vect 2)))))
|
|
|
91 (if (null parent)
|
|
|
92 (aset (symbol-value subject-sym) 2
|
|
70
|
93 (cons (car mp)
|
|
|
94 (aref (symbol-value subject-sym) 2))))))))
|
|
0
|
95 (setq mp (cdr mp) n (1+ n))
|
|
|
96 (if (zerop (% n modulus))
|
|
70
|
97 (vm-unsaved-message "Building threads... %d" n)))
|
|
0
|
98 (if (> n modulus)
|
|
70
|
99 (vm-unsaved-message "Building threads... done"))))
|
|
0
|
100
|
|
|
101 (defun vm-thread-mark-for-summary-update (message-list)
|
|
70
|
102 (while message-list
|
|
|
103 (vm-mark-for-summary-update (car message-list) t)
|
|
|
104 (vm-set-thread-list-of (car message-list) nil)
|
|
|
105 (vm-set-thread-indentation-of (car message-list) nil)
|
|
|
106 (vm-thread-mark-for-summary-update
|
|
|
107 (get (intern (vm-su-message-id (car message-list))
|
|
|
108 vm-thread-obarray)
|
|
|
109 'children))
|
|
|
110 (setq message-list (cdr message-list))))
|
|
0
|
111
|
|
|
112 (defun vm-thread-list (message)
|
|
|
113 (let ((done nil)
|
|
|
114 (m message)
|
|
|
115 thread-list id-sym subject-sym loop-sym root-date)
|
|
|
116 (save-excursion
|
|
|
117 (set-buffer (vm-buffer-of m))
|
|
|
118 (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
|
|
|
119 thread-list (list id-sym))
|
|
|
120 (fillarray vm-thread-loop-obarray 0)
|
|
|
121 (while (not done)
|
|
|
122 (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
|
|
|
123 (if (boundp loop-sym)
|
|
|
124 ;; loop detected, bail...
|
|
98
|
125 (setq done t)
|
|
0
|
126 (set loop-sym t)
|
|
|
127 (if (and (boundp id-sym) (symbol-value id-sym))
|
|
|
128 (progn
|
|
|
129 (setq id-sym (symbol-value id-sym)
|
|
|
130 thread-list (cons id-sym thread-list)
|
|
|
131 m (car (get id-sym 'messages))))
|
|
|
132 (if (null m)
|
|
|
133 (setq done t)
|
|
|
134 (if (null vm-thread-using-subject)
|
|
|
135 nil
|
|
|
136 (setq subject-sym
|
|
|
137 (intern (vm-so-sortable-subject m)
|
|
|
138 vm-thread-subject-obarray))
|
|
|
139 (if (or (not (boundp subject-sym))
|
|
|
140 (eq (aref (symbol-value subject-sym) 0) id-sym))
|
|
|
141 (setq done t)
|
|
|
142 (setq id-sym (aref (symbol-value subject-sym) 0)
|
|
|
143 thread-list (cons id-sym thread-list)
|
|
|
144 m (car (get id-sym 'messages)))))))))
|
|
|
145 ;; save the date of the oldest message in this thread
|
|
|
146 (setq root-date (get id-sym 'oldest-date))
|
|
|
147 (if (or (null root-date)
|
|
|
148 (string< (vm-so-sortable-datestring message) root-date))
|
|
|
149 (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
|
|
|
150 thread-list )))
|
|
|
151
|
|
|
152 ;; remove message struct from thread data.
|
|
|
153 ;;
|
|
|
154 ;; optional second arg non-nil means forget information that
|
|
70
|
155 ;; might be different if the mesage contents changed.
|
|
0
|
156 ;;
|
|
70
|
157 ;; message must be a real message
|
|
0
|
158 (defun vm-unthread-message (message &optional message-changing)
|
|
|
159 (save-excursion
|
|
|
160 (let ((mp (cons message (vm-virtual-messages-of message)))
|
|
70
|
161 id-sym subject-sym vect p-sym)
|
|
0
|
162 (while mp
|
|
|
163 (let ((inhibit-quit t))
|
|
70
|
164 (vm-set-thread-list-of (car mp) nil)
|
|
|
165 (vm-set-thread-indentation-of (car mp) nil)
|
|
|
166 (set-buffer (vm-buffer-of (car mp)))
|
|
|
167 (setq id-sym (intern (vm-su-message-id (car mp)) vm-thread-obarray)
|
|
|
168 subject-sym (intern (vm-so-sortable-subject (car mp))
|
|
0
|
169 vm-thread-subject-obarray))
|
|
|
170 (if (boundp id-sym)
|
|
|
171 (progn
|
|
70
|
172 (put id-sym 'messages (delq (car mp) (get id-sym 'messages)))
|
|
0
|
173 (vm-thread-mark-for-summary-update (get id-sym 'children))
|
|
|
174 (setq p-sym (symbol-value id-sym))
|
|
|
175 (and p-sym (put p-sym 'children
|
|
70
|
176 (delq (car mp) (get p-sym 'children))))
|
|
0
|
177 (if message-changing
|
|
|
178 (set id-sym nil))))
|
|
|
179 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
|
|
|
180 (if (not (eq id-sym (aref vect 0)))
|
|
70
|
181 (aset vect 2 (delq (car mp) (aref vect 2)))
|
|
0
|
182 (if message-changing
|
|
|
183 (if (null (cdr (aref vect 3)))
|
|
|
184 (makunbound subject-sym)
|
|
|
185 (let ((p (aref vect 3))
|
|
|
186 oldest-msg oldest-date children)
|
|
|
187 (setq oldest-msg (car p)
|
|
|
188 oldest-date (vm-so-sortable-datestring (car p))
|
|
|
189 p (cdr p))
|
|
|
190 (while p
|
|
|
191 (if (and (string-lessp (vm-so-sortable-datestring (car p))
|
|
|
192 oldest-date)
|
|
70
|
193 (not (eq (car mp) (car p))))
|
|
0
|
194 (setq oldest-msg (car p)
|
|
|
195 oldest-date (vm-so-sortable-datestring (car p))))
|
|
|
196 (setq p (cdr p)))
|
|
|
197 (aset vect 0 (intern (vm-su-message-id oldest-msg)
|
|
|
198 vm-thread-obarray))
|
|
|
199 (aset vect 1 oldest-date)
|
|
|
200 (setq children (delq oldest-msg (aref vect 2)))
|
|
|
201 (aset vect 2 children)
|
|
70
|
202 (aset vect 3 (delq (car mp) (aref vect 3)))
|
|
0
|
203 ;; I'm not sure there aren't situations
|
|
|
204 ;; where this might loop forever.
|
|
|
205 (let ((inhibit-quit nil))
|
|
|
206 (vm-thread-mark-for-summary-update children))))))))
|
|
|
207 (setq mp (cdr mp))))))
|
|
|
208
|
|
|
209 (defun vm-th-parent (m)
|
|
|
210 (or (vm-parent-of m)
|
|
|
211 (vm-set-parent-of
|
|
|
212 m
|
|
70
|
213 (or (let (references)
|
|
98
|
214 (setq references (vm-get-header-contents m "References:" " "))
|
|
70
|
215 (and references
|
|
|
216 (car (vm-last
|
|
|
217 (vm-parse references "[^<]*\\(<[^>]+>\\)")))))
|
|
0
|
218 (let (in-reply-to)
|
|
98
|
219 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " "))
|
|
0
|
220 (and in-reply-to
|
|
|
221 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
|
|
|
222
|
|
|
223 (defun vm-th-thread-indentation (m)
|
|
|
224 (or (vm-thread-indentation-of m)
|
|
|
225 (let ((p (vm-th-thread-list m)))
|
|
|
226 (while (and p (null (get (car p) 'messages)))
|
|
|
227 (setq p (cdr p)))
|
|
|
228 (vm-set-thread-indentation-of m (1- (length p)))
|
|
|
229 (vm-thread-indentation-of m))))
|
|
|
230
|
|
|
231 (defun vm-th-thread-list (m)
|
|
|
232 (or (vm-thread-list-of m)
|
|
|
233 (progn
|
|
|
234 (vm-set-thread-list-of m (vm-thread-list m))
|
|
|
235 (vm-thread-list-of m))))
|
