Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-thread.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 05472e90ae02
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
40 ;; Just for laughs, make the update interval vary. 40 ;; Just for laughs, make the update interval vary.
41 (modulus (+ (% (vm-abs (random)) 11) 40)) 41 (modulus (+ (% (vm-abs (random)) 11) 40))
42 ;; no need to schedule reindents of reparented messages 42 ;; no need to schedule reindents of reparented messages
43 ;; unless there were already messages present. 43 ;; unless there were already messages present.
44 (schedule-reindents message-list) 44 (schedule-reindents message-list)
45 m parent parent-sym id id-sym date refs old-parent-sym) 45 parent parent-sym id id-sym date)
46 (while mp 46 (while mp
47 (setq m (car mp) 47 (setq parent (vm-th-parent (car mp))
48 parent (vm-th-parent m) 48 id (vm-su-message-id (car mp))
49 id (vm-su-message-id m)
50 id-sym (intern id vm-thread-obarray) 49 id-sym (intern id vm-thread-obarray)
51 date (vm-so-sortable-datestring m)) 50 date (vm-so-sortable-datestring (car mp)))
52 (put id-sym 'messages (cons m (get id-sym 'messages))) 51 (put id-sym 'messages (cons (car mp) (get id-sym 'messages)))
53 (if (and (null (cdr (get id-sym 'messages))) 52 (if (and (null (cdr (get id-sym 'messages)))
54 schedule-reindents) 53 schedule-reindents)
55 (vm-thread-mark-for-summary-update (get id-sym 'children))) 54 (vm-thread-mark-for-summary-update (get id-sym 'children)))
56 (if parent 55 (if parent
57 (progn 56 (progn
58 (setq parent-sym (intern parent vm-thread-obarray)) 57 (setq parent-sym (intern parent vm-thread-obarray))
59 (cond ((or (not (boundp id-sym)) 58 (if (not (boundp id-sym))
60 (null (symbol-value id-sym)) 59 (set id-sym parent-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
69 (setq kids (delq m kids)
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)))))
76 (put parent-sym 'children 60 (put parent-sym 'children
77 (cons m (get parent-sym 'children)))) 61 (cons (car mp) (get parent-sym 'children))))
78 (if (not (boundp id-sym)) 62 (set id-sym nil))
79 (set id-sym nil))) 63 ;; we need to make sure the asets below are an atomic group.
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)
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)))))
99 (if vm-thread-using-subject 64 (if vm-thread-using-subject
100 ;; inhibit-quit because we need to make sure the asets
101 ;; below are an atomic group.
102 (let* ((inhibit-quit t) 65 (let* ((inhibit-quit t)
103 (subject (vm-so-sortable-subject m)) 66 (subject (vm-so-sortable-subject (car mp)))
104 (subject-sym (intern subject vm-thread-subject-obarray))) 67 (subject-sym (intern subject vm-thread-subject-obarray)))
105 ;; if this subject never seen before create the
106 ;; information vector.
107 (if (not (boundp subject-sym)) 68 (if (not (boundp subject-sym))
108 (set subject-sym 69 (set subject-sym
109 (vector id-sym (vm-so-sortable-datestring m) 70 (vector id-sym (vm-so-sortable-datestring (car mp))
110 nil (list m))) 71 nil (list (car mp))))
111 ;; this subject seen before
112 (aset (symbol-value subject-sym) 3 72 (aset (symbol-value subject-sym) 3
113 (cons m (aref (symbol-value subject-sym) 3))) 73 (cons (car mp) (aref (symbol-value subject-sym) 3)))
114 (if (string< date (aref (symbol-value subject-sym) 1)) 74 (if (string< date (aref (symbol-value subject-sym) 1))
115 (let* ((vect (symbol-value subject-sym)) 75 (let* ((vect (symbol-value subject-sym))
116 (i-sym (aref vect 0))) 76 (i-sym (aref vect 0)))
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.
122 (if (or (not (boundp i-sym)) 77 (if (or (not (boundp i-sym))
123 (null (symbol-value i-sym))) 78 (null (symbol-value i-sym)))
124 (aset vect 2 (append (get i-sym 'messages) 79 (aset vect 2 (append (get i-sym 'messages)
125 (aref vect 2)))) 80 (aref vect 2))))
126 (aset vect 0 id-sym) 81 (aset vect 0 id-sym)
131 ;; that it finish... the summary will just be out 86 ;; that it finish... the summary will just be out
132 ;; of sync. 87 ;; of sync.
133 (if schedule-reindents 88 (if schedule-reindents
134 (let ((inhibit-quit nil)) 89 (let ((inhibit-quit nil))
135 (vm-thread-mark-for-summary-update (aref vect 2))))) 90 (vm-thread-mark-for-summary-update (aref vect 2)))))
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.
141 (if (null parent) 91 (if (null parent)
142 (aset (symbol-value subject-sym) 2 92 (aset (symbol-value subject-sym) 2
143 (cons m (aref (symbol-value subject-sym) 2)))))))) 93 (cons (car mp)
94 (aref (symbol-value subject-sym) 2))))))))
144 (setq mp (cdr mp) n (1+ n)) 95 (setq mp (cdr mp) n (1+ n))
145 (if (zerop (% n modulus)) 96 (if (zerop (% n modulus))
146 (message "Building threads... %d" n))) 97 (vm-unsaved-message "Building threads... %d" n)))
147 (if (> n modulus) 98 (if (> n modulus)
148 (message "Building threads... done")))) 99 (vm-unsaved-message "Building threads... done"))))
149 100
150 (defun vm-thread-mark-for-summary-update (message-list) 101 (defun vm-thread-mark-for-summary-update (message-list)
151 (let (m) 102 (while message-list
152 (while message-list 103 (vm-mark-for-summary-update (car message-list) t)
153 (setq m (car message-list)) 104 (vm-set-thread-list-of (car message-list) nil)
154 ;; if thread-list is null then we've already marked this 105 (vm-set-thread-indentation-of (car message-list) nil)
155 ;; message, or it doesn't need marking. 106 (vm-thread-mark-for-summary-update
156 (if (null (vm-thread-list-of m)) 107 (get (intern (vm-su-message-id (car message-list))
157 nil 108 vm-thread-obarray)
158 (vm-mark-for-summary-update m t) 109 'children))
159 (vm-set-thread-list-of m nil) 110 (setq message-list (cdr message-list))))
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)))))
165 111
166 (defun vm-thread-list (message) 112 (defun vm-thread-list (message)
167 (let ((done nil) 113 (let ((done nil)
168 (m message) 114 (m message)
169 thread-list id-sym subject-sym loop-sym root-date) 115 thread-list id-sym subject-sym loop-sym root-date)
174 (fillarray vm-thread-loop-obarray 0) 120 (fillarray vm-thread-loop-obarray 0)
175 (while (not done) 121 (while (not done)
176 (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) 122 (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray))
177 (if (boundp loop-sym) 123 (if (boundp loop-sym)
178 ;; loop detected, bail... 124 ;; loop detected, bail...
179 (setq done t) 125 (setq done t
126 thread-list (cdr thread-list))
180 (set loop-sym t) 127 (set loop-sym t)
181 (if (and (boundp id-sym) (symbol-value id-sym)) 128 (if (and (boundp id-sym) (symbol-value id-sym))
182 (progn 129 (progn
183 (setq id-sym (symbol-value id-sym) 130 (setq id-sym (symbol-value id-sym)
184 thread-list (cons id-sym thread-list) 131 thread-list (cons id-sym thread-list)
204 thread-list ))) 151 thread-list )))
205 152
206 ;; remove message struct from thread data. 153 ;; remove message struct from thread data.
207 ;; 154 ;;
208 ;; optional second arg non-nil means forget information that 155 ;; optional second arg non-nil means forget information that
209 ;; might be different if the message contents changed. 156 ;; might be different if the mesage contents changed.
210 ;; 157 ;;
211 ;; message must be a real (non-virtual) message 158 ;; message must be a real message
212 (defun vm-unthread-message (message &optional message-changing) 159 (defun vm-unthread-message (message &optional message-changing)
213 (save-excursion 160 (save-excursion
214 (let ((mp (cons message (vm-virtual-messages-of message))) 161 (let ((mp (cons message (vm-virtual-messages-of message)))
215 m id-sym subject-sym vect p-sym) 162 id-sym subject-sym vect p-sym)
216 (while mp 163 (while mp
217 (setq m (car mp))
218 (let ((inhibit-quit t)) 164 (let ((inhibit-quit t))
219 (vm-set-thread-list-of m nil) 165 (vm-set-thread-list-of (car mp) nil)
220 (vm-set-thread-indentation-of m nil) 166 (vm-set-thread-indentation-of (car mp) nil)
221 (set-buffer (vm-buffer-of m)) 167 (set-buffer (vm-buffer-of (car mp)))
222 (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray) 168 (setq id-sym (intern (vm-su-message-id (car mp)) vm-thread-obarray)
223 subject-sym (intern (vm-so-sortable-subject m) 169 subject-sym (intern (vm-so-sortable-subject (car mp))
224 vm-thread-subject-obarray)) 170 vm-thread-subject-obarray))
225 (if (boundp id-sym) 171 (if (boundp id-sym)
226 (progn 172 (progn
227 (put id-sym 'messages (delq m (get id-sym 'messages))) 173 (put id-sym 'messages (delq (car mp) (get id-sym 'messages)))
228 (vm-thread-mark-for-summary-update (get id-sym 'children)) 174 (vm-thread-mark-for-summary-update (get id-sym 'children))
229 (setq p-sym (symbol-value id-sym)) 175 (setq p-sym (symbol-value id-sym))
230 (and p-sym (put p-sym 'children 176 (and p-sym (put p-sym 'children
231 (delq m (get p-sym 'children)))) 177 (delq (car mp) (get p-sym 'children))))
232 (if message-changing 178 (if message-changing
233 (set id-sym nil)))) 179 (set id-sym nil))))
234 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym))) 180 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
235 (if (not (eq id-sym (aref vect 0))) 181 (if (not (eq id-sym (aref vect 0)))
236 (aset vect 2 (delq m (aref vect 2))) 182 (aset vect 2 (delq (car mp) (aref vect 2)))
237 (if message-changing 183 (if message-changing
238 (if (null (cdr (aref vect 3))) 184 (if (null (cdr (aref vect 3)))
239 (makunbound subject-sym) 185 (makunbound subject-sym)
240 (let ((p (aref vect 3)) 186 (let ((p (aref vect 3))
241 oldest-msg oldest-date children) 187 oldest-msg oldest-date children)
243 oldest-date (vm-so-sortable-datestring (car p)) 189 oldest-date (vm-so-sortable-datestring (car p))
244 p (cdr p)) 190 p (cdr p))
245 (while p 191 (while p
246 (if (and (string-lessp (vm-so-sortable-datestring (car p)) 192 (if (and (string-lessp (vm-so-sortable-datestring (car p))
247 oldest-date) 193 oldest-date)
248 (not (eq m (car p)))) 194 (not (eq (car mp) (car p))))
249 (setq oldest-msg (car p) 195 (setq oldest-msg (car p)
250 oldest-date (vm-so-sortable-datestring (car p)))) 196 oldest-date (vm-so-sortable-datestring (car p))))
251 (setq p (cdr p))) 197 (setq p (cdr p)))
252 (aset vect 0 (intern (vm-su-message-id oldest-msg) 198 (aset vect 0 (intern (vm-su-message-id oldest-msg)
253 vm-thread-obarray)) 199 vm-thread-obarray))
254 (aset vect 1 oldest-date) 200 (aset vect 1 oldest-date)
255 (setq children (delq oldest-msg (aref vect 2))) 201 (setq children (delq oldest-msg (aref vect 2)))
256 (aset vect 2 children) 202 (aset vect 2 children)
257 (aset vect 3 (delq m (aref vect 3))) 203 (aset vect 3 (delq (car mp) (aref vect 3)))
258 ;; I'm not sure there aren't situations 204 ;; I'm not sure there aren't situations
259 ;; where this might loop forever. 205 ;; where this might loop forever.
260 (let ((inhibit-quit nil)) 206 (let ((inhibit-quit nil))
261 (vm-thread-mark-for-summary-update children)))))))) 207 (vm-thread-mark-for-summary-update children))))))))
262 (setq mp (cdr mp)))))) 208 (setq mp (cdr mp))))))
263 209
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
272 (defun vm-th-parent (m) 210 (defun vm-th-parent (m)
273 (or (vm-parent-of m) 211 (or (vm-parent-of m)
274 (vm-set-parent-of 212 (vm-set-parent-of
275 m 213 m
276 (or (car (vm-last (vm-th-references m))) 214 (or (let (references)
215 (setq references (vm-get-header-contents m "References:"))
216 (and references
217 (car (vm-last
218 (vm-parse references "[^<]*\\(<[^>]+>\\)")))))
277 (let (in-reply-to) 219 (let (in-reply-to)
278 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ")) 220 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:"))
279 (and in-reply-to 221 (and in-reply-to
280 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)")))))))) 222 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
281 223
282 (defun vm-th-thread-indentation (m) 224 (defun vm-th-thread-indentation (m)
283 (or (vm-thread-indentation-of m) 225 (or (vm-thread-indentation-of m)