Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-thread.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)
45 parent parent-sym id id-sym date)
46 (while mp
47 (setq parent (vm-th-parent (car mp))
48 id (vm-su-message-id (car mp))
49 id-sym (intern id vm-thread-obarray)
50 date (vm-so-sortable-datestring (car mp)))
51 (put id-sym 'messages (cons (car mp) (get id-sym 'messages)))
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))
58 (if (not (boundp id-sym))
59 (set id-sym parent-sym))
60 (put parent-sym 'children
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.
64 (if vm-thread-using-subject
65 (let* ((inhibit-quit t)
66 (subject (vm-so-sortable-subject (car mp)))
67 (subject-sym (intern subject vm-thread-subject-obarray)))
68 (if (not (boundp subject-sym))
69 (set subject-sym
70 (vector id-sym (vm-so-sortable-datestring (car mp))
71 nil (list (car mp))))
72 (aset (symbol-value subject-sym) 3
73 (cons (car mp) (aref (symbol-value subject-sym) 3)))
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
93 (cons (car mp)
94 (aref (symbol-value subject-sym) 2))))))))
95 (setq mp (cdr mp) n (1+ n))
96 (if (zerop (% n modulus))
97 (vm-unsaved-message "Building threads... %d" n)))
98 (if (> n modulus)
99 (vm-unsaved-message "Building threads... done"))))
100
101 (defun vm-thread-mark-for-summary-update (message-list)
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))))
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...
125 (setq done t
126 thread-list (cdr thread-list))
127 (set loop-sym t)
128 (if (and (boundp id-sym) (symbol-value id-sym))
129 (progn
130 (setq id-sym (symbol-value id-sym)
131 thread-list (cons id-sym thread-list)
132 m (car (get id-sym 'messages))))
133 (if (null m)
134 (setq done t)
135 (if (null vm-thread-using-subject)
136 nil
137 (setq subject-sym
138 (intern (vm-so-sortable-subject m)
139 vm-thread-subject-obarray))
140 (if (or (not (boundp subject-sym))
141 (eq (aref (symbol-value subject-sym) 0) id-sym))
142 (setq done t)
143 (setq id-sym (aref (symbol-value subject-sym) 0)
144 thread-list (cons id-sym thread-list)
145 m (car (get id-sym 'messages)))))))))
146 ;; save the date of the oldest message in this thread
147 (setq root-date (get id-sym 'oldest-date))
148 (if (or (null root-date)
149 (string< (vm-so-sortable-datestring message) root-date))
150 (put id-sym 'oldest-date (vm-so-sortable-datestring message)))
151 thread-list )))
152
153 ;; remove message struct from thread data.
154 ;;
155 ;; optional second arg non-nil means forget information that
156 ;; might be different if the mesage contents changed.
157 ;;
158 ;; message must be a real message
159 (defun vm-unthread-message (message &optional message-changing)
160 (save-excursion
161 (let ((mp (cons message (vm-virtual-messages-of message)))
162 id-sym subject-sym vect p-sym)
163 (while mp
164 (let ((inhibit-quit t))
165 (vm-set-thread-list-of (car mp) nil)
166 (vm-set-thread-indentation-of (car mp) nil)
167 (set-buffer (vm-buffer-of (car mp)))
168 (setq id-sym (intern (vm-su-message-id (car mp)) vm-thread-obarray)
169 subject-sym (intern (vm-so-sortable-subject (car mp))
170 vm-thread-subject-obarray))
171 (if (boundp id-sym)
172 (progn
173 (put id-sym 'messages (delq (car mp) (get id-sym 'messages)))
174 (vm-thread-mark-for-summary-update (get id-sym 'children))
175 (setq p-sym (symbol-value id-sym))
176 (and p-sym (put p-sym 'children
177 (delq (car mp) (get p-sym 'children))))
178 (if message-changing
179 (set id-sym nil))))
180 (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym)))
181 (if (not (eq id-sym (aref vect 0)))
182 (aset vect 2 (delq (car mp) (aref vect 2)))
183 (if message-changing
184 (if (null (cdr (aref vect 3)))
185 (makunbound subject-sym)
186 (let ((p (aref vect 3))
187 oldest-msg oldest-date children)
188 (setq oldest-msg (car p)
189 oldest-date (vm-so-sortable-datestring (car p))
190 p (cdr p))
191 (while p
192 (if (and (string-lessp (vm-so-sortable-datestring (car p))
193 oldest-date)
194 (not (eq (car mp) (car p))))
195 (setq oldest-msg (car p)
196 oldest-date (vm-so-sortable-datestring (car p))))
197 (setq p (cdr p)))
198 (aset vect 0 (intern (vm-su-message-id oldest-msg)
199 vm-thread-obarray))
200 (aset vect 1 oldest-date)
201 (setq children (delq oldest-msg (aref vect 2)))
202 (aset vect 2 children)
203 (aset vect 3 (delq (car mp) (aref vect 3)))
204 ;; I'm not sure there aren't situations
205 ;; where this might loop forever.
206 (let ((inhibit-quit nil))
207 (vm-thread-mark-for-summary-update children))))))))
208 (setq mp (cdr mp))))))
209
210 (defun vm-th-parent (m)
211 (or (vm-parent-of m)
212 (vm-set-parent-of
213 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 "[^<]*\\(<[^>]+>\\)")))))
219 (let (in-reply-to)
220 (setq in-reply-to (vm-get-header-contents m "In-Reply-To:"))
221 (and in-reply-to
222 (car (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))))))))
223
224 (defun vm-th-thread-indentation (m)
225 (or (vm-thread-indentation-of m)
226 (let ((p (vm-th-thread-list m)))
227 (while (and p (null (get (car p) 'messages)))
228 (setq p (cdr p)))
229 (vm-set-thread-indentation-of m (1- (length p)))
230 (vm-thread-indentation-of m))))
231
232 (defun vm-th-thread-list (m)
233 (or (vm-thread-list-of m)
234 (progn
235 (vm-set-thread-list-of m (vm-thread-list m))
236 (vm-thread-list-of m))))