Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-thread.el @ 36:c53a95d3c46d r19-15b101

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b101
author cvs
date Mon, 13 Aug 2007 08:53:38 +0200
parents 441bb1e64a06
children 05472e90ae02
comparison
equal deleted inserted replaced
35:279432d5c479 36:c53a95d3c46d
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) 45 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 parent (vm-th-parent (car mp))
48 id (vm-su-message-id (car mp)) 48 id (vm-su-message-id (car mp))
49 id-sym (intern id vm-thread-obarray) 49 id-sym (intern id vm-thread-obarray)
50 date (vm-so-sortable-datestring (car mp))) 50 date (vm-so-sortable-datestring (car mp)))
53 schedule-reindents) 53 schedule-reindents)
54 (vm-thread-mark-for-summary-update (get id-sym 'children))) 54 (vm-thread-mark-for-summary-update (get id-sym 'children)))
55 (if parent 55 (if parent
56 (progn 56 (progn
57 (setq parent-sym (intern parent vm-thread-obarray)) 57 (setq parent-sym (intern parent vm-thread-obarray))
58 (if (not (boundp id-sym)) 58 (cond ((or (not (boundp id-sym))
59 (set id-sym parent-sym)) 59 (null (symbol-value id-sym))
60 (eq (symbol-value id-sym) parent-sym))
61 (set id-sym parent-sym))
62 (t
63 (setq old-parent-sym (symbol-value id-sym))
64 (put old-parent-sym 'children
65 (let ((kids (get old-parent-sym 'children))
66 (msgs (get id-sym 'messages)))
67 (while msgs
68 (setq kids (delq (car msgs) kids)
69 msgs (cdr msgs)))
70 kids ))
71 (set id-sym parent-sym)
72 (if schedule-reindents
73 (vm-thread-mark-for-summary-update
74 (get id-sym 'messages)))))
60 (put parent-sym 'children 75 (put parent-sym 'children
61 (cons (car mp) (get parent-sym 'children)))) 76 (cons (car mp) (get parent-sym 'children))))
62 (set id-sym nil)) 77 (if (not (boundp id-sym))
63 ;; we need to make sure the asets below are an atomic group. 78 (set id-sym nil)))
79 ;; use the references header to set parenting information
80 ;; for ancestors of this message. This does not override
81 ;; a parent pointer for a message if it already exists.
82 (if (cdr (setq refs (vm-th-references (car mp))))
83 (let (parent-sym id-sym msgs)
84 (setq parent-sym (intern (car refs) vm-thread-obarray)
85 refs (cdr refs))
86 (while refs
87 (setq id-sym (intern (car refs) vm-thread-obarray))
88 (if (and (boundp id-sym) (symbol-value id-sym))
89 nil
90 (set id-sym parent-sym)
91 (if (setq msgs (get id-sym 'messages))
92 (put parent-sym 'children
93 (append msgs (get parent-sym 'children))))
94 (if schedule-reindents
95 (vm-thread-mark-for-summary-update msgs)))
96 (setq parent-sym id-sym
97 refs (cdr refs)))))
64 (if vm-thread-using-subject 98 (if vm-thread-using-subject
99 ;; inhibit-quit because we need to make sure the asets
100 ;; below are an atomic group.
65 (let* ((inhibit-quit t) 101 (let* ((inhibit-quit t)
66 (subject (vm-so-sortable-subject (car mp))) 102 (subject (vm-so-sortable-subject (car mp)))
67 (subject-sym (intern subject vm-thread-subject-obarray))) 103 (subject-sym (intern subject vm-thread-subject-obarray)))
104 ;; if this subject never seen before create the
105 ;; information vector.
68 (if (not (boundp subject-sym)) 106 (if (not (boundp subject-sym))
69 (set subject-sym 107 (set subject-sym
70 (vector id-sym (vm-so-sortable-datestring (car mp)) 108 (vector id-sym (vm-so-sortable-datestring (car mp))
71 nil (list (car mp)))) 109 nil (list (car mp))))
110 ;; this subject seen before
72 (aset (symbol-value subject-sym) 3 111 (aset (symbol-value subject-sym) 3
73 (cons (car mp) (aref (symbol-value subject-sym) 3))) 112 (cons (car mp) (aref (symbol-value subject-sym) 3)))
74 (if (string< date (aref (symbol-value subject-sym) 1)) 113 (if (string< date (aref (symbol-value subject-sym) 1))
75 (let* ((vect (symbol-value subject-sym)) 114 (let* ((vect (symbol-value subject-sym))
76 (i-sym (aref vect 0))) 115 (i-sym (aref vect 0)))
116 ;; optimization: if we know that this message
117 ;; already has a parent, then don't bother
118 ;; adding it to the list of child messages
119 ;; since we know that it will be threaded and
120 ;; unthreaded using the parent information.
77 (if (or (not (boundp i-sym)) 121 (if (or (not (boundp i-sym))
78 (null (symbol-value i-sym))) 122 (null (symbol-value i-sym)))
79 (aset vect 2 (append (get i-sym 'messages) 123 (aset vect 2 (append (get i-sym 'messages)
80 (aref vect 2)))) 124 (aref vect 2))))
81 (aset vect 0 id-sym) 125 (aset vect 0 id-sym)
86 ;; that it finish... the summary will just be out 130 ;; that it finish... the summary will just be out
87 ;; of sync. 131 ;; of sync.
88 (if schedule-reindents 132 (if schedule-reindents
89 (let ((inhibit-quit nil)) 133 (let ((inhibit-quit nil))
90 (vm-thread-mark-for-summary-update (aref vect 2))))) 134 (vm-thread-mark-for-summary-update (aref vect 2)))))
135 ;; optimization: if we know that this message
136 ;; already has a parent, then don't bother adding
137 ;; it to the list of child messages, since we
138 ;; know that it will be threaded and unthreaded
139 ;; using the parent information.
91 (if (null parent) 140 (if (null parent)
92 (aset (symbol-value subject-sym) 2 141 (aset (symbol-value subject-sym) 2
93 (cons (car mp) 142 (cons (car mp)
94 (aref (symbol-value subject-sym) 2)))))))) 143 (aref (symbol-value subject-sym) 2))))))))
95 (setq mp (cdr mp) n (1+ n)) 144 (setq mp (cdr mp) n (1+ n))
150 thread-list ))) 199 thread-list )))
151 200
152 ;; remove message struct from thread data. 201 ;; remove message struct from thread data.
153 ;; 202 ;;
154 ;; optional second arg non-nil means forget information that 203 ;; optional second arg non-nil means forget information that
155 ;; might be different if the mesage contents changed. 204 ;; might be different if the message contents changed.
156 ;; 205 ;;
157 ;; message must be a real message 206 ;; message must be a real (non-virtual) message
158 (defun vm-unthread-message (message &optional message-changing) 207 (defun vm-unthread-message (message &optional message-changing)
159 (save-excursion 208 (save-excursion
160 (let ((mp (cons message (vm-virtual-messages-of message))) 209 (let ((mp (cons message (vm-virtual-messages-of message)))
161 id-sym subject-sym vect p-sym) 210 id-sym subject-sym vect p-sym)
162 (while mp 211 (while mp
204 ;; where this might loop forever. 253 ;; where this might loop forever.
205 (let ((inhibit-quit nil)) 254 (let ((inhibit-quit nil))
206 (vm-thread-mark-for-summary-update children)))))))) 255 (vm-thread-mark-for-summary-update children))))))))
207 (setq mp (cdr mp)))))) 256 (setq mp (cdr mp))))))
208 257
258 (defun vm-th-references (m)
259 (or (vm-references-of m)
260 (vm-set-references-of
261 m
262 (let (references)
263 (setq references (vm-get-header-contents m "References:" " "))
264 (and references (vm-parse references "[^<]*\\(<[^>]+>\\)"))))))
265
209 (defun vm-th-parent (m) 266 (defun vm-th-parent (m)
210 (or (vm-parent-of m) 267 (or (vm-parent-of m)
211 (vm-set-parent-of 268 (vm-set-parent-of
212 m 269 m
213 (or (let (references) 270 (or (car (vm-last (vm-th-references m)))
214 (setq references (vm-get-header-contents m "References:" " "))
215 (and references
216 (car (vm-last
217 (vm-parse references "[^<]*\\(<[^>]+>\\)")))))
218 (let (in-reply-to) 271 (let (in-reply-to)
219 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ")) 272 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " "))
220 (and in-reply-to 273 (and in-reply-to
221 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)")))))))) 274 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
222 275