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

   1 ;;; vm-avirtual.el --- additional functions for virtual folder selectors
   2 ;;
   3 ;; Copyright (C) 2000-2006 Robert Widhopf-Fenk
   4 ;;
   5 ;; Author:      Robert Widhopf-Fenk
   6 ;; Status:      Tested with XEmacs 21.4.19 & VM 7.19
   7 ;; Keywords:    VM, virtual folders
   8 ;; X-URL:       http://www.robf.de/Hacking/elisp
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2 of the License, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License along
  21 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  22 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  23
  24 ;;; Commentary:
  25 ;;
  26 ;; Virtual folders are one of the greatest features offered by VM, however
  27 ;; sometimes I do not want do visit a virtual folder in order to do something
  28 ;; on messages.  E.g. I have a virtual folder selector for spam messages and I
  29 ;; want VM to mark those messages matching the selector for deletion when
  30 ;; retrieving new messages.  This can be done with a trick described in
  31 ;; the VM-FAQ, however this created two new buffers polluting my buffer space.
  32 ;; So this package provides a function `vm-auto-delete-messages' for this
  33 ;; purpose without drawbacks.
  34 ;;
  35 ;; Then after I realized I was maintaining three different variables for
  36 ;; actually the same things.  They were `vm-auto-folder-alist' for automatic
  37 ;; selection of folders when saving messages, `vm-virtual-folder-alist' for my
  38 ;; loved virtual folders and `vmpc-conditions' in order to solve the handling
  39 ;; of my different email-addresses.
  40 ;;
  41 ;; This was kind of annoying, since virtual folder selector offer the best
  42 ;; way of specifying conditions, but they only work on messages within
  43 ;; folders and not on messages which are currently composed. So I decided to
  44 ;; extent virtual folder selectors also to message composing, although not
  45 ;; all of the selectors are meaning full for `mail-mode'.
  46 ;;
  47 ;; I wrote functions which can replace (*) the existing ones and others that
  48 ;; add new (+) functionality.  Finally I came up with the following ones:
  49 ;;       * vm-virtual-auto-archive-messages
  50 ;;       * vm-virtual-save-message
  51 ;;       * vmpc-check-virtual-selector
  52 ;;       + vm-virtual-auto-delete-messages
  53 ;;       + vm-virtual-auto-delete-message
  54 ;;       + vm-virtual-omit-message
  55 ;;       + vm-virtual-update-folders
  56 ;;       + vm-virtual-apply-function
  57 ;; and the following variables
  58 ;;      vm-virtual-check-case-fold-search
  59 ;;      vm-virtual-auto-delete-message-selector
  60 ;;      vm-virtual-auto-folder-alist
  61 ;;      vm-virtual-message
  62 ;; and a couple of new selectors
  63 ;;      mail-mode       if in mail-mode evals its `argument' else `nil'
  64 ;;      vm-mode         if in vm-mode evals its `arg' else `nil'
  65 ;;      eval            evaluates its `arg' (write own complex selectors)
  66 ;;      older-than      returns `t' is a message is older than `arg' days
  67 ;;
  68 ;; So by using theses new features I can maintain just one selector for
  69 ;; e.g. my private email-address and get the right folder for saving messages,
  70 ;; visiting the corresponding virtual folders, auto archiving, setting the FCC
  71 ;; header and setting up `vmpc-conditions'.  Do you know a mailer than can
  72 ;; beet this?
  73 ;;
  74 ;; My default selector for spam messages:
  75 ;;
  76 ;; ("spam" ("received")
  77 ;;  (vm-mode
  78 ;;   (and (new) (undeleted)
  79 ;;        (or
  80 ;;         ;; kill all those where all authors/recipients
  81 ;;         ;; are unknown to my BBDB, i.e. messages from
  82 ;;         ;; strangers which are not directed to me!
  83 ;;         ;; (c't 12/2001)
  84 ;;         (not (in-bbdb))
  85 ;;         ;; authors that I do not know
  86 ;;         (and (not (in-bbdb authors))
  87 ;;              (or
  88 ;;               ;;  with bad content
  89 ;;               (spam-word)
  90 ;;               ;; they hide ID codes by long subjects
  91 ;;               (subject "       ")
  92 ;;               ;; HTML only messages
  93 ;;               (header "^Content-Type: text/html")
  94 ;;               ;; for 8bit encoding "chinese" spam
  95 ;;               (header "[¡-ÿ][¡-ÿ][¡-ÿ][¡-ÿ]")
  96 ;;               ;; for qp-encoding "chinese" spam
  97 ;;               (header "=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]=[A-F][0-9A-F]")
  98 ;;               ))))))
  99 ;;
 100 ;;; Feel free to sent me any comments or bug reports.
 101 ;;
 102 ;;; Code:
 103
 104 (require 'vm-virtual)
 105
 106 (defgroup vm nil
 107   "VM"
 108   :group 'mail)
 109
 110 (defgroup vm-avirtual nil
 111   "VM additional virtual folder selectors and functions."
 112   :group 'vm)
 113
 114 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 115 (eval-when-compile
 116   (require 'cl))
 117
 118 (eval-and-compile
 119   (require 'advice)
 120   (require 'regexp-opt)
 121   (require 'vm-version)
 122   (require 'vm-message)
 123   (require 'vm-macro)
 124   (require 'vm-vars)
 125   (require 'time-date)
 126
 127   (let ((feature-list '(bbdb bbdb-autoloads bbdb-com)))
 128     (while feature-list
 129       (condition-case nil
 130           (require (car feature-list))
 131         (error
 132          (if (load (format "%s\n" (car feature-list)) t)
 133              (message "Library %s loaded!" (car feature-list))
 134            (message "Could not load feature %S.  Related functions may not work correctly!" (car feature-list))
 135            (beep 1))))
 136       (setq feature-list (cdr feature-list)))))
 137
 138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 139 (defvar vm-mail-virtual-selector-function-alist
 140   '(;; standard selectors
 141     (and . vm-mail-vs-and)
 142     (or . vm-mail-vs-or)
 143     (not . vm-mail-vs-not)
 144     (any . vm-mail-vs-any)
 145     (header . vm-mail-vs-header)
 146     (text . vm-mail-vs-text)
 147     (header-or-text . vm-mail-vs-header-or-text)
 148     (recipient . vm-mail-vs-recipient)
 149     (author . vm-mail-vs-author)
 150     (author-or-recipient . vm-mail-vs-author-or-recipient)
 151     (subject . vm-mail-vs-subject)
 152     (sortable-subject . vm-mail-vs-sortable-subject)
 153     (more-chars-than . vm-mail-vs-more-chars-than)
 154     (less-chars-than . vm-mail-vs-less-chars-than)
 155     (more-lines-than . vm-mail-vs-more-lines-than)
 156     (less-lines-than . vm-mail-vs-less-lines-than)
 157     (replied . vm-mail-vs-replied)
 158     (answered . vm-mail-vs-answered)
 159     (forwarded . vm-mail-vs-forwarded)
 160     (redistributed . vm-mail-vs-redistributed)
 161     (unreplied . vm-mail-vs-unreplied)
 162     (unanswered . vm-mail-vs-unanswered)
 163     (unforwarded . vm-mail-vs-unforwarded)
 164     (unredistributed . vm-mail-vs-unredistributed)
 165
 166     ;; unknown selectors which return always nil
 167     (new . vm-mail-vs-unknown)
 168     (unread . vm-mail-vs-unknown)
 169     (read . vm-mail-vs-unknown)
 170     (unseen . vm-mail-vs-unknown)
 171     (recent . vm-mail-vs-unknown)
 172     (deleted . vm-mail-vs-unknown)
 173     (filed . vm-mail-vs-unknown)
 174     (written . vm-mail-vs-unknown)
 175     (edited . vm-mail-vs-unknown)
 176     (marked . vm-mail-vs-unknown)
 177     (undeleted . vm-mail-vs-unknown)
 178     (unfiled . vm-mail-vs-unknown)
 179     (unwritten . vm-mail-vs-unknown)
 180     (unedited . vm-mail-vs-unknown)
 181     (unmarked . vm-mail-vs-unknown)
 182     (virtual-folder-member . vm-mail-vs-unknown)
 183     (label . vm-mail-vs-unknown)
 184     (sent-before . vm-mail-vs-unknown)
 185     (sent-after . vm-mail-vs-unknown)
 186
 187
 188     ;; new selectors
 189     (mail-mode . vm-mail-vs-mail-mode)
 190     (vm-mode . vm-vs-vm-mode)
 191     (eval . vm-mail-vs-eval)
 192     (older-than . vm-mail-vs-older-than)
 193     (in-bbdb . vm-mail-vs-in-bbdb)
 194     ))
 195
 196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 197 (defun vm-avirtual-add-selectors (selectors)
 198   (let ((alist 'vm-virtual-selector-function-alist)
 199         (sup-alist 'vm-supported-interactive-virtual-selectors)
 200         sel)
 201
 202     (while selectors
 203       (setq sel (car selectors))
 204       (add-to-list alist (cons sel (intern (format "vm-vs-%s" sel))))
 205       (add-to-list sup-alist (list (format "%s" sel)))
 206       (setq selectors (cdr selectors)))))
 207
 208 (vm-avirtual-add-selectors
 209  '(mail-mode
 210    vm-mode
 211    eval
 212    older-than
 213    outgoing
 214    selected
 215    in-bbdb
 216    uninteresting-senders
 217    spam-word
 218    folder-name
 219    attachment
 220    spam-level
 221    spam-score))
 222
 223 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 224 ;; we redefine the basic selectors for some extra features ...
 225
 226 (defcustom vm-virtual-check-case-fold-search t
 227   "Wheater to use case-fold-search or not when applying virtual selectors.
 228 I was really missing this!"
 229   :type 'boolean
 230   :group 'vm-avirtual)
 231
 232 (defcustom vm-virtual-check-diagnostics nil
 233   "When set to nil we will display messages on matching selectors."
 234   :type 'boolean
 235   :group 'vm-avirtual)
 236
 237 (defvar vm-virtual-check-level 0)
 238
 239 (defun vm-vs-or (m &rest selectors)
 240   (let ((case-fold-search vm-virtual-check-case-fold-search)
 241         (vm-virtual-check-level (+ 2 vm-virtual-check-level))
 242         (result nil) selector arglist function)
 243     (while selectors
 244       (setq selector (car (car selectors))
 245             function (cdr (assq selector vm-virtual-selector-function-alist)))
 246       (setq arglist (cdr (car selectors))
 247             arglist (cdr (car selectors))
 248             result (apply function m arglist)
 249             selectors (if result nil (cdr selectors)))
 250       (if vm-virtual-check-diagnostics
 251           (princ (format "%sor: %s (%S%s)\n"
 252                          (make-string vm-virtual-check-level ? )
 253                          (if result t nil) selector
 254                          (if arglist (format " %S" arglist) "")))))
 255     result))
 256
 257 (defun vm-vs-and (m &rest selectors)
 258   (let ((vm-virtual-check-level (+ 2 vm-virtual-check-level))
 259         (result t) selector arglist function)
 260     (while selectors
 261       (setq selector (car (car selectors))
 262             function (cdr (assq selector vm-virtual-selector-function-alist)))
 263       (if (null function)
 264           (error "Invalid selector"))
 265       (setq arglist (cdr (car selectors))
 266             result (apply function m arglist)
 267             selectors (if (null result) nil (cdr selectors)))
 268       (if vm-virtual-check-diagnostics
 269           (princ (format "%sand: %s (%S%s)\n"
 270                          (make-string vm-virtual-check-level ? )
 271                          (if result t nil) selector
 272                          (if arglist (format " %S" arglist) "")))))
 273     result))
 274
 275 (defun vm-vs-not (m arg)
 276   (let ((vm-virtual-check-level (+ 2 vm-virtual-check-level))
 277         (selector (car arg))
 278         (arglist (cdr arg))
 279         result)
 280     (setq result
 281           (apply (cdr (assq selector vm-virtual-selector-function-alist))
 282                  m arglist))
 283     (if vm-virtual-check-diagnostics
 284         (princ (format "%snot: %s for (%S%s)\n"
 285                        (make-string vm-virtual-check-level ? )
 286                        (if result t nil) selector
 287                        (if arglist (format " %S" arglist) ""))))
 288     (not result)))
 289
 290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 291 ;;;###autoload
 292 (defun vm-avirtual-check-for-missing-selectors (&optional arg)
 293   "Check if there are selectors missing for either vm-mode or mail-mode."
 294   (interactive "P")
 295   (let ((a (if arg vm-mail-virtual-selector-function-alist
 296              vm-virtual-selector-function-alist))
 297         (b (mapcar (lambda (s) (car s))
 298                    (if arg vm-virtual-selector-function-alist
 299                      vm-mail-virtual-selector-function-alist)))
 300         l)
 301     (while a
 302       (if (not (memq (caar a) b))
 303           (setq l (concat (format "%s" (caar a)) ", " l)))
 304       (setq a (cdr a)))
 305     (if l
 306         (message "Selectors %s are missing!" l)
 307       (message "No selectors are missing!"))))
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 310 ;; new virtual folder selectors
 311 (defvar vm-virtual-message nil
 312   "Set to the VM message vector when doing a `vm-vs-eval'.")
 313
 314 (defcustom vm-vs-attachment-regexp "^Content-Disposition: attachment"
 315   "Regexp used to detect attachments in an message."
 316   :group 'vm-avirtual
 317   :type 'regexp)
 318
 319 (defun vm-vs-attachment (m)
 320   (vm-vs-text m vm-vs-attachment-regexp))
 321
 322 (defun vm-vs-folder-name (m regexp)
 323   (setq m (vm-real-message-of m))
 324   (string-match regexp (buffer-name (marker-buffer (vm-start-of m)))))
 325
 326 (defun vm-vs-eval (&rest selectors)
 327   (let ((vm-virtual-message (car selectors)))
 328     (eval (cadr selectors))))
 329
 330 (defun vm-vs-vm-mode (&rest selectors)
 331   (if (not (equal major-mode 'mail-mode))
 332       (apply 'vm-vs-or selectors)
 333     nil))
 334
 335 (defun vm-vs-older-than (m arg)
 336   (let ((date (vm-get-header-contents m "Date:")))
 337     (if date
 338         (> (days-between (current-time-string) date) arg))))
 339
 340 (defun vm-vs-outgoing (m)
 341   (and vm-summary-uninteresting-senders
 342        (or (string-match vm-summary-uninteresting-senders (vm-su-full-name m))
 343            (string-match vm-summary-uninteresting-senders (vm-su-from m)))))
 344
 345 (defun vm-vs-selected (m)
 346   (save-excursion
 347     (vm-select-folder-buffer)
 348     (eq m (car vm-message-pointer))))
 349
 350 (defun vm-vs-uninteresting-senders (m)
 351   (string-match vm-summary-uninteresting-senders
 352                 (vm-get-header-contents m "From:")))
 353
 354 (defun vm-vs-in-bbdb (m &optional address-class only-first)
 355   "check if one of the email addresses from the mail is known."
 356   (let (bbdb-user-mail-names)
 357     (let* ((bbdb-get-only-first-address-p only-first)
 358            (bbdb-user-mail-names nil)
 359            (bbdb-get-addresses-headers
 360             (if address-class
 361                 (or (list (assoc address-class bbdb-get-addresses-headers))
 362                     (error "no such address class"))
 363               bbdb-get-addresses-headers))
 364            (addresses (bbdb-get-addresses nil nil
 365                                           'bbdb/vm-get-header-content
 366                                           (vm-real-message-of m)))
 367            (done nil)
 368            addr)
 369       (while (and (not done) addresses)
 370         (setq addr (caddar addresses)
 371               addresses (cdr addresses))
 372         (let ((name (car addr))
 373               (net  (cadr addr)))
 374           (setq done (or (bbdb-search-simple nil net)
 375                          (bbdb-search-simple name nil)))))
 376       done)))
 377
 378 (defun vm-mail-vs-in-bbdb (&optional address-class only-first)
 379   "check if one of the email addresses from the mail is known."
 380   (let (bbdb-user-mail-names)
 381     (let* ((bbdb-get-only-first-address-p only-first)
 382            (bbdb-user-mail-names nil)
 383            (bbdb-get-addresses-headers
 384             (if address-class
 385                 (or (list (assoc address-class bbdb-get-addresses-headers))
 386                     (error "no such address class"))
 387               bbdb-get-addresses-headers))
 388            (addresses (bbdb-get-addresses nil nil
 389                                           'vm-mail-mode-get-header-contents))
 390            (done nil)
 391            addr)
 392       (while (and (not done) addresses)
 393         (setq addr (caddar addresses)
 394               addresses (cdr addresses))
 395         (let ((name (car addr))
 396               (net  (cadr addr)))
 397           (setq done (or (bbdb-search-simple nil net)
 398                          (bbdb-search-simple name nil)))))
 399       done)))
 400
 401 (defvar vm-spam-words nil
 402   "A list of words often contained in spam messages.")
 403
 404 (defvar vm-spam-words-regexp nil
 405   "A regexp matching those words in `vm-spam-words'.")
 406
 407 (defcustom vm-spam-words-file
 408   (expand-file-name "~/.spam-words")
 409   "A file storing a list of words contained in spam messages."
 410   :group 'vm-avirtual
 411   :type 'file)
 412
 413 (defun vm-vs-spam-word (m &optional selector)
 414   (if (and (not vm-spam-words)
 415            vm-spam-words-file
 416            (file-readable-p vm-spam-words-file)
 417            (not (get-file-buffer vm-spam-words-file)))
 418       (save-excursion
 419         (set-buffer (find-file-noselect vm-spam-words-file))
 420         (goto-char (point-min))
 421         (while (re-search-forward "^\\s-*\\([^#;].*\\)\\s-*$" (point-max) t)
 422           (setq vm-spam-words (cons (match-string 1) vm-spam-words)))
 423         (setq vm-spam-words-regexp (regexp-opt vm-spam-words))))
 424   (if (and m vm-spam-words-regexp)
 425       (let ((case-fold-search t))
 426         (cond ((eq selector 'header)
 427                (vm-vs-header m vm-spam-words-regexp))
 428               ((eq selector 'header-or-text)
 429                (vm-vs-header-or-text m vm-spam-words-regexp))
 430               (t
 431                (vm-vs-text m vm-spam-words-regexp))))))
 432
 433 ;;;###autoload
 434 (defun vm-add-spam-word (word)
 435   "Add a new word to the list of spam words."
 436   (interactive (list (if (region-active-p)
 437                          (buffer-substring (point) (mark))
 438                        (read-string "Spam word: "))))
 439   (save-excursion
 440     (when (not (member word vm-spam-words))
 441       (if (get-file-buffer vm-spam-words-file)
 442           (set-buffer (get-file-buffer vm-spam-words-file))
 443         (set-buffer (find-file-noselect vm-spam-words-file)))
 444       (goto-char (point-max))
 445       ;; if the last character is no newline, then append one!
 446       (if (and (not (= (point) (point-min)))
 447                (save-excursion
 448                  (backward-char 1)
 449                  (not (looking-at "\n"))))
 450           (insert "\n"))
 451       (insert word)
 452       (save-buffer)
 453       (setq vm-spam-words (cons word vm-spam-words))
 454       (setq vm-spam-words-regexp (regexp-opt vm-spam-words)))))
 455
 456 ;;;###autoload
 457 (defun vm-spam-words-rebuild ()
 458   "Discharge the internal cached data about spam words."
 459   (interactive)
 460   (setq vm-spam-words nil
 461         vm-spam-words-regexp nil)
 462   (if (get-file-buffer vm-spam-words-file)
 463       (kill-buffer (get-file-buffer vm-spam-words-file)))
 464   (vm-vs-spam-word nil)
 465   (message "%d spam words are installed!" (length vm-spam-words)))
 466
 467 (defcustom vm-vs-spam-score-headers
 468   '(("X-Spam-Score:"  "[-+]?[0-9]*\\.?[0-9]+"  string-to-number)
 469     ("X-Spam-Status:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number)
 470     ("X-Spam-Level:"  "\\*+"     length))
 471   "A list of headers to look for spam scores."
 472   :group 'vm-avirtual
 473   :type '(repeat (list (string :tag "Header regexp")
 474                        (regexp :tag "Regexp matching the score")
 475                        (function :tag "Function converting the score to a number"))))
 476
 477 (defun vm-vs-spam-score (m min &optional max)
 478   "True when the spam score is >= MIN and optionally <= MAX.
 479 The headers that will be checked are those listed in `vm-vs-spam-score-headers'."
 480   (let ((spam-headers vm-vs-spam-score-headers)
 481         it-is-spam)
 482     (while spam-headers
 483       (let* ((spam-selector (car spam-headers))
 484              (score (vm-get-header-contents m (car spam-selector))))
 485         (when (and score (string-match (nth 1 spam-selector) score))
 486           (setq score (funcall (nth 2 spam-selector) (match-string 0 score)))
 487           (if (and (<= min score) (if max (<= score max) t))
 488               (setq it-is-spam t spam-headers nil))))
 489       (setq spam-headers (cdr spam-headers)))
 490     it-is-spam))
 491
 492 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 493 ;; new mail virtual folder selectors
 494
 495 (defun vm-mail-vs-eval (&rest selectors)
 496   (eval (cadr selectors)))
 497
 498 (defun vm-mail-vs-mail-mode (&rest selectors)
 499   (if (equal major-mode 'mail-mode)
 500       (apply 'vm-mail-vs-or selectors)
 501     nil))
 502
 503 (defalias 'vm-vs-mail-mode 'vm-mail-vs-mail-mode)
 504
 505 (defun vm-mail-vs-or (&rest selectors)
 506   (let ((result nil) selector arglist
 507         (case-fold-search vm-virtual-check-case-fold-search))
 508     (while selectors
 509       (setq selector (car (car selectors))
 510             arglist (cdr (car selectors))
 511             result (apply (cdr (assq selector
 512                                      vm-mail-virtual-selector-function-alist))
 513                           arglist)
 514             selectors (if result nil (cdr selectors)))
 515       (if vm-virtual-check-diagnostics
 516           (princ (format "%sor: %s (%S%s)\n"
 517                          (make-string vm-virtual-check-level ? )
 518                          (if result t nil) selector
 519                          (if arglist (format " %S" arglist) "")))))
 520     result))
 521
 522 (defun vm-mail-vs-and (&rest selectors)
 523   (let ((result t) selector arglist)
 524     (while selectors
 525       (setq selector (car (car selectors))
 526             arglist (cdr (car selectors))
 527             result (apply (cdr (assq selector
 528                                      vm-mail-virtual-selector-function-alist))
 529                           arglist)
 530             selectors (if (null result) nil (cdr selectors)))
 531       (if vm-virtual-check-diagnostics
 532           (princ (format "%sand: %s (%S%s)\n"
 533                          (make-string vm-virtual-check-level ? )
 534                          (if result t nil) selector
 535                          (if arglist (format " %S" arglist) "")))))
 536     result))
 537
 538 (defun vm-mail-vs-not (arg)
 539   (let ((selector (car arg))
 540         (arglist (cdr arg))
 541         result)
 542     (setq result (apply (cdr (assq selector vm-mail-virtual-selector-function-alist))
 543                         arglist))
 544     (if vm-virtual-check-diagnostics
 545         (princ (format "%snot: %s for (%S%s)\n"
 546                        (make-string vm-virtual-check-level ? )
 547                        (if result t nil) selector
 548                        (if arglist (format " %S" arglist) ""))))
 549     (not result)))
 550
 551 ;; return just nil for those selectors not known for mail-mode
 552 (defun vm-mail-vs-unknown (&optional arg)
 553   nil)
 554
 555 (defun vm-mail-vs-any ()
 556   t)
 557
 558 (defun vm-mail-vs-author (arg)
 559   (let ((val (vm-mail-mode-get-header-contents "Sender\\|From:")))
 560     (and val (string-match arg val))))
 561
 562 (defun vm-mail-vs-recipient (arg)
 563   (let (val)
 564     (or
 565      (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?To:"))
 566           (string-match arg val))
 567      (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?CC:"))
 568           (string-match arg val))
 569      (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?BCC:"))
 570           (string-match arg val)))))
 571
 572 (defun vm-mail-vs-author-or-recipient (arg)
 573   (or (vm-mail-vs-author arg)
 574       (vm-mail-vs-recipient arg)))
 575
 576 (defun vm-mail-vs-subject (arg)
 577   (let ((val (vm-mail-mode-get-header-contents "Subject:")))
 578     (and val (string-match arg val))))
 579
 580 (defun vm-mail-vs-sortable-subject (arg)
 581   (let ((case-fold-search t)
 582         (subject (vm-mail-mode-get-header-contents "Subject:")))
 583     (when subject
 584       (if (and vm-subject-ignored-prefix
 585                (string-match vm-subject-ignored-prefix subject)
 586                (zerop (match-beginning 0)))
 587           (setq subject (substring subject (match-end 0))))
 588       (if (and vm-subject-ignored-suffix
 589                (string-match vm-subject-ignored-suffix subject)
 590                (= (match-end 0) (length subject)))
 591           (setq subject (substring subject 0 (match-beginning 0))))
 592       (setq subject (vm-with-string-as-temp-buffer
 593                      subject
 594                      (function vm-collapse-whitespace)))
 595       (if (and vm-subject-significant-chars
 596                (natnump vm-subject-significant-chars)
 597                (< vm-subject-significant-chars (length subject)))
 598           (setq subject
 599                 (substring subject 0 vm-subject-significant-chars)))
 600       (string-match arg subject))))
 601
 602 (defun vm-mail-vs-header (arg)
 603   (save-excursion
 604     (let ((start (point-min)) end)
 605       (goto-char start)
 606       (search-forward (concat "\n" mail-header-separator "\n"))
 607       (setq end (match-beginning 0))
 608       (goto-char start)
 609       (re-search-forward arg end t))))
 610
 611 (defun vm-mail-vs-text (arg)
 612   (save-excursion
 613     (goto-char (point-min))
 614     (search-forward (concat "\n" mail-header-separator "\n"))
 615     (re-search-forward arg (point-max) t)))
 616
 617 (defun vm-mail-vs-header-or-text (arg)
 618   (save-excursion
 619     (goto-char (point-min))
 620     (re-search-forward arg (point-max) t)))
 621
 622 (defun vm-mail-vs-more-chars-than (arg)
 623   (> (- (point-max) (point-min) (length mail-header-separator) 2) arg))
 624
 625 (defun vm-mail-vs-less-chars-than (arg)
 626   (< (- (point-max) (point-min) (length mail-header-separator) 2) arg))
 627
 628 (defun vm-mail-vs-more-lines-than (arg)
 629   (> (- (count-lines (point-min) (point-max)) 1) arg))
 630
 631 (defun vm-mail-vs-less-lines-than (arg)
 632   (< (- (count-lines (point-min) (point-max)) 1) arg))
 633
 634 (defun vm-mail-vs-replied ()
 635   vm-reply-list)
 636 (fset 'vm-mail-vs-answered 'vm-mail-vs-replied)
 637
 638 (defun vm-mail-vs-forwarded ()
 639   vm-forward-list)
 640
 641 (defun vm-mail-vs-redistributed ()
 642   (vm-mail-mode-get-header-contents "Resent-[^:]+:"))
 643
 644 (defun vm-mail-vs-unreplied ()
 645   (not (vm-mail-vs-forwarded )))
 646 (fset 'vm-mail-vs-unanswered 'vm-mail-vs-unreplied)
 647
 648 (defun vm-mail-vs-unforwarded ()
 649   (not (vm-mail-vs-forwarded )))
 650
 651 (defun vm-mail-vs-unredistributed ()
 652   (not (vm-mail-vs-redistributed )))
 653
 654 (defun vm-mail-vs-older-than (arg)
 655   (let* ((date (vm-mail-mode-get-header-contents "Date:"))
 656          (days (and date (days-between (current-time-string) date))))
 657     (and days (> days arg))))
 658
 659 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 660 (defun vm-virtual-get-selector-member (folder-name folder-list)
 661   (let (match )
 662     (while folder-list
 663       (if (string-match (car folder-list) folder-name)
 664           (setq folder-list nil
 665                 match t))
 666       (setq folder-list (cdr folder-list)))
 667     match))
 668
 669 ;;;###autoload
 670 (defun vm-virtual-get-selector (vfolder &optional valid-folder-list)
 671   "Return the selector of virtual folder VFOLDER for VALID-FOLDER-LIST."
 672   (interactive
 673    (list (vm-read-string "Virtual folder: " vm-virtual-folder-alist)
 674          (if (equal major-mode 'mail-mode) nil
 675            (list (save-excursion (vm-select-folder-buffer)
 676                                  (buffer-name))))))
 677
 678   (let ((sels (assoc vfolder vm-virtual-folder-alist))
 679         selector folder-name)
 680     (setq sels (and sels (cadr sels)))
 681
 682     (when sels
 683       (if (not valid-folder-list)
 684           (setq selector (append (cdr sels) selector))
 685         (setq folder-name valid-folder-list)
 686         (while folder-name
 687           (if (vm-virtual-get-selector-member (car folder-name) (car sels))
 688               (setq selector (append (cdr sels) selector)))
 689           (setq folder-name (cdr folder-name)))))
 690
 691     selector))
 692
 693 ;;;###autoload
 694 (defun vm-virtual-check-selector (selector &optional msg virtual)
 695   "Return t if SELECTOR matches the message MSG.
 696 If VIRTUAL is true we check the current message and not the real one."
 697   (if msg
 698       (if virtual
 699           (apply 'vm-vs-or msg selector)
 700         (save-excursion
 701           (set-buffer (vm-buffer-of (vm-real-message-of msg)))
 702           (apply 'vm-vs-or msg selector)))
 703     (if (eq major-mode 'mail-mode)
 704         (apply 'vm-mail-vs-or selector))))
 705
 706 ;;;###autoload
 707 (defun vm-virtual-check-selector-interactive (selector &optional diagnostics)
 708   "Return t if SELECTOR matches the current message.
 709 Called with an prefix argument we display more diagnostics about the selector
 710 evaluation.  Information is displayed in the order of evaluation and indented
 711 according to the level of recursion. The displayed information is has the
 712 format:
 713         FATHER-SELECTOR: RESULT CHILD-SELECTOR"
 714   (interactive
 715    (list  (vm-read-string "Virtual folder: " vm-virtual-folder-alist)
 716           current-prefix-arg))
 717   (save-excursion
 718     (vm-select-folder-buffer)
 719     (vm-error-if-folder-empty)
 720     (vm-follow-summary-cursor)
 721     (let ((msg (car vm-message-pointer))
 722           (virtual (eq major-mode 'vm-virtual-mode))
 723           (vm-virtual-check-diagnostics (or vm-virtual-check-diagnostics
 724                                             diagnostics)))
 725       (with-output-to-temp-buffer "*VM virtual-folder-check*"
 726        (save-excursion
 727          (set-buffer "*VM virtual-folder-check*")
 728          (toggle-truncate-lines t))
 729         (princ (format "Checking %S on <%s> from %s\n\n" selector
 730                        (vm-su-subject msg) (vm-su-from msg)))
 731         (princ (format "\nThe virtual folder selector `%s' is %s!\n"
 732                        selector
 733                        (if (vm-virtual-check-selector
 734                             (vm-virtual-get-selector selector)
 735                             msg virtual)
 736                            "true"
 737                          "false")))))))
 738
 739 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 740 (defvar vmpc-current-state nil)
 741 ;;;###autoload
 742 (defun vmpc-virtual-check-selector (selector &optional folder-list)
 743   "Checks SELECTOR based on the state of vmpc on the original or current."
 744   (setq selector (vm-virtual-get-selector selector folder-list))
 745   (if (null selector)
 746       (error "no virtual folder %s!!" selector))
 747   (cond ((or (eq vmpc-current-state 'reply)
 748              (eq vmpc-current-state 'forward)
 749              (eq vmpc-current-state 'resend))
 750          (vm-virtual-check-selector selector (car vm-message-pointer)))
 751         ((eq vmpc-current-state 'automorph)
 752          (vm-virtual-check-selector selector))))
 753
 754 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 755 ;;;###autoload
 756 (defun vm-virtual-apply-function (count &optional selector function)
 757   "Apply a FUNCTION to the next COUNT messages matching SELECTOR."
 758   (interactive "p")
 759   (when (interactive-p)
 760       (vm-follow-summary-cursor)
 761       (setq selector (vm-virtual-get-selector
 762                       (vm-read-string "Virtual folder: "
 763                                       vm-virtual-folder-alist))
 764             function (key-or-menu-binding (read-key-sequence "VM command: "))))
 765
 766   (vm-select-folder-buffer)
 767   (vm-check-for-killed-summary)
 768   (vm-error-if-folder-empty)
 769
 770   (let ((mlist (vm-select-marked-or-prefixed-messages (or count 1)))
 771         (count 0))
 772
 773     (while mlist
 774       (if (vm-virtual-check-selector selector (car mlist))
 775           (progn (funcall function (car mlist))
 776                  (vm-increment count)))
 777       (setq mlist (cdr mlist)))
 778
 779     count))
 780
 781 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 782 ;;;###autoload
 783 (defun vm-virtual-update-folders (&optional count message-list)
 784   "Updates all virtual folders.
 785 E.g. when creating a folder of all marked messages one can call this
 786 function in order to add newly marked messages to the virtual folder
 787 without recreating it."
 788   (interactive "p")
 789   (vm-select-folder-buffer)
 790
 791   (let ((new-messages (or message-list
 792                           (vm-select-marked-or-prefixed-messages count)))
 793         b-list)
 794     (setq new-messages (copy-sequence new-messages))
 795     (if (and new-messages vm-virtual-buffers)
 796         (save-excursion
 797           (setq b-list vm-virtual-buffers)
 798           (while b-list
 799             ;; buffer might be dead
 800             (if (buffer-name (car b-list))
 801                 (let (tail-cons)
 802                   (set-buffer (car b-list))
 803                   (setq tail-cons (vm-last vm-message-list))
 804                   (vm-build-virtual-message-list new-messages)
 805                   (if (or (null tail-cons) (cdr tail-cons))
 806                       (progn
 807                         (setq vm-ml-sort-keys nil)
 808                         (if vm-thread-obarray
 809                             (vm-build-threads (cdr tail-cons)))
 810                         (vm-set-summary-redo-start-point
 811                          (or (cdr tail-cons) vm-message-list))
 812                         (vm-set-numbering-redo-start-point
 813                          (or (cdr tail-cons) vm-message-list))
 814                         (if (null vm-message-pointer)
 815                             (progn (setq vm-message-pointer vm-message-list
 816                                          vm-need-summary-pointer-update t)
 817                                    (if vm-message-pointer
 818                                        (vm-preview-current-message))))
 819                         (setq vm-messages-needing-summary-update new-messages
 820                               vm-need-summary-pointer-update t)
 821                         (vm-update-summary-and-mode-line)
 822                         (if vm-summary-show-threads
 823                             (vm-sort-messages "thread"))))))
 824             (setq b-list (cdr b-list)))))
 825     new-messages))
 826
 827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 828 ;;;###autoload
 829 (defun vm-virtual-omit-message (&optional count message-list)
 830   "Omits a meassage from a virtual folder.
 831 IMHO allowing it for real folders makes no sense.  One rather should create a
 832 virtual folder of all messages."
 833   (interactive "p")
 834   (vm-select-folder-buffer)
 835
 836   (if (not (eq major-mode 'vm-virtual-mode))
 837       (error "This is no virtual folder."))
 838
 839   (let ((old-messages (or message-list
 840                           (vm-select-marked-or-prefixed-messages count)))
 841         prev curr
 842         (mp vm-message-list))
 843
 844     (while mp
 845       (if (not (member (car mp) old-messages))
 846           nil
 847         (setq prev (vm-reverse-link-of (car mp))
 848               curr (or (cdr prev) vm-message-list))
 849         (vm-set-numbering-redo-start-point (or prev t))
 850         (vm-set-summary-redo-start-point (or prev t))
 851         (if (eq vm-message-pointer curr)
 852             (setq vm-system-state nil
 853                   vm-message-pointer (or prev (cdr curr))))
 854         (if (eq vm-last-message-pointer curr)
 855             (setq vm-last-message-pointer nil))
 856         (if (null prev)
 857             (progn
 858               (setq vm-message-list (cdr vm-message-list))
 859               (and (cdr curr)
 860                    (vm-set-reverse-link-of (car (cdr curr)) nil)))
 861           (setcdr prev (cdr curr))
 862           (and (cdr curr)
 863                (vm-set-reverse-link-of (car (cdr curr)) prev))))
 864       (setq mp (cdr mp)))
 865
 866     (vm-update-summary-and-mode-line)
 867     (if vm-summary-show-threads
 868         (vm-sort-messages "thread"))
 869     old-messages))
 870
 871 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 872
 873 (defcustom vm-virtual-auto-delete-message-selector "spam"
 874   "*Name of virtual folder selector used for automatically deleting a message.
 875 Actually they are only marked for deletion."
 876   :group 'vm-avirtual
 877   :type 'string)
 878
 879 (defcustom vm-virtual-auto-delete-message-folder nil
 880   "*When set to a folder name we save affected messages there."
 881   :group 'vm-avirtual
 882   :type '(choice (file :tag "VM folder" "spam")
 883                  (const :tag "Disabled" nil)))
 884
 885 (defcustom vm-virtual-auto-delete-message-expunge nil
 886   "*When true we expunge the affected right after marking and saving them."
 887   :group 'vm-avirtual
 888   :type 'boolean)
 889
 890 ;;;###autoload
 891 (defun vm-virtual-auto-delete-message (&optional count selector)
 892   "*Mark messages matching a virtual folder selector for deletion.
 893 The virtual folder selector can be configured by the variable
 894 `vm-virtual-auto-delete-message-selector'.
 895
 896 This function does not visit the virtual folder, but checks only the current
 897 message, therefore it is much faster and not so disturbing like the method
 898 described in the VM-FAQ.
 899
 900 In order to automatically mark spam for deletion use the function
 901 `vm-virtual-auto-delete-messages'.  See its documentation on how to hook it
 902 into VM!"
 903   (interactive "p")
 904
 905   (setq selector (or selector
 906                        (vm-virtual-get-selector
 907                         vm-virtual-auto-delete-message-selector)))
 908
 909   (let (spammlist)
 910     (setq count (vm-virtual-apply-function
 911                  count
 912                  selector
 913                  (function (lambda (msg)
 914                              (setq spammlist (cons msg spammlist))
 915                              (vm-set-labels
 916                               msg
 917                               (list
 918                                vm-virtual-auto-delete-message-selector))
 919                              (vm-set-deleted-flag msg t)
 920                              (vm-mark-for-summary-update msg t)))))
 921
 922     (when spammlist
 923       (setq spammlist (reverse spammlist))
 924       ;; save them
 925       (if vm-virtual-auto-delete-message-folder
 926           (let ((vm-arrived-messages-hook nil)
 927                 (vm-arrived-message-hook nil)
 928                 (mlist spammlist))
 929             (while mlist
 930               (let ((vm-message-pointer mlist))
 931                 (vm-save-message vm-virtual-auto-delete-message-folder))
 932               (setq mlist (cdr mlist)))))
 933       ;; expunge them
 934       (if vm-virtual-auto-delete-message-expunge
 935           (vm-expunge-folder t t spammlist)))
 936
 937     (vm-display nil nil '(vm-delete-message vm-delete-message-backward)
 938                 (list this-command))
 939
 940     (vm-update-summary-and-mode-line)
 941
 942     (message "%s message%s %s!"
 943              (if (> count 0) count "No")
 944              (if (= 1 count) "" "s")
 945              (concat
 946               (if vm-virtual-auto-delete-message-folder
 947                   (format "saved to %s and "
 948                           vm-virtual-auto-delete-message-folder)
 949                 "")
 950               (if vm-virtual-auto-delete-message-expunge
 951                   "expunged right away"
 952                 "marked for deletion")))))
 953
 954 ;;;###autoload
 955 (defun vm-virtual-auto-delete-messages ()
 956   "*Mark all messages from the current upto the last for (spam-)deletion.
 957 Add this to `vm-arrived-messages-hook'!
 958
 959 See the function `vm-virtual-auto-delete-message' for details.
 960
 961  (add-hook 'vm-arrived-messages-hook 'vm-virtual-auto-delete-messages)
 962 "
 963   (interactive)
 964
 965   (if (interactive-p)
 966       (vm-follow-summary-cursor))
 967   (vm-select-folder-buffer)
 968   (vm-check-for-killed-summary)
 969   (vm-virtual-auto-delete-message (length vm-message-pointer)))
 970
 971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 972 ;;;###autoload
 973 (defcustom vm-virtual-auto-folder-alist nil
 974   "*Non-nil value should be an alist that VM will use to choose a default
 975 folder name when messages are saved.  The alist should be of the form
 976         ((VIRTUAL-FOLDER-NAME . FOLDER-NAME)
 977           ...)
 978 where VIRTUAL-FOLDER-NAME is a string, and FOLDER-NAME
 979 is a string or an s-expression that evaluates to a string.
 980
 981 This allows you to extend `vm-virtual-auto-select-folder' to generate
 982 a folder name.  Your function may use `folder' to get the currently choosen
 983 folder name and `mp' (a vm-pessage-pointer) to access the message.
 984
 985 Example:
 986  (setq vm-virtual-auto-folder-alist
 987        '((\"spam\" (concat folder \"-\"
 988                            (format-time-string \"%y%m\" (current-time))))))
 989
 990 This will return \"spam-0008\" as a folder name for messages matching the
 991 virtual folder selector of the virtual folder \"spam\" during August in year
 992 2000."
 993   :type 'sexp
 994   :group 'vm-avirtual)
 995
 996 ;;;###autoload
 997 (defun vm-virtual-auto-select-folder (&optional m avfolder-alist
 998                                                 valid-folder-list
 999                                                 not-to-history)
1000   "Return the first matching virtual folder.
1001 This can be seen as an more powerful replacement of `vm-auto-select-folder'
1002 and it is used by `vm-virtual-save-message'.  It might also be applied to
1003 messages which are composed in order to find the right FCC."
1004   (when (not m)
1005     (setq m (car vm-message-pointer)
1006           avfolder-alist vm-virtual-folder-alist
1007           valid-folder-list (cond ((eq major-mode 'mail-mode)
1008                                    nil)
1009                                   ((eq major-mode 'vm-mode)
1010                                    (save-excursion
1011                                      (vm-select-folder-buffer)
1012                                      (list (buffer-name))))
1013                                   ((eq major-mode 'vm-virtual-mode)
1014                                    (list (buffer-name
1015                                           (vm-buffer-of
1016                                            (vm-real-message-of m))))))))
1017
1018   (let ((vfolders avfolder-alist)
1019         selector folder-list)
1020
1021     (when t;(and m (aref m 0) (aref (aref m 0) 0)
1022             ;   (marker-buffer (aref (aref m 0) 0)))
1023       (while vfolders
1024         (setq selector (vm-virtual-get-selector (caar vfolders)
1025                                                 valid-folder-list))
1026         (when (and selector (vm-virtual-check-selector selector m))
1027           (setq folder-list (append (list (caar vfolders)) folder-list))
1028           (if not-to-history
1029               (setq vfolders nil)))
1030         (setq vfolders (cdr vfolders)))
1031
1032       (setq folder-list (reverse folder-list))
1033
1034       (setq folder-list
1035             (mapcar (lambda (f)
1036                       (let ((rf (assoc f vm-virtual-auto-folder-alist)))
1037                         (if rf
1038                             (eval (cadr rf))
1039                           f)))
1040                     folder-list))
1041
1042       (when (and (not not-to-history) folder-list)
1043         (let ((fl (cdr folder-list)) f)
1044           (while fl
1045             (setq f (abbreviate-file-name
1046                      (expand-file-name (car fl) vm-folder-directory) t)
1047                   vm-folder-history (delete f vm-folder-history)
1048                   vm-folder-history (nconc (list f) vm-folder-history)
1049                   fl (cdr fl)))))
1050       (car folder-list))))
1051
1052 ;;;###autoload
1053 (defvar vm-sort-compare-auto-folder-cache nil)
1054 (add-to-list 'vm-supported-sort-keys "auto-folder")
1055
1056 (defun vm-sort-compare-auto-folder (m1 m2)
1057   (let* ((folder-list (list (buffer-name)))
1058          s1 s2)
1059     (if (setq s1 (assoc m1 vm-sort-compare-auto-folder-cache))
1060         (setq s1 (cdr s1))
1061       (setq s1 (vm-virtual-auto-select-folder
1062                 m1 vm-virtual-folder-alist folder-list))
1063       (add-to-list 'vm-sort-compare-auto-folder-cache (cons m1 s1)))
1064     (if (setq s2 (assoc m2 vm-sort-compare-auto-folder-cache))
1065         (setq s2 (cdr s2))
1066       (setq s2 (vm-virtual-auto-select-folder
1067                 m2 vm-virtual-folder-alist folder-list))
1068       (add-to-list 'vm-sort-compare-auto-folder-cache (cons m2 s2)))
1069     (cond ((or (and (null s1) s2)
1070                (and s1 s2 (string-lessp s1 s2)))
1071            t)
1072           ((or (and (null s1) (null s2))
1073                (and s1 s2 (string-equal s1 s2)))
1074            '=)
1075           (t nil))))
1076
1077 ;;;###autoload
1078 (defun vm-sort-insert-auto-folder-names ()
1079   (interactive)
1080   (if (interactive-p)
1081       (vm-sort-messages "auto-folder"))
1082   (save-excursion
1083     (vm-select-folder-buffer)
1084     ;; remove old descriptions
1085     (save-excursion
1086       (set-buffer vm-summary-buffer)
1087       (goto-char (point-min))
1088       (let ((buffer-read-only nil)
1089             (s (point-min))
1090             (p (point-min)))
1091         (while (setq p (next-single-property-change p 'vm-auto-folder))
1092           (if (get-text-property (1+ p) 'vm-auto-folder)
1093               (setq s p)
1094             (delete-region s p))
1095           (setq p (1+ p)))))
1096     ;; add new descriptions
1097     (let ((ml vm-message-list)
1098           (oldf "")
1099           m f)
1100       (while ml
1101         (setq m (car ml)
1102               f (cdr (assoc m vm-sort-compare-auto-folder-cache)))
1103         (when (not (equal oldf f))
1104           (setq m (vm-su-start-of m))
1105           (save-excursion
1106             (set-buffer (marker-buffer m))
1107             (let ((buffer-read-only nil))
1108               (goto-char m)
1109               (insert (format "%s\n" (or f "no default folder")))
1110               (put-text-property m (point) 'vm-auto-folder t)
1111               (put-text-property m (point) 'face 'blue)
1112               ;; fix messages summary mark
1113               (set-marker m (point))))
1114           (setq oldf f))
1115         (setq ml (cdr ml))))))
1116
1117 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1118 ;;;###autoload
1119 (defun vm-virtual-save-message (&optional folder count)
1120   "Save the current message to a mail folder.
1121 Like `vm-save-message' but the default folder it guessed by
1122 `vm-virtual-auto-select-folder'."
1123   (interactive
1124    (list
1125     ;; protect value of last-command
1126     (let ((last-command last-command)
1127           (this-command this-command))
1128       (vm-follow-summary-cursor)
1129       (let ((default (save-excursion
1130                        (vm-select-folder-buffer)
1131                        (vm-check-for-killed-summary)
1132                        (vm-error-if-folder-empty)
1133                        (or (vm-virtual-auto-select-folder)
1134                            vm-last-save-folder)))
1135             (dir (or vm-folder-directory default-directory)))
1136         (cond ((and default
1137                     (let ((default-directory dir))
1138                       (file-directory-p default)))
1139                (vm-read-file-name "Save in folder: "
1140                                   dir nil nil default 'vm-folder-history))
1141               (default
1142                 (vm-read-file-name
1143                  (format "Save in folder: (default %s) " default)
1144                  dir default nil nil 'vm-folder-history))
1145               (t
1146                (vm-read-file-name "Save in folder: " dir nil)))))
1147     (prefix-numeric-value current-prefix-arg)))
1148   (vm-save-message folder count))
1149
1150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1151 ;;;###autoload
1152 (defun vm-virtual-auto-archive-messages (&optional prompt)
1153   "With a prefix ARG ask user before saving."
1154   (interactive "P")
1155   (vm-select-folder-buffer)
1156   (vm-check-for-killed-summary)
1157   (vm-error-if-folder-empty)
1158   (vm-error-if-folder-read-only)
1159
1160   (message "Archiving...")
1161
1162   (let ((auto-folder)
1163         (folder-list (list (buffer-name)))
1164         (archived 0))
1165     (unwind-protect
1166         ;; Need separate (let ...) so vm-message-pointer can
1167         ;; revert back in time for
1168         ;; (vm-update-summary-and-mode-line).
1169         ;; vm-last-save-folder is tucked away here since archives
1170         ;; shouldn't affect its value.
1171         (let ((vm-message-pointer
1172                (if (eq last-command 'vm-next-command-uses-marks)
1173                    (vm-select-marked-or-prefixed-messages 0)
1174                  vm-message-list))
1175               (done nil)
1176               stop-point
1177               (vm-last-save-folder vm-last-save-folder)
1178               (vm-move-after-deleting nil))
1179           ;; mark the place where we should stop.  otherwise if any
1180           ;; messages in this folder are archived to this folder
1181           ;; we would file messages into this folder forever.
1182           (setq stop-point (vm-last vm-message-pointer))
1183           (while (not done)
1184             (and (not (vm-filed-flag (car vm-message-pointer)))
1185                  ;; don't archive deleted messages
1186                  (not (vm-deleted-flag (car vm-message-pointer)))
1187                  (setq auto-folder
1188                        (vm-virtual-auto-select-folder (car vm-message-pointer)
1189                                                       vm-virtual-folder-alist
1190                                                       folder-list))
1191                  ;; Don't let user archive into the same folder
1192                  ;; that they are visiting.
1193                  (not (eq (vm-get-file-buffer auto-folder)
1194                           (current-buffer)))
1195                  (or (null prompt)
1196                      (y-or-n-p
1197                       (format "Save message %s in folder %s? "
1198                               (vm-number-of (car vm-message-pointer))
1199                               auto-folder)))
1200                  (let ((vm-delete-after-saving vm-delete-after-archiving))
1201                    (vm-save-message auto-folder)
1202                    (vm-increment archived)
1203                    (message "%d archived, still working..." archived)))
1204             (setq done (eq vm-message-pointer stop-point)
1205                   vm-message-pointer (cdr vm-message-pointer))))
1206       ;; fix mode line
1207       (intern (buffer-name) vm-buffers-needing-display-update)
1208       (vm-update-summary-and-mode-line))
1209     (if (zerop archived)
1210         (message "No messages were archived")
1211       (message "%d message%s archived"
1212                archived (if (= 1 archived) "" "s")))))
1213
1214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1215 ;;;###autoload
1216 (defun vm-virtual-make-folder-persistent ()
1217   "Save all mails of current virtual folder to the real folder with the same
1218 name."
1219   (interactive)
1220   (save-excursion
1221     (vm-select-folder-buffer)
1222     (if (eq major-mode 'vm-virtual-mode)
1223         (let ((file (substring (buffer-name) 1 -1)))
1224           (vm-goto-message 0)
1225           (vm-save-message file (length vm-message-list))
1226           (message "Saved virtual folder in file \"%s\"" file))
1227       (error "This is no virtual folder!"))))
1228
1229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1230 (provide 'vm-avirtual)
1231
1232 ;;; vm-rfaddons.el ends here