Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-thread.el @ 54:05472e90ae02 r19-16-pre2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-16-pre2
author cvs
date Mon, 13 Aug 2007 08:57:55 +0200
parents c53a95d3c46d
children 131b0175ea99
comparison
equal deleted inserted replaced
53:875393c1a535 54:05472e90ae02
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 parent parent-sym id id-sym date refs old-parent-sym) 45 m parent parent-sym id id-sym date refs old-parent-sym)
46 (while mp 46 (while mp
47 (setq parent (vm-th-parent (car mp)) 47 (setq m (car mp)
48 id (vm-su-message-id (car mp)) 48 parent (vm-th-parent m)
49 id (vm-su-message-id m)
49 id-sym (intern id vm-thread-obarray) 50 id-sym (intern id vm-thread-obarray)
50 date (vm-so-sortable-datestring (car mp))) 51 date (vm-so-sortable-datestring m))
51 (put id-sym 'messages (cons (car mp) (get id-sym 'messages))) 52 (put id-sym 'messages (cons m (get id-sym 'messages)))
52 (if (and (null (cdr (get id-sym 'messages))) 53 (if (and (null (cdr (get id-sym 'messages)))
53 schedule-reindents) 54 schedule-reindents)
54 (vm-thread-mark-for-summary-update (get id-sym 'children))) 55 (vm-thread-mark-for-summary-update (get id-sym 'children)))
55 (if parent 56 (if parent
56 (progn 57 (progn
63 (setq old-parent-sym (symbol-value id-sym)) 64 (setq old-parent-sym (symbol-value id-sym))
64 (put old-parent-sym 'children 65 (put old-parent-sym 'children
65 (let ((kids (get old-parent-sym 'children)) 66 (let ((kids (get old-parent-sym 'children))
66 (msgs (get id-sym 'messages))) 67 (msgs (get id-sym 'messages)))
67 (while msgs 68 (while msgs
68 (setq kids (delq (car msgs) kids) 69 (setq kids (delq m kids)
69 msgs (cdr msgs))) 70 msgs (cdr msgs)))
70 kids )) 71 kids ))
71 (set id-sym parent-sym) 72 (set id-sym parent-sym)
72 (if schedule-reindents 73 (if schedule-reindents
73 (vm-thread-mark-for-summary-update 74 (vm-thread-mark-for-summary-update
74 (get id-sym 'messages))))) 75 (get id-sym 'messages)))))
75 (put parent-sym 'children 76 (put parent-sym 'children
76 (cons (car mp) (get parent-sym 'children)))) 77 (cons m (get parent-sym 'children))))
77 (if (not (boundp id-sym)) 78 (if (not (boundp id-sym))
78 (set id-sym nil))) 79 (set id-sym nil)))
79 ;; use the references header to set parenting information 80 ;; use the references header to set parenting information
80 ;; for ancestors of this message. This does not override 81 ;; for ancestors of this message. This does not override
81 ;; a parent pointer for a message if it already exists. 82 ;; a parent pointer for a message if it already exists.
82 (if (cdr (setq refs (vm-th-references (car mp)))) 83 (if (cdr (setq refs (vm-th-references m)))
83 (let (parent-sym id-sym msgs) 84 (let (parent-sym id-sym msgs)
84 (setq parent-sym (intern (car refs) vm-thread-obarray) 85 (setq parent-sym (intern (car refs) vm-thread-obarray)
85 refs (cdr refs)) 86 refs (cdr refs))
86 (while refs 87 (while refs
87 (setq id-sym (intern (car refs) vm-thread-obarray)) 88 (setq id-sym (intern (car refs) vm-thread-obarray))
97 refs (cdr refs))))) 98 refs (cdr refs)))))
98 (if vm-thread-using-subject 99 (if vm-thread-using-subject
99 ;; inhibit-quit because we need to make sure the asets 100 ;; inhibit-quit because we need to make sure the asets
100 ;; below are an atomic group. 101 ;; below are an atomic group.
101 (let* ((inhibit-quit t) 102 (let* ((inhibit-quit t)
102 (subject (vm-so-sortable-subject (car mp))) 103 (subject (vm-so-sortable-subject m))
103 (subject-sym (intern subject vm-thread-subject-obarray))) 104 (subject-sym (intern subject vm-thread-subject-obarray)))
104 ;; if this subject never seen before create the 105 ;; if this subject never seen before create the
105 ;; information vector. 106 ;; information vector.
106 (if (not (boundp subject-sym)) 107 (if (not (boundp subject-sym))
107 (set subject-sym 108 (set subject-sym
108 (vector id-sym (vm-so-sortable-datestring (car mp)) 109 (vector id-sym (vm-so-sortable-datestring m)
109 nil (list (car mp)))) 110 nil (list m)))
110 ;; this subject seen before 111 ;; this subject seen before
111 (aset (symbol-value subject-sym) 3 112 (aset (symbol-value subject-sym) 3
112 (cons (car mp) (aref (symbol-value subject-sym) 3))) 113 (cons m (aref (symbol-value subject-sym) 3)))
113 (if (string< date (aref (symbol-value subject-sym) 1)) 114 (if (string< date (aref (symbol-value subject-sym) 1))
114 (let* ((vect (symbol-value subject-sym)) 115 (let* ((vect (symbol-value subject-sym))
115 (i-sym (aref vect 0))) 116 (i-sym (aref vect 0)))
116 ;; optimization: if we know that this message 117 ;; optimization: if we know that this message
117 ;; already has a parent, then don't bother 118 ;; already has a parent, then don't bother
137 ;; it to the list of child messages, since we 138 ;; it to the list of child messages, since we
138 ;; know that it will be threaded and unthreaded 139 ;; know that it will be threaded and unthreaded
139 ;; using the parent information. 140 ;; using the parent information.
140 (if (null parent) 141 (if (null parent)
141 (aset (symbol-value subject-sym) 2 142 (aset (symbol-value subject-sym) 2
142 (cons (car mp) 143 (cons m (aref (symbol-value subject-sym) 2))))))))
143 (aref (symbol-value subject-sym) 2))))))))
144 (setq mp (cdr mp) n (1+ n)) 144 (setq mp (cdr mp) n (1+ n))
145 (if (zerop (% n modulus)) 145 (if (zerop (% n modulus))
146 (message "Building threads... %d" n))) 146 (message "Building threads... %d" n)))
147 (if (> n modulus) 147 (if (> n modulus)
148 (message "Building threads... done")))) 148 (message "Building threads... done"))))
149 149
150 (defun vm-thread-mark-for-summary-update (message-list) 150 (defun vm-thread-mark-for-summary-update (message-list)
151 (while message-list 151 (let (m)
152 (vm-mark-for-summary-update (car message-list) t) 152 (while message-list
153 (vm-set-thread-list-of (car message-list) nil) 153 (setq m (car message-list))
154 (vm-set-thread-indentation-of (car message-list) nil) 154 ;; if thread-list is null then we've already marked this
155 (vm-thread-mark-for-summary-update 155 ;; message, or it doesn't need marking.
156 (get (intern (vm-su-message-id (car message-list)) 156 (if (null (vm-thread-list-of m))
157 vm-thread-obarray) 157 nil
158 'children)) 158 (vm-mark-for-summary-update m t)
159 (setq message-list (cdr message-list)))) 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)))))
160 165
161 (defun vm-thread-list (message) 166 (defun vm-thread-list (message)
162 (let ((done nil) 167 (let ((done nil)
163 (m message) 168 (m message)
164 thread-list id-sym subject-sym loop-sym root-date) 169 thread-list id-sym subject-sym loop-sym root-date)
205 ;; 210 ;;
206 ;; message must be a real (non-virtual) message 211 ;; message must be a real (non-virtual) message
207 (defun vm-unthread-message (message &optional message-changing) 212 (defun vm-unthread-message (message &optional message-changing)
208 (save-excursion 213 (save-excursion
209 (let ((mp (cons message (vm-virtual-messages-of message))) 214 (let ((mp (cons message (vm-virtual-messages-of message)))
210 id-sym subject-sym vect p-sym) 215 m id-sym subject-sym vect p-sym)
211 (while mp 216 (while mp
217 (setq m (car mp))
212 (let ((inhibit-quit t)) 218 (let ((inhibit-quit t))
213 (vm-set-thread-list-of (car mp) nil) 219 (vm-set-thread-list-of m nil)
214 (vm-set-thread-indentation-of (car mp) nil) 220 (vm-set-thread-indentation-of m nil)
215 (set-buffer (vm-buffer-of (car mp))) 221 (set-buffer (vm-buffer-of m))
216 (setq id-sym (intern (vm-su-message-id (car mp)) vm-thread-obarray) 222 (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray)
217 subject-sym (intern (vm-so-sortable-subject (car mp)) 223 subject-sym (intern (vm-so-sortable-subject m)
218 vm-thread-subject-obarray)) 224 vm-thread-subject-obarray))
219 (if (boundp id-sym) 225 (if (boundp id-sym)
220 (progn 226 (progn
221 (put id-sym 'messages (delq (car mp) (get id-sym 'messages))) 227 (put id-sym 'messages (delq m (get id-sym 'messages)))
222 (vm-thread-mark-for-summary-update (get id-sym 'children)) 228 (vm-thread-mark-for-summary-update (get id-sym 'children))
223 (setq p-sym (symbol-value id-sym)) 229 (setq p-sym (symbol-value id-sym))
224 (and p-sym (put p-sym 'children 230 (and p-sym (put p-sym 'children
225 (delq (car mp) (get p-sym 'children)))) 231 (delq m (get p-sym 'children))))
226 (if message-changing 232 (if message-changing
227 (set id-sym nil)))) 233 (set id-sym nil))))
228 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym))) 234 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
229 (if (not (eq id-sym (aref vect 0))) 235 (if (not (eq id-sym (aref vect 0)))
230 (aset vect 2 (delq (car mp) (aref vect 2))) 236 (aset vect 2 (delq m (aref vect 2)))
231 (if message-changing 237 (if message-changing
232 (if (null (cdr (aref vect 3))) 238 (if (null (cdr (aref vect 3)))
233 (makunbound subject-sym) 239 (makunbound subject-sym)
234 (let ((p (aref vect 3)) 240 (let ((p (aref vect 3))
235 oldest-msg oldest-date children) 241 oldest-msg oldest-date children)
237 oldest-date (vm-so-sortable-datestring (car p)) 243 oldest-date (vm-so-sortable-datestring (car p))
238 p (cdr p)) 244 p (cdr p))
239 (while p 245 (while p
240 (if (and (string-lessp (vm-so-sortable-datestring (car p)) 246 (if (and (string-lessp (vm-so-sortable-datestring (car p))
241 oldest-date) 247 oldest-date)
242 (not (eq (car mp) (car p)))) 248 (not (eq m (car p))))
243 (setq oldest-msg (car p) 249 (setq oldest-msg (car p)
244 oldest-date (vm-so-sortable-datestring (car p)))) 250 oldest-date (vm-so-sortable-datestring (car p))))
245 (setq p (cdr p))) 251 (setq p (cdr p)))
246 (aset vect 0 (intern (vm-su-message-id oldest-msg) 252 (aset vect 0 (intern (vm-su-message-id oldest-msg)
247 vm-thread-obarray)) 253 vm-thread-obarray))
248 (aset vect 1 oldest-date) 254 (aset vect 1 oldest-date)
249 (setq children (delq oldest-msg (aref vect 2))) 255 (setq children (delq oldest-msg (aref vect 2)))
250 (aset vect 2 children) 256 (aset vect 2 children)
251 (aset vect 3 (delq (car mp) (aref vect 3))) 257 (aset vect 3 (delq m (aref vect 3)))
252 ;; I'm not sure there aren't situations 258 ;; I'm not sure there aren't situations
253 ;; where this might loop forever. 259 ;; where this might loop forever.
254 (let ((inhibit-quit nil)) 260 (let ((inhibit-quit nil))
255 (vm-thread-mark-for-summary-update children)))))))) 261 (vm-thread-mark-for-summary-update children))))))))
256 (setq mp (cdr mp)))))) 262 (setq mp (cdr mp))))))