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