|
0
|
1 ;;; Virtual folders for VM
|
|
98
|
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)
|
|
100
|
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)
|
|
102
|
105 (let ((inhibit-local-variables t)
|
|
|
106 (enable-local-variables nil))
|
|
|
107 (find-file-noselect folder))))
|
|
100
|
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)
|
|
100
|
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))))))
|
|
136
|
251 (vm-visit-virtual-folder name read-only))
|
|
|
252 ;; have to do this again here because the known virtual
|
|
|
253 ;; folder menu is now hosed because we installed it while
|
|
|
254 ;; vm-virtual-folder-alist was bound to the temp value above
|
|
|
255 (if vm-use-menus
|
|
|
256 (vm-menu-install-known-virtual-folders-menu)))
|
|
|
257
|
|
0
|
258
|
|
|
259 (defun vm-apply-virtual-folder (name &optional read-only)
|
|
|
260 "Apply the selectors of a named virtual folder to the current folder
|
|
|
261 and create a virtual folder containing the selected messages.
|
|
|
262
|
|
|
263 Prefix arg means the new virtual folder should be visited read only."
|
|
|
264 (interactive
|
|
|
265 (let ((last-command last-command)
|
|
|
266 (this-command this-command))
|
|
|
267 (list
|
|
|
268 (completing-read "Apply this virtual folder's selectors: "
|
|
|
269 vm-virtual-folder-alist nil t)
|
|
|
270 current-prefix-arg)))
|
|
|
271 (vm-select-folder-buffer)
|
|
|
272 (vm-check-for-killed-summary)
|
|
|
273 (vm-error-if-folder-empty)
|
|
|
274 (let ((vfolder (assoc name vm-virtual-folder-alist))
|
|
|
275 clauses vm-virtual-folder-alist)
|
|
|
276 (or vfolder (error "No such virtual folder, %s" name))
|
|
|
277 (setq vfolder (vm-copy vfolder))
|
|
|
278 (setq clauses (cdr vfolder))
|
|
|
279 (while clauses
|
|
|
280 (setcar (car clauses) (list (list 'get-buffer (buffer-name))))
|
|
|
281 (setq clauses (cdr clauses)))
|
|
|
282 (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder)))
|
|
|
283 (setq vm-virtual-folder-alist (list vfolder))
|
|
136
|
284 (vm-visit-virtual-folder (car vfolder) read-only))
|
|
|
285 ;; have to do this again here because the known virtual
|
|
|
286 ;; folder menu is now hosed because we installed it while
|
|
|
287 ;; vm-virtual-folder-alist was bound to the temp value above
|
|
|
288 (if vm-use-menus
|
|
|
289 (vm-menu-install-known-virtual-folders-menu)))
|
|
0
|
290
|
|
|
291 (defun vm-toggle-virtual-mirror ()
|
|
|
292 (interactive)
|
|
|
293 (vm-select-folder-buffer)
|
|
|
294 (vm-check-for-killed-summary)
|
|
|
295 (if (not (eq major-mode 'vm-virtual-mode))
|
|
|
296 (error "This is not a virtual folder."))
|
|
|
297 (let ((mp vm-message-list)
|
|
|
298 (inhibit-quit t)
|
|
|
299 modified undo-list)
|
|
|
300 (setq undo-list vm-saved-undo-record-list
|
|
|
301 vm-saved-undo-record-list vm-undo-record-list
|
|
|
302 vm-undo-record-list undo-list
|
|
|
303 vm-undo-record-pointer undo-list)
|
|
|
304 (setq modified vm-saved-buffer-modified-p
|
|
|
305 vm-saved-buffer-modified-p (buffer-modified-p))
|
|
|
306 (set-buffer-modified-p modified)
|
|
|
307 (if vm-virtual-mirror
|
|
|
308 (while mp
|
|
|
309 (vm-set-attributes-of
|
|
|
310 (car mp) (or (vm-saved-virtual-attributes-of (car mp))
|
|
|
311 (make-vector vm-attributes-vector-length nil)))
|
|
|
312 (vm-set-mirror-data-of
|
|
|
313 (car mp) (or (vm-saved-virtual-mirror-data-of (car mp))
|
|
|
314 (make-vector vm-mirror-data-vector-length nil)))
|
|
|
315 (vm-mark-for-summary-update (car mp) t)
|
|
|
316 (setq mp (cdr mp)))
|
|
|
317 (while mp
|
|
|
318 ;; mark for summary update _before_ we set this message to
|
|
|
319 ;; be mirrored. this will prevent the real message and
|
|
|
320 ;; the other messages that will share attributes with
|
|
|
321 ;; this message from having their summaries
|
|
|
322 ;; updated... they don't need it.
|
|
|
323 (vm-mark-for-summary-update (car mp) t)
|
|
|
324 (vm-set-saved-virtual-attributes-of
|
|
|
325 (car mp) (vm-attributes-of (car mp)))
|
|
|
326 (vm-set-saved-virtual-mirror-data-of
|
|
|
327 (car mp) (vm-mirror-data-of (car mp)))
|
|
|
328 (vm-set-attributes-of
|
|
|
329 (car mp) (vm-attributes-of (vm-real-message-of (car mp))))
|
|
|
330 (vm-set-mirror-data-of
|
|
|
331 (car mp) (vm-mirror-data-of (vm-real-message-of (car mp))))
|
|
|
332 (setq mp (cdr mp))))
|
|
|
333 (setq vm-virtual-mirror (not vm-virtual-mirror))
|
|
|
334 (vm-increment vm-modification-counter))
|
|
|
335 (vm-update-summary-and-mode-line)
|
|
|
336 (message "Virtual folder now %s the underlying real folder%s."
|
|
|
337 (if vm-virtual-mirror "mirrors" "does not mirror")
|
|
|
338 (if (cdr vm-real-buffers) "s" "")))
|
|
|
339
|
|
|
340 (defun vm-virtual-help ()
|
|
|
341 (interactive)
|
|
|
342 (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help))
|
|
|
343 (message "VV = visit, VA = apply selectors, VC = create, VM = toggle virtual mirror"))
|
|
|
344
|
|
|
345 (defun vm-vs-or (m &rest selectors)
|
|
|
346 (let ((result nil) selector arglist)
|
|
|
347 (while selectors
|
|
|
348 (setq selector (car (car selectors))
|
|
|
349 arglist (cdr (car selectors))
|
|
|
350 result (apply (symbol-value selector) m arglist)
|
|
|
351 selectors (if result nil (cdr selectors))))
|
|
|
352 result ))
|
|
|
353
|
|
|
354 (defun vm-vs-and (m &rest selectors)
|
|
|
355 (let ((result t) selector arglist)
|
|
|
356 (while selectors
|
|
|
357 (setq selector (car (car selectors))
|
|
|
358 arglist (cdr (car selectors))
|
|
|
359 result (apply (symbol-value selector) m arglist)
|
|
|
360 selectors (if (null result) nil (cdr selectors))))
|
|
|
361 result ))
|
|
|
362
|
|
|
363 (defun vm-vs-not (m arg)
|
|
|
364 (let ((selector (car arg))
|
|
|
365 (arglist (cdr arg)))
|
|
|
366 (not (apply (symbol-value selector) m arglist))))
|
|
|
367
|
|
|
368 (defun vm-vs-any (m) t)
|
|
|
369
|
|
|
370 (defun vm-vs-author (m arg)
|
|
|
371 (or (string-match arg (vm-su-full-name m))
|
|
|
372 (string-match arg (vm-su-from m))))
|
|
|
373
|
|
|
374 (defun vm-vs-recipient (m arg)
|
|
|
375 (or (string-match arg (vm-su-to m))
|
|
|
376 (string-match arg (vm-su-to-names m))))
|
|
|
377
|
|
|
378 (defun vm-vs-subject (m arg)
|
|
|
379 (string-match arg (vm-su-subject m)))
|
|
|
380
|
|
|
381 (defun vm-vs-sent-before (m arg)
|
|
|
382 (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg)))
|
|
|
383
|
|
|
384 (defun vm-vs-sent-after (m arg)
|
|
|
385 (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m)))
|
|
|
386
|
|
|
387 (defun vm-vs-header (m arg)
|
|
|
388 (save-excursion
|
|
|
389 (save-restriction
|
|
|
390 (widen)
|
|
98
|
391 (goto-char (vm-headers-of (vm-real-message-of m)))
|
|
|
392 (re-search-forward arg (vm-text-of (vm-real-message-of m)) t))))
|
|
0
|
393
|
|
|
394 (defun vm-vs-label (m arg)
|
|
|
395 (vm-member arg (vm-labels-of m)))
|
|
|
396
|
|
|
397 (defun vm-vs-text (m arg)
|
|
|
398 (save-excursion
|
|
|
399 (save-restriction
|
|
|
400 (widen)
|
|
98
|
401 (goto-char (vm-text-of (vm-real-message-of m)))
|
|
|
402 (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t))))
|
|
0
|
403
|
|
|
404 (defun vm-vs-more-chars-than (m arg)
|
|
|
405 (> (string-to-int (vm-su-byte-count m)) arg))
|
|
|
406
|
|
|
407 (defun vm-vs-less-chars-than (m arg)
|
|
|
408 (< (string-to-int (vm-su-byte-count m)) arg))
|
|
|
409
|
|
|
410 (defun vm-vs-more-lines-than (m arg)
|
|
|
411 (> (string-to-int (vm-su-line-count m)) arg))
|
|
|
412
|
|
|
413 (defun vm-vs-less-lines-than (m arg)
|
|
|
414 (< (string-to-int (vm-su-line-count m)) arg))
|
|
|
415
|
|
|
416 (defun vm-vs-new (m) (vm-new-flag m))
|
|
|
417 (defun vm-vs-unread (m) (vm-unread-flag m))
|
|
|
418 (defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m))))
|
|
|
419 (defun vm-vs-deleted (m) (vm-deleted-flag m))
|
|
|
420 (defun vm-vs-replied (m) (vm-replied-flag m))
|
|
|
421 (defun vm-vs-forwarded (m) (vm-forwarded-flag m))
|
|
|
422 (defun vm-vs-filed (m) (vm-filed-flag m))
|
|
|
423 (defun vm-vs-written (m) (vm-written-flag m))
|
|
|
424 (defun vm-vs-marked (m) (vm-mark-of m))
|
|
|
425 (defun vm-vs-edited (m) (vm-edited-flag m))
|
|
|
426
|
|
|
427 (put 'header 'vm-virtual-selector-clause "with header matching")
|
|
|
428 (put 'label 'vm-virtual-selector-clause "with label of")
|
|
|
429 (put 'text 'vm-virtual-selector-clause "with text matching")
|
|
|
430 (put 'recipient 'vm-virtual-selector-clause "with recipient matching")
|
|
|
431 (put 'author 'vm-virtual-selector-clause "with author matching")
|
|
|
432 (put 'subject 'vm-virtual-selector-clause "with subject matching")
|
|
|
433 (put 'sent-before 'vm-virtual-selector-clause "sent before")
|
|
|
434 (put 'sent-after 'vm-virtual-selector-clause "sent after")
|
|
|
435 (put 'more-chars-than 'vm-virtual-selector-clause
|
|
|
436 "with more characters than")
|
|
|
437 (put 'less-chars-than 'vm-virtual-selector-clause
|
|
|
438 "with less characters than")
|
|
|
439 (put 'more-lines-than 'vm-virtual-selector-clause "with more lines than")
|
|
|
440 (put 'less-lines-than 'vm-virtual-selector-clause "with less lines than")
|
|
|
441
|
|
|
442 (defun vm-read-virtual-selector (prompt)
|
|
|
443 (let (selector (arg nil))
|
|
|
444 (setq selector
|
|
|
445 (vm-read-string prompt vm-supported-interactive-virtual-selectors)
|
|
|
446 selector (intern selector))
|
|
|
447 (if (memq selector '(header label text recipient
|
|
|
448 author subject
|
|
|
449 sent-before sent-after
|
|
|
450 more-chars-than more-lines-than
|
|
|
451 less-chars-than less-lines-than))
|
|
|
452 (progn
|
|
|
453 (setq prompt (concat (substring prompt 0 -2) " "
|
|
|
454 (get selector 'vm-virtual-selector-clause)
|
|
|
455 ": "))
|
|
|
456 (cond ((memq selector '(more-chars-than more-lines-than
|
|
|
457 less-chars-than less-lines-than))
|
|
|
458 (setq arg (vm-read-number prompt)))
|
|
|
459 ((eq selector 'label)
|
|
|
460 (let ((vm-completion-auto-correct nil)
|
|
|
461 (completion-ignore-case t))
|
|
|
462 (setq arg (downcase
|
|
|
463 (vm-read-string
|
|
|
464 prompt
|
|
|
465 (vm-obarray-to-string-list
|
|
|
466 vm-label-obarray)
|
|
|
467 nil)))))
|
|
|
468 (t (setq arg (read-string prompt))))))
|
|
98
|
469 (or (fboundp (intern (concat "vm-vs-" (symbol-name selector))))
|
|
|
470 (error "Invalid selector"))
|
|
0
|
471 (list selector arg)))
|
|
|
472
|
|
|
473 ;; clear away links between real and virtual folders when
|
|
|
474 ;; a vm-quit is performed in either type folder.
|
|
|
475 (defun vm-virtual-quit ()
|
|
|
476 (save-excursion
|
|
|
477 (cond ((eq major-mode 'vm-virtual-mode)
|
|
|
478 ;; don't trust blindly, user might have killed some of
|
|
|
479 ;; these buffers.
|
|
|
480 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
481 (let ((bp vm-real-buffers)
|
|
|
482 (mp vm-message-list)
|
|
|
483 (b (current-buffer))
|
|
|
484 ;; lock out interrupts here
|
|
|
485 (inhibit-quit t))
|
|
|
486 (while bp
|
|
|
487 (set-buffer (car bp))
|
|
|
488 (setq vm-virtual-buffers (delq b vm-virtual-buffers)
|
|
|
489 bp (cdr bp)))
|
|
|
490 (while mp
|
|
|
491 (vm-set-virtual-messages-of
|
|
|
492 (vm-real-message-of (car mp))
|
|
|
493 (delq (car mp) (vm-virtual-messages-of
|
|
|
494 (vm-real-message-of (car mp)))))
|
|
|
495 (setq mp (cdr mp)))))
|
|
|
496 ((eq major-mode 'vm-mode)
|
|
|
497 ;; don't trust blindly, user might have killed some of
|
|
|
498 ;; these buffers.
|
|
|
499 (setq vm-virtual-buffers
|
|
|
500 (vm-delete 'buffer-name vm-virtual-buffers t))
|
|
|
501 (let ((bp vm-virtual-buffers)
|
|
|
502 (mp vm-message-list)
|
|
|
503 vmp
|
|
|
504 (b (current-buffer))
|
|
|
505 ;; lock out interrupts here
|
|
|
506 (inhibit-quit t))
|
|
|
507 (while mp
|
|
|
508 (setq vmp (vm-virtual-messages-of (car mp)))
|
|
|
509 (while vmp
|
|
|
510 ;; we'll clear these messages from the virtual
|
|
|
511 ;; folder by looking for messages that have a "Q"
|
|
|
512 ;; id number associated with them.
|
|
|
513 (vm-set-message-id-number-of (car vmp) "Q")
|
|
|
514 (setq vmp (cdr vmp)))
|
|
|
515 (vm-set-virtual-messages-of (car mp) nil)
|
|
|
516 (setq mp (cdr mp)))
|
|
|
517 (while bp
|
|
|
518 (set-buffer (car bp))
|
|
|
519 (setq vm-real-buffers (delq b vm-real-buffers))
|
|
|
520 ;; set the message pointer to a new value if it is
|
|
|
521 ;; now invalid.
|
|
98
|
522 (cond
|
|
114
|
523 ((and vm-message-pointer
|
|
|
524 (equal "Q" (vm-message-id-number-of
|
|
|
525 (car vm-message-pointer))))
|
|
98
|
526 (vm-garbage-collect-message)
|
|
|
527 (setq vmp vm-message-pointer)
|
|
|
528 (while (and vm-message-pointer
|
|
|
529 (equal "Q" (vm-message-id-number-of
|
|
|
530 (car vm-message-pointer))))
|
|
|
531 (setq vm-message-pointer
|
|
|
532 (cdr vm-message-pointer)))
|
|
|
533 ;; if there were no good messages ahead, try going
|
|
|
534 ;; backward.
|
|
|
535 (if (null vm-message-pointer)
|
|
|
536 (progn
|
|
|
537 (setq vm-message-pointer vmp)
|
|
|
538 (while (and vm-message-pointer
|
|
|
539 (equal "Q" (vm-message-id-number-of
|
|
|
540 (car vm-message-pointer))))
|
|
|
541 (setq vm-message-pointer
|
|
|
542 (vm-reverse-link-of
|
|
|
543 (car vm-message-pointer))))))))
|
|
0
|
544 ;; expunge the virtual messages associated with
|
|
|
545 ;; real messages that are going away.
|
|
|
546 (setq vm-message-list
|
|
|
547 (vm-delete (function
|
|
|
548 (lambda (m)
|
|
|
549 (equal "Q" (vm-message-id-number-of m))))
|
|
|
550 vm-message-list nil))
|
|
|
551 (if (null vm-message-pointer)
|
|
|
552 (setq vm-message-pointer vm-message-list))
|
|
|
553 ;; same for vm-last-message-pointer
|
|
|
554 (if (null vm-last-message-pointer)
|
|
|
555 (setq vm-last-message-pointer nil))
|
|
|
556 (vm-clear-virtual-quit-invalidated-undos)
|
|
|
557 (vm-reverse-link-messages)
|
|
|
558 (vm-set-numbering-redo-start-point t)
|
|
|
559 (vm-set-summary-redo-start-point t)
|
|
|
560 (if vm-message-pointer
|
|
|
561 (vm-preview-current-message)
|
|
|
562 (vm-update-summary-and-mode-line))
|
|
|
563 (setq bp (cdr bp))))))))
|
|
|
564
|
|
|
565 (defun vm-virtual-save-folder (prefix)
|
|
|
566 (save-excursion
|
|
|
567 ;; don't trust blindly, user might have killed some of
|
|
|
568 ;; these buffers.
|
|
|
569 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
570 (let ((bp vm-real-buffers))
|
|
|
571 (while bp
|
|
|
572 (set-buffer (car bp))
|
|
|
573 (vm-save-folder prefix)
|
|
|
574 (setq bp (cdr bp)))))
|
|
|
575 (vm-set-buffer-modified-p nil)
|
|
|
576 (vm-clear-modification-flag-undos)
|
|
|
577 (vm-update-summary-and-mode-line))
|
|
|
578
|
|
|
579 (defun vm-virtual-get-new-mail ()
|
|
|
580 (save-excursion
|
|
|
581 ;; don't trust blindly, user might have killed some of
|
|
|
582 ;; these buffers.
|
|
|
583 (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t))
|
|
|
584 (let ((bp vm-real-buffers))
|
|
|
585 (while bp
|
|
|
586 (set-buffer (car bp))
|
|
|
587 (condition-case error-data
|
|
|
588 (vm-get-new-mail)
|
|
|
589 (folder-read-only
|
|
|
590 (message "Folder is read only: %s"
|
|
|
591 (or buffer-file-name (buffer-name)))
|
|
|
592 (sit-for 1))
|
|
|
593 (unrecognized-folder-type
|
|
|
594 (message "Folder type is unrecognized: %s"
|
|
|
595 (or buffer-file-name (buffer-name)))
|
|
|
596 (sit-for 1)))
|
|
|
597 (setq bp (cdr bp)))))
|
|
|
598 (vm-emit-totals-blurb))
|
|
|
599
|
|
|
600 (defun vm-make-virtual-copy (m)
|
|
|
601 (widen)
|
|
|
602 (let ((virtual-buffer (current-buffer))
|
|
|
603 (real-m (vm-real-message-of m))
|
|
|
604 (buffer-read-only nil)
|
|
|
605 (modified (buffer-modified-p)))
|
|
|
606 (unwind-protect
|
|
|
607 (save-excursion
|
|
|
608 (set-buffer (vm-buffer-of real-m))
|
|
|
609 (save-restriction
|
|
|
610 (widen)
|
|
|
611 ;; must reference this now so that headers will be in
|
|
|
612 ;; their final position before the message is copied.
|
|
|
613 ;; otherwise the vheader offset computed below will be wrong.
|
|
|
614 (vm-vheaders-of real-m)
|
|
|
615 (copy-to-buffer virtual-buffer (vm-start-of real-m)
|
|
|
616 (vm-end-of real-m))))
|
|
|
617 (set-buffer-modified-p modified))
|
|
|
618 (set-marker (vm-start-of m) (point-min))
|
|
|
619 (set-marker (vm-headers-of m) (+ (vm-start-of m)
|
|
|
620 (- (vm-headers-of real-m)
|
|
|
621 (vm-start-of real-m))))
|
|
|
622 (set-marker (vm-vheaders-of m) (+ (vm-start-of m)
|
|
|
623 (- (vm-vheaders-of real-m)
|
|
|
624 (vm-start-of real-m))))
|
|
|
625 (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m)
|
|
|
626 (vm-start-of real-m))))
|
|
|
627 (set-marker (vm-text-end-of m) (+ (vm-start-of m)
|
|
|
628 (- (vm-text-end-of real-m)
|
|
|
629 (vm-start-of real-m))))
|
|
|
630 (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m)
|
|
|
631 (vm-start-of real-m))))))
|
