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