Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; 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))))))