Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-virtual.el @ 24:4103f0995bd7 r19-15b95

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b95
author cvs
date Mon, 13 Aug 2007 08:51:03 +0200
parents 859a2309aef8
children 441bb1e64a06
comparison
equal deleted inserted replaced
23:0edd3412f124 24:4103f0995bd7
29 ;; definition. Matching messages are added to 29 ;; definition. Matching messages are added to
30 ;; vm-message-list, instead of replacing it. 30 ;; vm-message-list, instead of replacing it.
31 ;; 31 ;;
32 ;; The messages in new-messages must all be in the same real folder. 32 ;; The messages in new-messages must all be in the same real folder.
33 (defun vm-build-virtual-message-list (new-messages) 33 (defun vm-build-virtual-message-list (new-messages)
34 (let ((clauses (cdr vm-virtual-folder-definition)) 34 (vm-with-virtual-selector-variables
35 35 (let ((clauses (cdr vm-virtual-folder-definition))
36 (message-set (make-vector 311 0)) 36 (message-set (make-vector 311 0))
37 (vbuffer (current-buffer)) 37 (vbuffer (current-buffer))
38 (mirrored vm-virtual-mirror) 38 (mirrored vm-virtual-mirror)
39 (case-fold-search t) 39 (case-fold-search t)
40 (tail-cons (vm-last vm-message-list)) 40 (tail-cons (vm-last vm-message-list))
41 (new-message-list nil) 41 (new-message-list nil)
42 42 virtual location-vector
43 ;; selectors 43 message mp folders folder
44 (any 'vm-vs-any) 44 selectors sel-list selector arglist i
45 (and 'vm-vs-and) 45 real-buffers-used)
46 (or 'vm-vs-or) 46 ;; Since there is at most one virtual message in the folder
47 (not 'vm-vs-not) 47 ;; buffer of a virtual folder, the location data vector (and
48 (header 'vm-vs-header) 48 ;; the markers in it) of all virtual messages in a virtual
49 (label 'vm-vs-label) 49 ;; folder is shared. We initialize the vector here if it
50 (text 'vm-vs-text) 50 ;; hasn't been created already.
51 (recipient 'vm-vs-recipient) 51 (if vm-message-list
52 (author 'vm-vs-author) 52 (setq location-vector (vm-location-data-of (car vm-message-pointer)))
53 (subject 'vm-vs-subject) 53 (setq i 0
54 (sent-before 'vm-vs-sent-before) 54 location-vector (make-vector vm-location-data-vector-length nil))
55 (sent-after 'vm-vs-sent-after) 55 (while (< i vm-location-data-vector-length)
56 (more-chars-than 'vm-vs-more-chars-than) 56 (aset location-vector i (vm-marker nil))
57 (less-chars-than 'vm-vs-less-chars-than) 57 (vm-increment i)))
58 (more-lines-than 'vm-vs-more-lines-than) 58 ;; To keep track of the messages in a virtual folder to
59 (less-lines-than 'vm-vs-less-lines-than) 59 ;; prevent duplicates we create and maintain a set that
60 (new 'vm-vs-new) 60 ;; contain all the real messages.
61 (unread 'vm-vs-unread) 61 (setq mp vm-message-list)
62 (read 'vm-vs-read) 62 (while mp
63 (deleted 'vm-vs-deleted) 63 (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
64 (replied 'vm-vs-replied) 64 message-set)
65 (forwarded 'vm-vs-forwarded) 65 (setq mp (cdr mp)))
66 (filed 'vm-vs-filed) 66 ;; now select the messages
67 (written 'vm-vs-written) 67 (save-excursion
68 (edited 'vm-vs-edited) 68 (while clauses
69 (marked 'vm-vs-marked) 69 (setq folders (car (car clauses))
70 70 selectors (cdr (car clauses)))
71 virtual location-vector 71 (while folders
72 message mp folders folder 72 (setq folder (car folders))
73 selectors sel-list selector arglist i 73 (and (stringp folder)
74 real-buffers-used) 74 (setq folder (expand-file-name folder vm-folder-directory)))
75 ;; Since there is at most one virtual message in the folder 75 (and (listp folder)
76 ;; buffer of a virtual folder, the location data vector (and 76 (setq folder (eval folder)))
77 ;; the markers in it) of all virtual messages in a virtual 77 (cond
78 ;; folder is shared. We initialize the vector here if it 78 ((null folder)
79 ;; hasn't been created already. 79 ;; folder was a s-expr which returned nil
80 (if vm-message-list 80 ;; skip it
81 (setq location-vector (vm-location-data-of (car vm-message-pointer))) 81 nil )
82 (setq i 0 82 ((and (stringp folder) (file-directory-p folder))
83 location-vector (make-vector vm-location-data-vector-length nil)) 83 (setq folders (nconc folders
84 (while (< i vm-location-data-vector-length) 84 (vm-delete-backup-file-names
85 (aset location-vector i (vm-marker nil)) 85 (vm-delete-auto-save-file-names
86 (vm-increment i))) 86 (vm-delete-directory-file-names
87 ;; To keep track of the messages in a virtual folder to 87 (directory-files folder t nil)))))))
88 ;; prevent duplicates we create and maintain a set that 88 ((or (null new-messages)
89 ;; contain all the real messages. 89 ;; If we're assimilating messages into an
90 (setq mp vm-message-list) 90 ;; existing virtual folder, only allow selectors
91 (while mp 91 ;; that would be normally applied to this folder.
92 (intern (vm-message-id-number-of (vm-real-message-of (car mp))) 92 (and (bufferp folder)
93 message-set) 93 (eq (vm-buffer-of (car new-messages)) folder))
94 (setq mp (cdr mp))) 94 (and (stringp folder)
95 ;; now select the messages 95 (eq (vm-buffer-of (car new-messages))
96 (save-excursion 96 ;; letter bomb protection
97 (while clauses 97 ;; set inhibit-local-variables to t for v18 Emacses
98 (setq folders (car (car clauses)) 98 ;; set enable-local-variables to nil
99 selectors (cdr (car clauses))) 99 ;; for newer Emacses
100 (while folders 100 (let ((inhibit-local-variables t)
101 (setq folder (car folders)) 101 (enable-local-variables nil))
102 (and (stringp folder) 102 (find-file-noselect folder)))))
103 (setq folder (expand-file-name folder vm-folder-directory))) 103 (set-buffer (or (and (bufferp folder) folder)
104 (and (listp folder) 104 (vm-get-file-buffer folder)
105 (setq folder (eval folder))) 105 (find-file-noselect folder)))
106 (cond 106 (if (eq major-mode 'vm-virtual-mode)
107 ((null folder) 107 (setq virtual t
108 ;; folder was a s-expr which returned nil 108 real-buffers-used
109 ;; skip it 109 (append vm-real-buffers real-buffers-used))
110 nil ) 110 (setq virtual nil)
111 ((and (stringp folder) (file-directory-p folder)) 111 (if (not (memq (current-buffer) real-buffers-used))
112 (setq folders (nconc folders 112 (setq real-buffers-used (cons (current-buffer)
113 (vm-delete-backup-file-names 113 real-buffers-used)))
114 (vm-delete-auto-save-file-names 114 (if (not (eq major-mode 'vm-mode))
115 (vm-delete-directory-file-names 115 (vm-mode)))
116 (directory-files folder t nil))))))) 116 ;; change (sexpr) into ("/file" "/file2" ...)
117 ((or (null new-messages) 117 ;; this assumes that there will never be (sexpr sexpr2)
118 ;; If we're assimilating messages into an 118 ;; in a virtual folder spec.
119 ;; existing virtual folder, only allow selectors 119 (if (bufferp folder)
120 ;; that would be normally applied to this folder. 120 (if virtual
121 (and (bufferp folder) 121 (setcar (car clauses)
122 (eq (vm-buffer-of (car new-messages)) folder)) 122 (delq nil
123 (and (stringp folder) 123 (mapcar 'buffer-file-name vm-real-buffers)))
124 (eq (vm-buffer-of (car new-messages)) 124 (if buffer-file-name
125 ;; letter bomb protection 125 (setcar (car clauses) (list buffer-file-name)))))
126 ;; set inhibit-local-variables to t for v18 Emacses 126 ;; if new-messages non-nil use it instead of the
127 ;; set enable-local-variables to nil for newer Emacses 127 ;; whole message list
128 (let ((inhibit-local-variables t) 128 (setq mp (or new-messages vm-message-list))
129 (enable-local-variables nil)) 129 (while mp
130 (find-file-noselect folder))))) 130 (if (and (not (intern-soft
131 (set-buffer (or (and (bufferp folder) folder) 131 (vm-message-id-number-of
132 (vm-get-file-buffer folder) 132 (vm-real-message-of (car mp)))
133 (find-file-noselect folder))) 133 message-set))
134 (if (eq major-mode 'vm-virtual-mode) 134 (if virtual
135 (setq virtual t 135 (save-excursion
136 real-buffers-used 136 (set-buffer
137 (append vm-real-buffers real-buffers-used)) 137 (vm-buffer-of
138 (setq virtual nil) 138 (vm-real-message-of
139 (if (not (memq (current-buffer) real-buffers-used)) 139 (car mp))))
140 (setq real-buffers-used (cons (current-buffer) 140 (apply 'vm-vs-or (car mp) selectors))
141 real-buffers-used))) 141 (apply 'vm-vs-or (car mp) selectors)))
142 (if (not (eq major-mode 'vm-mode)) 142 (progn
143 (vm-mode))) 143 (intern
144 ;; change (sexpr) into ("/file" "/file2" ...) 144 (vm-message-id-number-of
145 ;; this assumes that there will never be (sexpr sexpr2) 145 (vm-real-message-of (car mp)))
146 ;; in a virtual folder spec.
147 (if (bufferp folder)
148 (if virtual
149 (setcar (car clauses)
150 (delq nil
151 (mapcar 'buffer-file-name vm-real-buffers)))
152 (if buffer-file-name
153 (setcar (car clauses) (list buffer-file-name)))))
154 ;; if new-messages non-nil use it instead of the
155 ;; whole message list
156 (setq mp (or new-messages vm-message-list))
157 (while mp
158 (if (and (not (intern-soft
159 (vm-message-id-number-of
160 (vm-real-message-of (car mp)))
161 message-set))
162 (if virtual
163 (save-excursion
164 (set-buffer
165 (vm-buffer-of
166 (vm-real-message-of
167 (car mp))))
168 (apply 'vm-vs-or (car mp) selectors))
169 (apply 'vm-vs-or (car mp) selectors)))
170 (progn
171 (intern
172 (vm-message-id-number-of
173 (vm-real-message-of (car mp)))
174 message-set) 146 message-set)
175 (setq message (copy-sequence 147 (setq message (copy-sequence
176 (vm-real-message-of (car mp)))) 148 (vm-real-message-of (car mp))))
177 (if mirrored 149 (if mirrored
178 () 150 ()
179 (vm-set-mirror-data-of 151 (vm-set-mirror-data-of
180 message 152 message
181 (make-vector vm-mirror-data-vector-length nil)) 153 (make-vector vm-mirror-data-vector-length nil))
182 (vm-set-virtual-messages-sym-of 154 (vm-set-virtual-messages-sym-of
183 message (make-symbol "<v>")) 155 message (make-symbol "<v>"))
184 (vm-set-virtual-messages-of message nil) 156 (vm-set-virtual-messages-of message nil)
185 (vm-set-attributes-of 157 (vm-set-attributes-of
186 message 158 message
187 (make-vector vm-attributes-vector-length nil))) 159 (make-vector vm-attributes-vector-length nil)))
188 (vm-set-location-data-of message location-vector) 160 (vm-set-location-data-of message location-vector)
189 (vm-set-softdata-of 161 (vm-set-softdata-of
190 message 162 message
191 (make-vector vm-softdata-vector-length nil)) 163 (make-vector vm-softdata-vector-length nil))
192 (vm-set-real-message-sym-of 164 (vm-set-real-message-sym-of
193 message 165 message
194 (vm-real-message-sym-of (car mp))) 166 (vm-real-message-sym-of (car mp)))
195 (vm-set-message-type-of message vm-folder-type) 167 (vm-set-message-type-of message vm-folder-type)
196 (vm-set-message-id-number-of message 168 (vm-set-message-id-number-of message
197 vm-message-id-number) 169 vm-message-id-number)
198 (vm-increment vm-message-id-number) 170 (vm-increment vm-message-id-number)
199 (vm-set-buffer-of message vbuffer) 171 (vm-set-buffer-of message vbuffer)
200 (vm-set-reverse-link-sym-of message (make-symbol "<--")) 172 (vm-set-reverse-link-sym-of message (make-symbol "<--"))
201 (vm-set-reverse-link-of message tail-cons) 173 (vm-set-reverse-link-of message tail-cons)
202 (if (null tail-cons) 174 (if (null tail-cons)
203 (setq new-message-list (list message) 175 (setq new-message-list (list message)
204 tail-cons new-message-list) 176 tail-cons new-message-list)
205 (setcdr tail-cons (list message)) 177 (setcdr tail-cons (list message))
206 (if (null new-message-list) 178 (if (null new-message-list)
207 (setq new-message-list (cdr tail-cons))) 179 (setq new-message-list (cdr tail-cons)))
208 (setq tail-cons (cdr tail-cons))))) 180 (setq tail-cons (cdr tail-cons)))))
209 (setq mp (cdr mp))))) 181 (setq mp (cdr mp)))))
210 (setq folders (cdr folders))) 182 (setq folders (cdr folders)))
211 (setq clauses (cdr clauses)))) 183 (setq clauses (cdr clauses))))
212 ; this doesn't need to work currently, but it might someday 184 ;; this doesn't need to work currently, but it might someday
213 ; (if virtual 185 ;; (if virtual
214 ; (setq real-buffers-used (vm-delete-duplicates real-buffers-used))) 186 ;; (setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
215 (vm-increment vm-modification-counter) 187 (vm-increment vm-modification-counter)
216 ;; Until this point the user doesn't really have a virtual 188 ;; Until this point the user doesn't really have a virtual
217 ;; folder, as the virtual messages haven't been linked to the 189 ;; folder, as the virtual messages haven't been linked to the
218 ;; real messages, virtual buffers to the real buffers, and no 190 ;; real messages, virtual buffers to the real buffers, and no
219 ;; message list has been installed. 191 ;; message list has been installed.
220 ;; 192 ;;
221 ;; Now we tie it all together, with this section of code being 193 ;; Now we tie it all together, with this section of code being
222 ;; uninterruptible. 194 ;; uninterruptible.
223 (let ((inhibit-quit t) 195 (let ((inhibit-quit t)
224 (label-obarray vm-label-obarray)) 196 (label-obarray vm-label-obarray))
225 (if (null vm-real-buffers) 197 (if (null vm-real-buffers)
226 (setq vm-real-buffers real-buffers-used)) 198 (setq vm-real-buffers real-buffers-used))
227 (save-excursion 199 (save-excursion
228 (while real-buffers-used 200 (while real-buffers-used
229 (set-buffer (car real-buffers-used)) 201 (set-buffer (car real-buffers-used))
230 ;; inherit the global label lists of all the associated 202 ;; inherit the global label lists of all the associated
231 ;; real folders. 203 ;; real folders.
232 (mapatoms (function (lambda (x) (intern (symbol-name x) 204 (mapatoms (function (lambda (x) (intern (symbol-name x)
233 label-obarray))) 205 label-obarray)))
234 vm-label-obarray) 206 vm-label-obarray)
235 (if (not (memq vbuffer vm-virtual-buffers)) 207 (if (not (memq vbuffer vm-virtual-buffers))
236 (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))) 208 (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
237 (setq real-buffers-used (cdr real-buffers-used)))) 209 (setq real-buffers-used (cdr real-buffers-used))))
238 (setq mp new-message-list) 210 (setq mp new-message-list)
239 (while mp 211 (while mp
240 (vm-set-virtual-messages-of 212 (vm-set-virtual-messages-of
241 (vm-real-message-of (car mp)) 213 (vm-real-message-of (car mp))
242 (cons (car mp) (vm-virtual-messages-of (car mp)))) 214 (cons (car mp) (vm-virtual-messages-of (car mp))))
243 (setq mp (cdr mp))) 215 (setq mp (cdr mp)))
244 (if vm-message-list 216 (if vm-message-list
245 (progn 217 (progn
246 (vm-set-summary-redo-start-point new-message-list) 218 (vm-set-summary-redo-start-point new-message-list)
247 (vm-set-numbering-redo-start-point new-message-list)) 219 (vm-set-numbering-redo-start-point new-message-list))
248 (vm-set-summary-redo-start-point t) 220 (vm-set-summary-redo-start-point t)
249 (vm-set-numbering-redo-start-point t) 221 (vm-set-numbering-redo-start-point t)
250 (setq vm-message-list new-message-list))))) 222 (setq vm-message-list new-message-list))))))
251 223
252 (defun vm-create-virtual-folder (selector &optional arg read-only) 224 (defun vm-create-virtual-folder (selector &optional arg read-only)
253 "Create a new virtual folder from messages in the current folder. 225 "Create a new virtual folder from messages in the current folder.
254 The messages will be chosen by applying the selector you specify, 226 The messages will be chosen by applying the selector you specify,
255 which is normally read from the minibuffer. 227 which is normally read from the minibuffer.