cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-virtual.el

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