|
0
|
1 ;;; Virtual folders for VM
|
|
20
|
2 ;;; Copyright (C) 1990-1997 Kyle E. Jones
|
|
0
|
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-virtual)
|
|
|
19
|
|
|
20 ;; This function builds the virtual message list.
|
|
|
21 ;;
|
|
|
22 ;; If the new-messages argument is nil, the message list is
|
|
|
23 ;; derived from the folders listed in the virtual folder
|
|
|
24 ;; definition and selected by the various selectors. The
|
|
|
25 ;; resulting message list is assigned to vm-message-list.
|
|
|
26 ;;
|
|
|
27 ;; If new-messages is non-nil then it is a list of messages to be
|
|
|
28 ;; tried against the selector parts of the virtual folder
|
|
|
29 ;; definition. Matching messages are added to
|
|
|
30 ;; vm-message-list, instead of replacing it.
|
|
|
31 ;;
|
|
|
32 ;; The messages in new-messages must all be in the same real folder.
|
|
|
33 (defun vm-build-virtual-message-list (new-messages)
|
|
24
|
34 (vm-with-virtual-selector-variables
|
|
|
35 (let ((clauses (cdr vm-virtual-folder-definition))
|
|
|
36 (message-set (make-vector 311 0))
|
|
|
37 (vbuffer (current-buffer))
|
|
|
38 (mirrored vm-virtual-mirror)
|
|
|
39 (case-fold-search t)
|
|
|
40 (tail-cons (vm-last vm-message-list))
|
|
|
41 (new-message-list nil)
|
|
|
42 virtual location-vector
|
|
|
43 message mp folders folder
|
|
|
44 selectors sel-list selector arglist i
|
|
|
45 real-buffers-used)
|
|
|
46 ;; Since there is at most one virtual message in the folder
|
|
|
47 ;; buffer of a virtual folder, the location data vector (and
|
|
|
48 ;; the markers in it) of all virtual messages in a virtual
|
|
|
49 ;; folder is shared. We initialize the vector here if it
|
|
|
50 ;; hasn't been created already.
|
|
|
51 (if vm-message-list
|
|
|
52 (setq location-vector (vm-location-data-of (car vm-message-pointer)))
|
|
|
53 (setq i 0
|
|
|
54 location-vector (make-vector vm-location-data-vector-length nil))
|
|
|
55 (while (< i vm-location-data-vector-length)
|
|
|
56 (aset location-vector i (vm-marker nil))
|
|
|
57 (vm-increment i)))
|
|
|
58 ;; To keep track of the messages in a virtual folder to
|
|
|
59 ;; prevent duplicates we create and maintain a set that
|
|
|
60 ;; contain all the real messages.
|
|
|
61 (setq mp vm-message-list)
|
|
|
62 (while mp
|
|
|
63 (intern (vm-message-id-number-of (vm-real-message-of (car mp)))
|
|
|
64 message-set)
|
|
|
65 (setq mp (cdr mp)))
|
|
|
66 ;; now select the messages
|
|
|
67 (save-excursion
|
|
|
68 (while clauses
|
|
|
69 (setq folders (car (car clauses))
|
|
|
70 selectors (cdr (car clauses)))
|
|
|
71 (while folders
|
|
|
72 (setq folder (car folders))
|
|
|
73 (and (stringp folder)
|
|
|
74 (setq folder (expand-file-name folder vm-folder-directory)))
|
|
|
75 (and (listp folder)
|
|
|
76 (setq folder (eval folder)))
|
|
|
77 (cond
|
|
|
78 ((null folder)
|
|
|
79 ;; folder was a s-expr which returned nil
|
|
|
80 ;; skip it
|
|
|
81 nil )
|
|
|
82 ((and (stringp folder) (file-directory-p folder))
|
|
|
83 (setq folders (nconc folders
|
|
|
84 (vm-delete-backup-file-names
|
|
|
85 (vm-delete-auto-save-file-names
|
|
|
86 (vm-delete-directory-file-names
|
|
|
87 (directory-files folder t nil)))))))
|
|
|
88 ((or (null new-messages)
|
|
|
89 ;; If we're assimilating messages into an
|
|
|
90 ;; existing virtual folder, only allow selectors
|
|
|
91 ;; that would be normally applied to this folder.
|
|
|
92 (and (bufferp folder)
|
|
|
93 (eq (vm-buffer-of (car new-messages)) folder))
|
|
|
94 (and (stringp folder)
|
|
|
95 (eq (vm-buffer-of (car new-messages))
|
|
|
96 ;; letter bomb protection
|
|
|
97 ;; set inhibit-local-variables to t for v18 Emacses
|
|
|
98 ;; set enable-local-variables to nil
|
|
|
99 ;; for newer Emacses
|
|
|
100 (let ((inhibit-local-variables t)
|
|
|
101 (enable-local-variables nil))
|
|
|
102 (find-file-noselect folder)))))
|
|
|
103 (set-buffer (or (and (bufferp folder) folder)
|
|
|
104 (vm-get-file-buffer folder)
|
|
26
|
105 (let ((inhibit-local-variables t)
|
|
|
106 (enable-local-variables nil))
|
|
|
107 (find-file-noselect folder))))
|
|
24
|
108 (if (eq major-mode 'vm-virtual-mode)
|
|
|
109 (setq virtual t
|
|
|
110 real-buffers-used
|
|
|
111 (append vm-real-buffers real-buffers-used))
|
|
|
112 (setq virtual nil)
|
|
|
113 (if (not (memq (current-buffer) real-buffers-used))
|
|
|
114 (setq real-buffers-used (cons (current-buffer)
|
|
|
115 real-buffers-used)))
|
|
|
116 (if (not (eq major-mode 'vm-mode))
|
|
|
117 (vm-mode)))
|
|
|
118 ;; change (sexpr) into ("/file" "/file2" ...)
|
|
|
119 ;; this assumes that there will never be (sexpr sexpr2)
|
|
|
120 ;; in a virtual folder spec.
|
|
|
121 (if (bufferp folder)
|
|
|
122 (if virtual
|
|
|
123 (setcar (car clauses)
|
|
|
124 (delq nil
|
|
|
125 (mapcar 'buffer-file-name vm-real-buffers)))
|
|
|
126 (if buffer-file-name
|
|
|
127 (setcar (car clauses) (list buffer-file-name)))))
|
|
|
128 ;; if new-messages non-nil use it instead of the
|
|
|
129 ;; whole message list
|
|
|
130 (setq mp (or new-messages vm-message-list))
|
|
|
131 (while mp
|
|
|
132 (if (and (not (intern-soft
|
|
|
133 (vm-message-id-number-of
|
|
|
134 (vm-real-message-of (car mp)))
|
|
|
135 message-set))
|
|
|
136 (if virtual
|
|
|
137 (save-excursion
|
|
|
138 (set-buffer
|
|
|
139 (vm-buffer-of
|
|
|
140 (vm-real-message-of
|
|
|
141 (car mp))))
|
|
|
142 (apply 'vm-vs-or (car mp) selectors))
|
|
|
143 (apply 'vm-vs-or (car mp) selectors)))
|
|
|
144 (progn
|
|
|
145 (intern
|
|
|
146 (vm-message-id-number-of
|
|
|
147 (vm-real-message-of (car mp)))
|
|
0
|
148 message-set)
|
|
24
|
149 (setq message (copy-sequence
|
|
|
150 (vm-real-message-of (car mp))))
|
|
|
151 (if mirrored
|
|
|
152 ()
|
|
|
153 (vm-set-mirror-data-of
|
|
|
154 message
|
|
|
155 (make-vector vm-mirror-data-vector-length nil))
|
|
|
156 (vm-set-virtual-messages-sym-of
|
|
|
157 message (make-symbol "<v>"))
|
|
|
158 (vm-set-virtual-messages-of message nil)
|
|
|
159 (vm-set-attributes-of
|
|
|
160 message
|
|
|
161 (make-vector vm-attributes-vector-length nil)))
|
|
|
162 (vm-set-location-data-of message location-vector)
|
|
|
163 (vm-set-softdata-of
|
|
|
164 message
|
|
|
165 (make-vector vm-softdata-vector-length nil))
|
|
|
166 (vm-set-real-message-sym-of
|
|
|
167 message
|
|
|
168 (vm-real-message-sym-of (car mp)))
|
|
|
169 (vm-set-message-type-of message vm-folder-type)
|
|
|
170 (vm-set-message-id-number-of message
|
|
|
171 vm-message-id-number)
|
|
|
172 (vm-increment vm-message-id-number)
|
|
|
173 (vm-set-buffer-of message vbuffer)
|
|
|
174 (vm-set-reverse-link-sym-of message (make-symbol "<--"))
|
|
|
175 (vm-set-reverse-link-of message tail-cons)
|
|
|
176 (if (null tail-cons)
|
|
|
177 (setq new-message-list (list message)
|
|
|
178 tail-cons new-message-list)
|
|
|
179 (setcdr tail-cons (list message))
|
|
|
180 (if (null new-message-list)
|
|
|
181 (setq new-message-list (cdr tail-cons)))
|
|
|
182 (setq tail-cons (cdr tail-cons)))))
|
|
|
183 (setq mp (cdr mp)))))
|
|
|
184 (setq folders (cdr folders)))
|
|
|
185 (setq clauses (cdr clauses))))
|
|
|
186 ;; this doesn't need to work currently, but it might someday
|
|
|
187 ;; (if virtual
|
|
|
188 ;; (setq real-buffers-used (vm-delete-duplicates real-buffers-used)))
|
|
|
189 (vm-increment vm-modification-counter)
|
|
|
190 ;; Until this point the user doesn't really have a virtual
|
|
|
191 ;; folder, as the virtual messages haven't been linked to the
|
|
|
192 ;; real messages, virtual buffers to the real buffers, and no
|
|
|
193 ;; message list has been installed.
|
|
|
194 ;;
|
|
|
195 ;; Now we tie it all together, with this section of code being
|
|
|
196 ;; uninterruptible.
|
|
|
197 (let ((inhibit-quit t)
|
|
|
198 (label-obarray vm-label-obarray))
|
|
|
199 (if (null vm-real-buffers)
|
|
|
200 (setq vm-real-buffers real-buffers-used))
|
|
|
201 (save-excursion
|
|
|
202 (while real-buffers-used
|
|
|
203 (set-buffer (car real-buffers-used))
|
|
|
204 ;; inherit the global label lists of all the associated
|
|
|
205 ;; real folders.
|
|
|
206 (mapatoms (function (lambda (x) (intern (symbol-name x)
|
|
|
207 label-obarray)))
|
|
|
208 vm-label-obarray)
|
|
|
209 (if (not (memq vbuffer vm-virtual-buffers))
|
|
|
210 (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers)))
|
|
|
211 (setq real-buffers-used (cdr real-buffers-used))))
|
|
|
212 (setq mp new-message-list)
|
|
|
213 (while mp
|
|
|
214 (vm-set-virtual-messages-of
|
|
|
215 (vm-real-message-of (car mp))
|
|
|
216 (cons (car mp) (vm-virtual-messages-of (car mp))))
|
|
|
217 (setq mp (cdr mp)))
|
|
|
218 (if vm-message-list
|
|
|
219 (progn
|
|
|
220 (vm-set-summary-redo-start-point new-message-list)
|
|
|
221 (vm-set-numbering-redo-start-point new-message-list))
|
|
|
222 (vm-set-summary-redo-start-point t)
|
|
|
223 (vm-set-numbering-redo-start-point t)
|
|
|
224 (setq vm-message-list new-message-list))))))
|
|
0
|
225
|
|
|
226 (defun vm-create-virtual-folder (selector &optional arg read-only)
|
|
|
227 "Create a new virtual folder from messages in the current folder.
|
|
|
228 The messages will be chosen by applying the selector you specify,
|
|
|
229 which is normally read from the minibuffer.
|
|
|
230
|
|
|
231 Prefix arg means the new virtual folder should be visited read only."
|
|
|
232 (interactive
|
|
|
233 (let ((last-command last-command)
|
|
|
234 (this-command this-command)
|
|
|
235 (prefix current-prefix-arg))
|
|
|
236 (vm-select-folder-buffer)
|
|
|
237 (nconc (vm-read-virtual-selector "Create virtual folder of messages: ")
|
|
|
238 (list prefix))))
|
|
|
239 (vm-select-folder-buffer)
|
|
|
240 (vm-check-for-killed-summary)
|
|
|
241 (vm-error-if-folder-empty)
|
|
|
242 (let (vm-virtual-folder-alist name)
|
|
|
243 (if arg
|
|
|
244 (setq name (format "%s %s %s" (buffer-name) selector arg))
|
|
|
245 (setq name (format "%s %s" (buffer-name) selector)))
|
|
|
246 (setq vm-virtual-folder-alist
|
|
|
247 (list
|
|
|
248 (list name
|
|
|
249 (list (list (list 'get-buffer (buffer-name)))
|
|
|
250 (if arg (list selector arg) (list selector))))))
|
|
|
251 (vm-visit-virtual-folder name read-only)))
|
|
|
252
|
|
|
253 (defun vm-apply-virtual-folder (name &optional read-only)
|
|
|
254 "Apply the selectors of a named virtual folder to the current folder
|
|
|
255 and create a virtual folder containing the selected messages.
|
|
|
256
|
|
|
257 Prefix arg means the new virtual folder should be visited read only."
|
|
|
258 (interactive
|
|
|
259 (let ((last-command last-command)
|
|
|
260 (this-command this-command))
|
|
|
261 (list
|
|
|
262 (completing-read "Apply this virtual folder's selectors: "
|
|
|
263 vm-virtual-folder-alist nil t)
|
|
|
264 current-prefix-arg)))
|
|
|
265 (vm-select-folder-buffer)
|
|
|
266 (vm-check-for-killed-summary)
|
|
|
267 (vm-error-if-folder-empty)
|
|
|
268 (let ((vfolder (assoc name vm-virtual-folder-alist))
|
|
|
269 clauses vm-virtual-folder-alist)
|
|
|
270 (or vfolder (error "No such virtual folder, %s" name))
|
|
|
271 (setq vfolder (vm-copy vfolder))
|
|
|
272 (setq clauses (cdr vfolder))
|
|
|
273 (while clauses
|
|
|
274 (setcar (car clauses) (list (list 'get-buffer (buffer-name))))
|
|
|
275 (setq clauses (cdr clauses)))
|
|
|
276 (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder)))
|
|
|
277 (setq vm-virtual-folder-alist (list vfolder))
|
|
|
278 (vm-visit-virtual-folder (car vfolder) read-only)))
|
|
|
279
|
|
|
280 (defun vm-toggle-virtual-mirror ()
|
|
|
281 (interactive)
|
|
|
282 (vm-select-folder-buffer)
|
|
|
283 (vm-check-for-killed-summary)
|
|
|
284 (if (not (eq major-mode 'vm-virtual-mode))
|
|
|
285 (error "This is not a virtual folder."))
|
|
|
286 (let ((mp vm-message-list)
|
|
|
287 (inhibit-quit t)
|
|
|
288 modified undo-list)
|
|
|
289 (setq undo-list vm-saved-undo-record-list
|
|
|
290 vm-saved-undo-record-list vm-undo-record-list
|
|
|
291 vm-undo-record-list undo-list
|
|
|
292 vm-undo-record-pointer undo-list)
|
|
|
293 (setq modified vm-saved-buffer-modified-p
|
|
|
294 vm-saved-buffer-modified-p (buffer-modified-p))
|
|
|
295 (set-buffer-modified-p modified)
|
|
|
296 (if vm-virtual-mirror
|
|
|
297 (while mp
|
|
|
298 (vm-set-attributes-of
|
|
|
299 (car mp) (or (vm-saved-virtual-attributes-of (car mp))
|
|
|
300 (make-vector vm-attributes-vector-length nil)))
|
|
|
301 (vm-set-mirror-data-of
|
|
|
302 (car mp) (or (vm-saved-virtual-mirror-data-of (car mp))
|
|
|
303 (make-vector vm-mirror-data-vector-length nil)))
|
|
|
304 (vm-mark-for-summary-update (car mp) t)
|
|
|
305 (setq mp (cdr mp)))
|
|
|
306 (while mp
|
|
|
307 ;; mark for summary update _before_ we set this message to
|
|
|
308 ;; be mirrored. this will prevent the real message and
|
|
|
309 ;; the other messages that will share attributes with
|
|
|
310 ;; this message from having their summaries
|
|
|
311 ;; updated... they don't need it.
|
|
|
312 (vm-mark-for-summary-update (car mp) t)
|
|
|
313 (vm-set-saved-virtual-attributes-of
|
|
|
314 (car mp) (vm-attributes-of (car mp)))
|
|
|
315 (vm-set-saved-virtual-mirror-data-of
|
|
|
316 (car mp) (vm-mirror-data-of (car mp)))
|
|
|
317 (vm-set-attributes-of
|
|
|
318 (car mp) (vm-attributes-of (vm-real-message-of (car mp))))
|
|
|
319 (vm-set-mirror-data-of
|
|
|
320 (car mp) (vm-mirror-data-of (vm-real-message-of (car mp))))
|
|
|
321 (setq mp (cdr mp))))
|
|
|
322 (setq vm-virtual-mirror (not vm-virtual-mirror))
|
|
|
323 (vm-increment vm-modification-counter))
|
|
|
324 (vm-update-summary-and-mode-line)
|
|
|
325 (message "Virtual folder now %s the underlying real folder%s."
|
|
|
326 (if vm-virtual-mirror "mirrors" "does not mirror")
|
|
|
327 (if (cdr vm-real-buffers) "s" "")))
|
|
|
328
|
|
|
329 (defun vm-virtual-help ()
|
|
|
330 (interactive)
|
|
|
331 (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help))
|
|
|
332 (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror"))
|
|
|
333
|
|
|
334 (defun vm-vs-or (m &rest selectors)
|
|
|
335 (let ((result nil) selector arglist)
|
|
|
336 (while selectors
|
|
|
337 (setq selector (car (car selectors))
|
|
|
338 arglist (cdr (car selectors))
|
|
|
339 result (apply (symbol-value selector) m arglist)
|
|
|
340 selectors (if result nil (cdr selectors))))
|
|
|
341 result ))
|
|
|
342
|
|
|
343 (defun vm-vs-and (m &rest selectors)
|
|
|
344 (let ((result t) selector arglist)
|
|
|
345 (while selectors
|
|
|
346 (setq selector (car (car selectors))
|
|
|
347 arglist (cdr (car selectors))
|
|
|
348 result (apply (symbol-value selector) m arglist)
|
|
|
349 selectors (if (null result) nil (cdr selectors))))
|
|
|
350 result ))
|
|
|
351
|
|
|
352 (defun vm-vs-not (m arg)
|
|
|
353 (let ((selector (car arg))
|
|
|
354 (arglist (cdr arg)))
|
|
|
355 (not (apply (symbol-value selector) m arglist))))
|
|
|
356
|
|
|
357 (defun vm-vs-any (m) t)
|
|
|
358
|
|
|
359 (defun vm-vs-author (m arg)
|
|
|
360 (or (string-match arg (vm-su-full-name m))
|
|
|
361 (string-match arg (vm-su-from m))))
|
|
|
362
|
|
|
363 (defun vm-vs-recipient (m arg)
|
|
|
364 (or (string-match arg (vm-su-to m))
|
|
|
365 (string-match arg (vm-su-to-names m))))
|
|
|
366
|
|
|
367 (defun vm-vs-subject (m arg)
|
|
|
368 (string-match arg (vm-su-subject m)))
|
|
|
369
|
|
|
370 (defun vm-vs-sent-before (m arg)
|
|
|
371 (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg)))
|
|
|
372
|
|
|
373 (defun vm-vs-sent-after (m arg)
|
|
|
374 (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m)))
|
|
|
375
|
|
|
376 (defun vm-vs-header (m arg)
|
|
|
377 (save-excursion
|
|
|
378 (save-restriction
|
|
|
379 (widen)
|
|
20
|
380 (goto-char (vm-headers-of (vm-real-message-of m)))
|
|
|
381 (re-search-forward arg (vm-text-of (vm-real-message-of m)) t))))
|
|
0
|
382
|
|
|
383 (defun vm-vs-label (m arg)
|
|
|
384 (vm-member arg (vm-labels-of m)))
|
|
|
385
|
|
|
386 (defun vm-vs-text (m arg)
|
|
|
387 (save-excursion
|
|
|
388 (save-restriction
|
|
|
389 (widen)
|
|
20
|
390 (goto-char (vm-text-of (vm-real-message-of m)))
|
|
|
391 (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t))))
|
|
0
|
392
|
|
|
393 (defun vm-vs-more-chars-than (m arg)
|
|
|
394 (> (string-to-int (vm-su-byte-count m)) arg))
|
|
|
395
|
|
|
396 (defun vm-vs-less-chars-than (m arg)
|
|
|
397 (< (string-to-int (vm-su-byte-count m)) arg))
|
|
|
398
|
|
|
399 (defun vm-vs-more-lines-than (m arg)
|
|
|
400 (> (string-to-int (vm-su-line-count m)) arg))
|
|
|
401
|
|
|
402 (defun vm-vs-less-lines-than (m arg)
|
|
|
403 (< (string-to-int (vm-su-line-count m)) arg))
|
|
|
404
|
|
|
405 (defun vm-vs-new (m) (vm-new-flag m))
|
|
|
406 (defun vm-vs-unread (m) (vm-unread-flag m))
|
|
|
407 (defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m))))
|
|
|
408 (defun vm-vs-deleted (m) (vm-deleted-flag m))
|
|
|
409 (defun vm-vs-replied (m) (vm-replied-flag m))
|
|
|
410 (defun vm-vs-forwarded (m) (vm-forwarded-flag m))
|
|
|
411 (defun vm-vs-filed (m) (vm-filed-flag m))
|
|
|
412 (defun vm-vs-written (m) (vm-written-flag m))
|
|
|
413 (defun vm-vs-marked (m) (vm-mark-of m))
|
|
|
414 (defun vm-vs-edited (m) (vm-edited-flag m))
|
|
|
415
|
|
|
416 (put 'header 'vm-virtual-selector-clause "with header matching")
|
|
|
417 (put 'label 'vm-virtual-selector-clause "with label of")
|
|
|
418 (put 'text 'vm-virtual-selector-clause "with text matching")
|
|
|
419 (put 'recipient 'vm-virtual-selector-clause "with recipient matching")
|
|
|
420 (put 'author 'vm-virtual-selector-clause "with author matching")
|
|
|
421 (put 'subject 'vm-virtual-selector-clause "with subject matching")
|
|
|
422 (put 'sent-before 'vm-virtual-selector-clause "sent before")
|
|
|
423 (put 'sent-after 'vm-virtual-selector-clause "sent after")
|
|
|
424 (put 'more-chars-than 'vm-virtual-selector-clause
|
|
|
425 "with more characters than")
|
|
|
426 (put 'less-chars-than 'vm-virtual-selector-clause
|
|
|
427 "with less characters than")
|
|
|
428 (put 'more-lines-than 'vm-virtual-selector-clause "with more lines than")
|
|
|
429 (put 'less-lines-than 'vm-virtual-selector-clause "with less lines than")
|
|
|
430
|
|
|
431 (defun vm-read-virtual-selector (prompt)
|
|
|
432 (let (selector (arg nil))
|
|
|
433 (setq selector
|
|
|
434 (vm-read-string prompt vm-supported-interactive-virtual-selectors)
|
|
|
435 selector (intern selector))
|
|
|
436 (if (memq selector '(header label text recipient
|
|
|
437 author subject
|
|
|
438 sent-before sent-after
|
|
|
439 more-chars-than more-lines-than
|
|
|
440 less-chars-than less-lines-than))
|
|
|
441 (progn
|
|
|
442 (setq prompt (concat (substring prompt 0 -2) " "
|
|
|
443 (get selector 'vm-virtual-selector-clause)
|
|
|
444 ": "))
|
|
|
445 (cond ((memq selector '(more-chars-than more-lines-than
|
|
|
446 less-chars-than less-lines-than))
|
|
|
447 (setq arg (vm-read-number prompt)))
|
|
|
448 ((eq selector 'label)
|
|
|
449 (let ((vm-completion-auto-correct nil)
|
|
|
450 (completion-ignore-case t))
|
|
|
451 (setq arg (downcase
|
|
|
452 (vm-read-string
|
|
|
453 prompt
|
|
|
454 (vm-obarray-to-string-list
|
|
|
455 vm-label-obarray)
|
|
|
456 nil)))))
|
|
|
457 (t (setq arg (read-string prompt))))))
|
|
20
|
458 (or (fboundp (intern (concat "vm-vs-" (symbol-name selector))))
|
|
|
459 (error "Invalid selector"))
|
|
0
|
460 (list selector arg)))
|
|
|
461
|
|
|
462 ;; clear away links between real and virtual folders when
|
|
|
463 ;; a vm-quit is performed in either type folder.
|
|
|
464 (defun vm-virtual-quit ()
|
|
|
465 (save-excursion
|
|
|
466 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
467 ;; don't trust blindly, user might have killed some of
|
|
|
468 ;; these buffers.
|
|
|
469 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
470 (let ((bp vm-real-buffers)
|
|
|
471 (mp vm-message-list)
|
|
|
472 (b (current-buffer))
|
|
|
473 ;; lock out interrupts here
|
|
|
474 (inhibit-quit t))
|
|
|
475 (while bp
|
|
|
476 (set-buffer (car bp))
|
|
|
477 (setq vm-virtual-buffers (delq b vm-virtual-buffers)
|
|
|
478 bp (cdr bp)))
|
|
|
479 (while mp
|
|
|
480 (vm-set-virtual-messages-of
|
|
|
481 (vm-real-message-of (car mp))
|
|
|
482 (delq (car mp) (vm-virtual-messages-of
|
|
|
483 (vm-real-message-of (car mp)))))
|
|
|
484 (setq mp (cdr mp)))))
|
|
|
485 ((eq major-mode 'vm-mode)
|
|
|
486 ;; don't trust blindly, user might have killed some of
|
|
|
487 ;; these buffers.
|
|
|
488 (setq vm-virtual-buffers
|
|
|
489 (vm-delete 'buffer-name vm-virtual-buffers t))
|
|
|
490 (let ((bp vm-virtual-buffers)
|
|
|
491 (mp vm-message-list)
|
|
|
492 vmp
|
|
|
493 (b (current-buffer))
|
|
|
494 ;; lock out interrupts here
|
|
|
495 (inhibit-quit t))
|
|
|
496 (while mp
|
|
|
497 (setq vmp (vm-virtual-messages-of (car mp)))
|
|
|
498 (while vmp
|
|
|
499 ;; we'll clear these messages from the virtual
|
|
|
500 ;; folder by looking for messages that have a "Q"
|
|
|
501 ;; id number associated with them.
|
|
|
502 (vm-set-message-id-number-of (car vmp) "Q")
|
|
|
503 (setq vmp (cdr vmp)))
|
|
|
504 (vm-set-virtual-messages-of (car mp) nil)
|
|
|
505 (setq mp (cdr mp)))
|
|
|
506 (while bp
|
|
|
507 (set-buffer (car bp))
|
|
|
508 (setq vm-real-buffers (delq b vm-real-buffers))
|
|
|
509 ;; set the message pointer to a new value if it is
|
|
|
510 ;; now invalid.
|
|
20
|
511 (cond
|
|
36
|
512 ((and vm-message-pointer
|
|
|
513 (equal "Q" (vm-message-id-number-of
|
|
|
514 (car vm-message-pointer))))
|
|
20
|
515 (vm-garbage-collect-message)
|
|
|
516 (setq vmp vm-message-pointer)
|
|
|
517 (while (and vm-message-pointer
|
|
|
518 (equal "Q" (vm-message-id-number-of
|
|
|
519 (car vm-message-pointer))))
|
|
|
520 (setq vm-message-pointer
|
|
|
521 (cdr vm-message-pointer)))
|
|
|
522 ;; if there were no good messages ahead, try going
|
|
|
523 ;; backward.
|
|
|
524 (if (null vm-message-pointer)
|
|
|
525 (progn
|
|
|
526 (setq vm-message-pointer vmp)
|
|
|
527 (while (and vm-message-pointer
|
|
|
528 (equal "Q" (vm-message-id-number-of
|
|
|
529 (car vm-message-pointer))))
|
|
|
530 (setq vm-message-pointer
|
|
|
531 (vm-reverse-link-of
|
|
|
532 (car vm-message-pointer))))))))
|
|
0
|
533 ;; expunge the virtual messages associated with
|
|
|
534 ;; real messages that are going away.
|
|
|
535 (setq vm-message-list
|
|
|
536 (vm-delete (function
|
|
|
537 (lambda (m)
|
|
|
538 (equal "Q" (vm-message-id-number-of m))))
|
|
|
539 vm-message-list nil))
|
|
|
540 (if (null vm-message-pointer)
|
|
|
541 (setq vm-message-pointer vm-message-list))
|
|
|
542 ;; same for vm-last-message-pointer
|
|
|
543 (if (null vm-last-message-pointer)
|
|
|
544 (setq vm-last-message-pointer nil))
|
|
|
545 (vm-clear-virtual-quit-invalidated-undos)
|
|
|
546 (vm-reverse-link-messages)
|
|
|
547 (vm-set-numbering-redo-start-point t)
|
|
|
548 (vm-set-summary-redo-start-point t)
|
|
|
549 (if vm-message-pointer
|
|
|
550 (vm-preview-current-message)
|
|
|
551 (vm-update-summary-and-mode-line))
|
|
|
552 (setq bp (cdr bp))))))))
|
|
|
553
|
|
|
554 (defun vm-virtual-save-folder (prefix)
|
|
|
555 (save-excursion
|
|
|
556 ;; don't trust blindly, user might have killed some of
|
|
|
557 ;; these buffers.
|
|
|
558 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
559 (let ((bp vm-real-buffers))
|
|
|
560 (while bp
|
|
|
561 (set-buffer (car bp))
|
|
|
562 (vm-save-folder prefix)
|
|
|
563 (setq bp (cdr bp)))))
|
|
|
564 (vm-set-buffer-modified-p nil)
|
|
|
565 (vm-clear-modification-flag-undos)
|
|
|
566 (vm-update-summary-and-mode-line))
|
|
|
567
|
|
|
568 (defun vm-virtual-get-new-mail ()
|
|
|
569 (save-excursion
|
|
|
570 ;; don't trust blindly, user might have killed some of
|
|
|
571 ;; these buffers.
|
|
|
572 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
573 (let ((bp vm-real-buffers))
|
|
|
574 (while bp
|
|
|
575 (set-buffer (car bp))
|
|
|
576 (condition-case error-data
|
|
|
577 (vm-get-new-mail)
|
|
|
578 (folder-read-only
|
|
|
579 (message "Folder is read only: %s"
|
|
|
580 (or buffer-file-name (buffer-name)))
|
|
|
581 (sit-for 1))
|
|
|
582 (unrecognized-folder-type
|
|
|
583 (message "Folder type is unrecognized: %s"
|
|
|
584 (or buffer-file-name (buffer-name)))
|
|
|
585 (sit-for 1)))
|
|
|
586 (setq bp (cdr bp)))))
|
|
|
587 (vm-emit-totals-blurb))
|
|
|
588
|
|
|
589 (defun vm-make-virtual-copy (m)
|
|
|
590 (widen)
|
|
|
591 (let ((virtual-buffer (current-buffer))
|
|
|
592 (real-m (vm-real-message-of m))
|
|
|
593 (buffer-read-only nil)
|
|
|
594 (modified (buffer-modified-p)))
|
|
|
595 (unwind-protect
|
|
|
596 (save-excursion
|
|
|
597 (set-buffer (vm-buffer-of real-m))
|
|
|
598 (save-restriction
|
|
|
599 (widen)
|
|
|
600 ;; must reference this now so that headers will be in
|
|
|
601 ;; their final position before the message is copied.
|
|
|
602 ;; otherwise the vheader offset computed below will be wrong.
|
|
|
603 (vm-vheaders-of real-m)
|
|
|
604 (copy-to-buffer virtual-buffer (vm-start-of real-m)
|
|
|
605 (vm-end-of real-m))))
|
|
|
606 (set-buffer-modified-p modified))
|
|
|
607 (set-marker (vm-start-of m) (point-min))
|
|
|
608 (set-marker (vm-headers-of m) (+ (vm-start-of m)
|
|
|
609 (- (vm-headers-of real-m)
|
|
|
610 (vm-start-of real-m))))
|
|
|
611 (set-marker (vm-vheaders-of m) (+ (vm-start-of m)
|
|
|
612 (- (vm-vheaders-of real-m)
|
|
|
613 (vm-start-of real-m))))
|
|
|
614 (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m)
|
|
|
615 (vm-start-of real-m))))
|
|
|
616 (set-marker (vm-text-end-of m) (+ (vm-start-of m)
|
|
|
617 (- (vm-text-end-of real-m)
|
|
|
618 (vm-start-of real-m))))
|
|
|
619 (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m)
|
|
|
620 (vm-start-of real-m))))))
|
