vm-8.2.0b/0002755000175000017500000000000011676442162012572 5ustar srivastasrivastavm-8.2.0b/lisp/0002755000175000017500000000000011676442161013540 5ustar srivastasrivastavm-8.2.0b/lisp/vm-rfaddons.el0000755000175000017500000023120211676442160016302 0ustar srivastasrivasta;;; vm-rfaddons.el --- a collections of various useful VM helper functions ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 1999-2006 Robert Widhopf-Fenk ;; ;; Author: Robert Widhopf-Fenk ;; Status: Integrated into View Mail (aka VM), 8.0.x ;; Keywords: VM helpers ;; X-URL: http://bazaar.launchpad.net/viewmail ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; Some of the functions should be unbundled into separate packages, ;; but well I'm a lazy guy. And some of them are not tested well. ;; ;; In order to use this package add the following lines to the _end_ of your ;; .vm file. It should be the _end_ in order to ensure that variable you had ;; been setting are honored! ;; ;; (require 'vm-rfaddons) ;; (vm-rfaddons-infect-vm) ;; ;; If you want to use only a subset of the functions you should have a ;; look at the documentation of `vm-rfaddons-infect-vm' and modify ;; its call as desired. ;; ;; Additional packages you may need are: ;; ;; * Package: Personality Crisis for VM ;; is a really cool package if you want to do automatic header rewriting, ;; e.g. if you have various mail accounts and always want to use the right ;; from header, then check it out! ;; ;; * Package: BBDB ;; Homepage: http://bbdb.sourceforge.net ;; ;; All other packages should be included within standard (X)Emacs ;; distributions. ;; ;; As I am no active GNU Emacs user, I would be thankful for any patches to ;; make things work with GNU Emacs! ;; ;;; Code: (provide 'vm-rfaddons) (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-toolbar) (require 'vm-mouse) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-crypto) (require 'vm-mime) (require 'vm-edit) (require 'vm-virtual) (require 'vm-pop) (require 'vm-imap) (require 'vm-sort) (require 'vm-reply) (require 'vm-pine) (require 'wid-edit) (require 'vm) ) (declare-function bbdb-record-raw-notes "ext:bbdb" (record)) (declare-function bbdb-record-net "ext:bbdb " (record)) (declare-function bbdb-split "ext:bbdb" (string separators)) (declare-function bbdb-records "ext:bbdb" (&optional dont-check-disk already-in-db-buffer)) (declare-function smtpmail-via-smtp-server "ext:smtpmail" ()) (declare-function esmtpmail-send-it "ext:esmtpmail" ()) (declare-function esmtpmail-via-smtp-server "ext:esmtpmail" ()) (declare-function vm-folder-buffers "ext:vm" (&optional non-virtual)) (eval-when-compile (require 'cl) (require 'advice) (vm-load-features '(regexp-opt bbdb bbdb-vm)) ;; gnus-group removed from features because it gives errors. USR, 2011-01-26 ) (require 'sendmail) (vm-load-features '(bbdb)) (if vm-xemacs-p (require 'overlay)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup vm-rfaddons nil "Customize vm-rfaddons.el" :group 'vm-ext) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro vm-rfaddons-check-option (option option-list &rest body) "Evaluate body if option is in OPTION-LIST or OPTION-LIST is nil." (list 'if (list 'member option option-list) (cons 'progn (cons (list 'setq option-list (list 'delq option option-list)) (cons (list 'message "Adding vm-rfaddons-option `%s'." option) body))))) ;;;###autoload (defun vm-rfaddons-infect-vm (&optional sit-for option-list exclude-option-list) "This function will setup the key bindings, advices and hooks necessary to use all the function of vm-rfaddons.el. SIT-FOR specifies the number of seconds to display the infection message. The OPTION-LIST can be use to select individual option. The EXCLUDE-OPTION-LIST can be use to exclude individual option. The following options are possible. `general' options: - rf-faces: change some faces `vm-mail-mode' options: - attach-save-files: bind [C-c C-a] to `vm-attach-files-in-directory' - check-recipients: add `vm-mail-check-recipients' to `mail-send-hook' in order to check if the recipients headers are correct. - encode-headers: add `vm-mime-encode-headers' to `mail-send-hook' in order to encode the headers before sending. - fake-date: if enabled allows you to fake the date of an outgoing message. `vm-mode' options: - shrunken-headers: enable shrunken-headers by advising several functions Other EXPERIMENTAL options: - auto-save-all-attachments: add `vm-mime-auto-save-all-attachments' to `vm-select-new-message-hook' for automatic saving of attachments and define an advice for `vm-set-deleted-flag-of' in order to automatically delete the files corresponding to MIME objects of type message/external-body when deleting the message. - return-receipt-to If you want to use only a subset of the options then call `vm-rfaddons-infect-vm' like this: (vm-rfaddons-infect-vm 2 '(general vm-mail-mode shrunken-headers) '(fake-date)) This will enable all `general' and `vm-mail-mode' options plus the `shrunken-headers' option, but it will exclude the `fake-date' option of the `vm-mail-mode' options. or do the binding and advising on your own." (interactive "") (if (eq option-list 'all) (setq option-list (list 'general 'vm-mail-mode 'vm-mode 'auto-save-all-attachments 'auto-delete-message-external-body)) (if (eq option-list t) (setq option-list (list 'vm-mail-mode 'vm-mode)))) (when (member 'general option-list) (setq option-list (append '(rf-faces) option-list)) (setq option-list (delq 'general option-list))) (when (member 'vm-mail-mode option-list) (setq option-list (append '(attach-save-files check-recipients check-for-empty-subject encode-headers clean-subject fake-date open-line) option-list)) (setq option-list (delq 'vm-mail-mode option-list))) (when (member 'vm-mode option-list) (setq option-list (append '( ;; save-all-attachments shrunken-headers take-action-on-attachment ) option-list)) (setq option-list (delq 'vm-mode option-list))) (while exclude-option-list (if (member (car exclude-option-list) option-list) (setq option-list (delq (car exclude-option-list) option-list)) (message "VM-RFADDONS: The option `%s' was not excluded, maybe it is unknown!" (car exclude-option-list)) (ding) (sit-for 3)) (setq exclude-option-list (cdr exclude-option-list))) ;; general ---------------------------------------------------------------- ;; install my choice of faces (vm-rfaddons-check-option 'rf-faces option-list (vm-install-rf-faces)) ;; vm-mail-mode ----------------------------------------------------------- (vm-rfaddons-check-option 'attach-save-files option-list ;; this binding overrides the VM binding of C-c C-a to `vm-attach-file' (define-key vm-mail-mode-map "\C-c\C-a" 'vm-attach-files-in-directory)) ;; check recipients headers for errors before sending (vm-rfaddons-check-option 'check-recipients option-list (add-hook 'mail-send-hook 'vm-mail-check-recipients)) ;; check if the subjectline is empty (vm-rfaddons-check-option 'check-for-empty-subject option-list (add-hook 'vm-mail-send-hook 'vm-mail-check-for-empty-subject)) ;; encode headers before sending (vm-rfaddons-check-option 'encode-headers option-list (add-hook 'mail-send-hook 'vm-mime-encode-headers)) ;; This allows us to fake a date by advising vm-mail-mode-insert-date-maybe (vm-rfaddons-check-option 'fake-date option-list (defadvice vm-mail-mode-insert-date-maybe (around vm-fake-date activate) "Do not change an existing date if `vm-mail-mode-fake-date-p' is t." (if (not (and vm-mail-mode-fake-date-p (vm-mail-mode-get-header-contents "Date:"))) ad-do-it))) (vm-rfaddons-check-option 'open-line option-list (add-hook 'vm-mail-mode-hook 'vm-mail-mode-install-open-line)) (vm-rfaddons-check-option 'clean-subject option-list (add-hook 'vm-mail-mode-hook 'vm-mail-subject-cleanup)) ;; vm-mode ----------------------------------------------------------- ;; Shrunken header handlers (vm-rfaddons-check-option 'shrunken-headers option-list (if (not (boundp 'vm-always-use-presentation)) (message "Shrunken-headers do NOT work in standard VM!") ;; We would corrupt the folder buffer for messages which are ;; not displayed by a presentation buffer, thus we must ensure ;; that a presentation buffer is used. The visibility-widget ;; would cause "*"s to be inserted into the folder buffer. (setq vm-always-use-presentation t) (defadvice vm-present-current-message (after vm-shrunken-headers-pcm activate) "Shrink headers when previewing a message." (vm-shrunken-headers)) (defadvice vm-expose-hidden-headers (after vm-shrunken-headers-ehh activate) "Shrink headers when viewing hidden headers." (vm-shrunken-headers)) ;; this overrides the VM binding of "T" to `vm-toggle-thread' (define-key vm-mode-map "T" 'vm-shrunken-headers-toggle))) ;; This is not needed any more because VM has $ commands to take ;; action on attachments. But we keep it for compatibility. ;; take action on attachment binding (vm-rfaddons-check-option 'take-action-on-attachment option-list ;; this overrides the VM binding of "." to `vm-mark-message-as-read' (define-key vm-mode-map "." 'vm-mime-take-action-on-attachment)) ;; This is not needed any more becaue it is in the core ;; (vm-rfaddons-check-option ;; 'save-all-attachments option-list ;; (define-key vm-mode-map "\C-c\C-s" 'vm-save-all-attachments)) ;; other experimental options --------------------------------------------- ;; Now take care of automatic saving of attachments (vm-rfaddons-check-option 'auto-save-all-attachments option-list ;; In order to reflect MIME type changes when `vm-mime-delete-after-saving' ;; is t we preview the message again. (defadvice vm-mime-send-body-to-file (after vm-do-preview-again activate) (if vm-mime-delete-after-saving (vm-present-current-message))) (add-hook 'vm-select-new-message-hook 'vm-mime-auto-save-all-attachments)) (vm-rfaddons-check-option 'auto-delete-message-external-body option-list ;; and their deletion when deleting a unfiled message, ;; this is probably a problem, since actually we should delete it ;; only if there remains no reference to it!!!! (defadvice vm-set-deleted-flag-of (before vm-mime-auto-save-all-attachments activate) (if (and (eq (ad-get-arg 1) 'expunged) (not (vm-filed-flag (ad-get-arg 0)))) (vm-mime-auto-save-all-attachments-delete-external (ad-get-arg 0))))) (vm-rfaddons-check-option 'return-receipt-to option-list (add-hook 'vm-select-message-hook 'vm-handle-return-receipt)) (when option-list (message "VM-RFADDONS: The following options are unknown: %s" option-list) (ding) (sit-for 3)) (message "VM-RFADDONS: Options loaded.") (vm-sit-for (or sit-for 2))) (defun rf-vm-su-labels (m) "This version does some sanity checking." (let ((labels (vm-label-string-of m))) (if (and labels (stringp labels)) labels (setq labels (vm-labels-of m)) (if (and labels (listp labels)) (vm-set-label-string-of m (setq labels (mapconcat 'identity labels ","))) (vm-set-label-string-of m "") (setq labels ""))) labels)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This add-on is now obsolete because ;; vm-include-text-from-presentation in core VM enables the same ;; functionality. USR, 2011-03-30 (defcustom vm-reply-include-presentation nil "*If true a reply will include the presentation of a message. This might give better results when using filling or MIME encoded messages, e.g. HTML message. (This variable is part of vm-rfaddons.el.)" :group 'vm-rfaddons :type 'boolean) ;;;###autoload (defun vm-followup-include-presentation (count) "Include presentation instead of text. This does not work when replying to multiple messages." (interactive "p") (vm-reply-include-presentation count t)) (make-obsolete 'vm-followup-include-presentation 'vm-include-text-from-presentation "8.2.0") ;;;###autoload (defun vm-reply-include-presentation (count &optional to-all) "Include presentation instead of text. This does only work with my modified VM, i.e. a hacked `vm-yank-message'." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (null vm-presentation-buffer) (if to-all (vm-followup-include-text count) (vm-reply-include-text count)) (let ((vm-include-text-from-presentation t) (vm-reply-include-presentation t) ; is this variable necessary? (vm-enable-thread-operations nil)) (vm-do-reply to-all t count)))) (make-obsolete 'vm-reply-include-presentation 'vm-include-text-from-presentation "8.2.0") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This add-on is disabled becaust it has been integrated into the ;; core. USR, 2010-05-01 ;; (defadvice vm-mime-encode-composition ;; (before do-fcc-before-mime-encode activate) ;; "FCC before encoding attachments if `vm-do-fcc-before-mime-encode' is t." ;; (if vm-do-fcc-before-mime-encode ;; (vm-do-fcc-before-mime-encode))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This has been moved to the VM core. USR, 2010-03-11 ;;;;;###autoload ;; (defun vm-fill-paragraphs-by-longlines (width start end) ;; "Uses longlines.el for filling. ;; To use it, advice `vm-fill-paragraphs-containing-long-lines' and call this ;; function instead." ;; (if (eq width 'window-width) ;; (setq width (- (window-width (get-buffer-window (current-buffer))) 1))) ;; ;; prepare for longlines.el in XEmacs ;; (require 'overlay) ;; (require 'longlines) ;; (defvar fill-nobreak-predicate nil) ;; (defvar undo-in-progress nil) ;; (defvar longlines-mode-hook nil) ;; (defvar longlines-mode-on-hook nil) ;; (defvar longlines-mode-off-hook nil) ;; (unless (functionp 'replace-regexp-in-string) ;; (defun replace-regexp-in-string (regexp rep string ;; &optional fixedcase literal) ;; (vm-replace-in-string string regexp rep literal))) ;; (unless (functionp 'line-end-position) ;; (defun line-end-position () ;; (save-excursion (end-of-line) (point)))) ;; (unless (functionp 'line-beginning-position) ;; (defun line-beginning-position (&optional n) ;; (save-excursion ;; (if n (forward-line n)) ;; (beginning-of-line) ;; (point))) ;; (unless (functionp 'replace-regexp-in-string) ;; (defun replace-regexp-in-string (regexp rep string ;; &optional fixedcase literal) ;; (vm-replace-in-string string regexp rep literal)))) ;; ;; now do the filling ;; (let ((buffer-read-only nil) ;; (fill-column width)) ;; (save-excursion ;; (vm-save-restriction ;; ;; longlines-wrap-region contains a (forward-line -1) which is causing ;; ;; wrapping of headers which is wrong, so we restrict it here! ;; (narrow-to-region start end) ;; (longlines-decode-region start end) ; make linebreaks hard ;; (longlines-wrap-region start end) ; wrap, adding soft linebreaks ;; (widen))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-spamassassin-strip-report "spamassassin -d" "*Shell command used to strip spamassassin-reports from a message." :type 'string :group 'vm-rfaddons) (defun vm-strip-spamassassin-report () "Strips spamassassin-reports from a message." (interactive) (save-window-excursion (let ((vm-frame-per-edit nil)) (vm-edit-message) (shell-command-on-region (point-min) (point-max) vm-spamassassin-strip-report (current-buffer) t) (vm-edit-message-end)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; vm-switch-to-folder moved to vm.el. USR, 2011-02-28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-rmail-mode nil "*Non-nil means up/down move to the next/previous message instead. Otherwise normal cursor movement is done. Specifically only modes listed in `vm-rmail-mode-list' are affected. Use `vm-rmail-toggle' to switch between normal and this mode." :type 'boolean :group 'vm-rfaddons) (defcustom vm-rmail-mode-list '(vm-summary-mode) "*Mode to activate `vm-rmail-mode' in." :type '(set (const vm-mode) (const vm-presentation-mode) (const vm-virtual-mode) (const vm-summary-mode)) :group 'vm-rfaddons) (defun vm-rmail-toggle (&optional arg) (interactive) (cond ((eq nil arg) (setq vm-rmail-mode (not vm-rmail-mode))) ((= 1 arg) (setq vm-rmail-mode t)) ((= -1 arg) (setq vm-rmail-mode nil)) (t (setq vm-rmail-mode (not vm-rmail-mode)))) (message (if vm-rmail-mode "Rmail cursor mode" "VM cursor mode"))) (defun vm-rmail-up () (interactive) (cond ((and vm-rmail-mode (member major-mode vm-rmail-mode-list)) (vm-next-message -1) (vm-display nil nil '(rf-vm-rmail-up vm-previous-message) (list this-command))) (t (forward-line -1)))) (defun vm-rmail-down () (interactive) (cond ((and vm-rmail-mode (member major-mode vm-rmail-mode-list)) (vm-next-message 1) (vm-display nil nil '(rf-vm-rmail-up vm-next-message) (list this-command))) (t (forward-line 1)))) (defun vm-do-with-message (count function vm-display) (vm-follow-summary-cursor) (save-excursion (vm-select-folder-buffer) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Operate on"))) (while mlist (funcall function (car mlist)) (vm-mark-for-summary-update (car mlist) t) (setq mlist (cdr mlist)))) (vm-display nil nil (append vm-display '(vm-do-with-message)) (list this-command)) (vm-update-summary-and-mode-line))) (defun vm-toggle-mark (count &optional m) (interactive "p") (vm-do-with-message count (lambda (m) (vm-set-mark-of m (not (vm-mark-of m)))) '(vm-toggle-mark vm-mark-message marking-message))) (defun vm-toggle-deleted (count &optional m) (interactive "p") (vm-do-with-message count (lambda (m) (vm-set-deleted-flag m (not (vm-deleted-flag m)))) '(vm-toggle-deleted vm-delete-message vm-delete-message-backward))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-mail-subject-prefix-replacements '(("\\(\\(re\\|aw\\|antw\\)\\(\\[[0-9]+\\]\\)?:[ \t]*\\)+" . "Re: ") ("\\(\\(fo\\|wg\\)\\(\\[[0-9]+\\]\\)?:[ \t]*\\)+" . "Fo: ")) "*List of subject prefixes which should be replaced. Matching will be done case insentivily." :group 'vm-rfaddons :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Replacement")))) (defcustom vm-mail-subject-number-reply nil "*Non-nil means, add a number [N] after the reply prefix. The number reflects the number of references." :group 'vm-rfaddons :type '(choice (const :tag "on" t) (const :tag "off" nil))) (defun vm-mail-subject-cleanup () "Do some subject line clean up. - Replace subject prefixes according to `vm-replace-subject-prefixes'. - Add a number after replies is `vm-mail-subject-number-reply' is t. You might add this function to `vm-mail-mode-hook' in order to clean up the Subject header." (interactive) (save-excursion ;; cleanup (goto-char (point-min)) (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max)) (let ((case-fold-search t) (rpl vm-mail-subject-prefix-replacements)) (while rpl (if (re-search-backward (concat "^Subject:[ \t]*" (caar rpl)) (point-min) t) (replace-match (concat "Subject: " (cdar rpl)))) (setq rpl (cdr rpl)))) ;; add number to replys (let (refs (start 0) end (count 0)) (when (and vm-mail-subject-number-reply vm-reply-list (setq refs (vm-mail-mode-get-header-contents "References:"))) (while (string-match "<[^<>]+>" refs start) (setq count (1+ count) start (match-end 0))) (when (> count 1) (mail-position-on-field "Subject" t) (setq end (point)) (if (re-search-backward "^Subject:" (point-min) t) (setq start (point)) (error "Could not find end of Subject header start")) (goto-char start) (if (not (re-search-forward (regexp-quote vm-reply-subject-prefix) end t)) (error "Cound not find vm-reply-subject-prefix `%s' in header" vm-reply-subject-prefix) (goto-char (match-end 0)) (skip-chars-backward ": \t") (insert (format "[%d]" count)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-mime-set-8bit-composition-charset (charset &optional buffer-local) "*Set `vm-mime-8bit-composition-charset' to CHARSET. With the optional BUFFER-LOCAL prefix arg, this only affects the current buffer." (interactive (list (completing-read "Composition charset: " vm-mime-charset-completion-alist nil t) current-prefix-arg)) (if (or vm-xemacs-mule-p vm-fsfemacs-p) (error "vm-mime-8bit-composition-charset has no effect in XEmacs/MULE")) (if buffer-local (set (make-local-variable 'vm-mime-8bit-composition-charset) charset) (setq vm-mime-8bit-composition-charset charset))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bbdb/vm-set-virtual-folder-alist () "Create a `vm-virtual-folder-alist' according to the records in the bbdb. For each record that has a 'vm-virtual' attribute, add or modify the corresponding BBDB-VM-VIRTUAL element of the `vm-virtual-folder-alist'. (BBDB-VM-VIRTUAL ((vm-primary-inbox) (author-or-recipient BBDB-RECORD-NET-REGEXP))) The element gets added to the 'element-name' sublist of the `vm-virtual-folder-alist'." (interactive) (let (notes-field email-regexp folder selector) (dolist (record (bbdb-records)) (setq notes-field (bbdb-record-raw-notes record)) (when (and (listp notes-field) (setq folder (cdr (assq 'vm-virtual notes-field)))) (setq email-regexp (mapconcat (lambda (addr) (regexp-quote addr)) (bbdb-record-net record) "\\|")) (unless (zerop (length email-regexp)) (setq folder (or (assoc folder vm-virtual-folder-alist) (car (setq vm-virtual-folder-alist (nconc (list (list folder (list (list vm-primary-inbox) (list 'author-or-recipient)))) vm-virtual-folder-alist)))) folder (cadr folder) selector (assoc 'author-or-recipient folder)) (if (cdr selector) (if (not (string-match (regexp-quote email-regexp) (cadr selector))) (setcdr selector (list (concat (cadr selector) "\\|" email-regexp)))) (nconc selector (list email-regexp))))) ) )) (defun vm-virtual-find-selector (selector-spec type) "Return the first selector of TYPE in SELECTOR-SPEC." (let ((s (assoc type selector-spec))) (unless s (while (and (not s) selector-spec) (setq s (and (listp (car selector-spec)) (vm-virtual-find-selector (car selector-spec) type)) selector-spec (cdr selector-spec)))) s)) (defcustom bbdb/vm-virtual-folder-alist-by-mail-alias-alist nil "*A list of (ALIAS . FOLDER-NAME) pairs, which map an alias to a folder." :group 'vm-rfaddons :type '(repeat (cons :tag "Mapping Definition" (regexp :tag "Alias") (string :tag "Folder Name")))) (defun bbdb/vm-set-virtual-folder-alist-by-mail-alias () "Create a `vm-virtual-folder-alist' according to the records in the bbdb. For each record check wheather its alias is in the variable `bbdb/vm-virtual-folder-alist-by-mail-alias-alist' and then add/modify the corresponding VM-VIRTUAL element of the `vm-virtual-folder-alist'. (BBDB-VM-VIRTUAL ((vm-primary-inbox) (author-or-recipient BBDB-RECORD-NET-REGEXP))) The element gets added to the 'element-name' sublist of the `vm-virtual-folder-alist'." (interactive) (let (notes-field email-regexp mail-aliases folder selector) (dolist (record (bbdb-records)) (setq notes-field (bbdb-record-raw-notes record)) (when (and (listp notes-field) (setq mail-aliases (cdr (assq 'mail-alias notes-field))) (setq mail-aliases (bbdb-split mail-aliases ","))) (setq folder nil) (while mail-aliases (setq folder (assoc (car mail-aliases) bbdb/vm-virtual-folder-alist-by-mail-alias-alist)) (when (and folder (setq folder (cdr folder) email-regexp (mapconcat (lambda (addr) (regexp-quote addr)) (bbdb-record-net record) "\\|")) (> (length email-regexp) 0)) (setq folder (or (assoc folder vm-virtual-folder-alist) (car (setq vm-virtual-folder-alist (nconc (list (list folder (list (list vm-primary-inbox) (list 'author-or-recipient)) )) vm-virtual-folder-alist)))) folder (cadr folder) selector (vm-virtual-find-selector folder 'author-or-recipient)) (unless selector (nconc (cdr folder) (list (list 'author-or-recipient)))) (if (cdr selector) (if (not (string-match (regexp-quote email-regexp) (cadr selector))) (setcdr selector (list (concat (cadr selector) "\\|" email-regexp)))) (nconc selector (list email-regexp)))) (setq mail-aliases (cdr mail-aliases))) )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-handle-return-receipt-mode 'edit "*Tells `vm-handle-return-receipt' how to handle return receipts. One can choose between 'ask, 'auto, 'edit or an expression which is evaluated and which should return t if the return receipts should be sent." :group 'vm-rfaddons :type '(choice (const :tag "Edit" edit) (const :tag "Ask" ask) (const :tag "Auto" auto))) (defcustom vm-handle-return-receipt-peek 500 "*Number of characters from the original message body to be returned." :group 'vm-rfaddons :type '(integer)) (defun vm-handle-return-receipt () "Generate a reply to the current message if it requests a return receipt and has not been replied so far. See the variable `vm-handle-return-receipt-mode' for customization." (interactive) (save-excursion (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let* ((msg (car vm-message-pointer)) (sender (vm-get-header-contents msg "Return-Receipt-To:")) (mail-signature nil) (mode (and sender (cond ((equal 'ask vm-handle-return-receipt-mode) (y-or-n-p "Send a return receipt? ")) ((symbolp vm-handle-return-receipt-mode) vm-handle-return-receipt-mode) (t (eval vm-handle-return-receipt-mode))))) (vm-mutable-frame-configuration (if (eq mode 'edit) vm-mutable-frame-configuration nil)) (vm-mail-mode-hook nil) (vm-mode-hook nil) message) (when (and mode (not (vm-replied-flag msg))) (vm-reply 1) (vm-mail-mode-remove-header "Return-Receipt-To:") (vm-mail-mode-remove-header "To:") (goto-char (point-min)) (insert "To: " sender "\n") (mail-text) (delete-region (point) (point-max)) (insert (format "Your mail has been received on %s." (current-time-string))) (save-restriction (save-excursion (set-buffer (vm-buffer-of msg)) (widen) (setq message (buffer-substring (vm-vheaders-of msg) (let ((tp (+ vm-handle-return-receipt-peek (marker-position (vm-text-of msg)))) (ep (marker-position (vm-end-of msg)))) (if (< tp ep) tp ep)) )))) (insert "\n-----------------------------------------------------------------------------\n" message) (if (re-search-backward "^\\s-+.*" (point-min) t) (replace-match "")) (insert "[...]\n") (if (not (eq mode 'edit)) (vm-mail-send-and-exit nil)) ) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defalias 'vm-mime-find-type-of-message/external-body 'vm-mf-external-body-content-type) (make-obsolete 'vm-mime-find-type-of-message/external-body 'vm-mf-external-body-content-type "8.2.0") ;; This is a hack in order to get the right MIME button ;(defadvice vm-mime-set-extent-glyph-for-type ; (around vm-message/external-body-glyph activate) ; (if (and (boundp 'real-mime-type) ; (string= (ad-get-arg 1) "message/external-body")) ; (ad-set-arg 1 real-mime-type)) ; ad-do-it) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar vm-attach-files-in-directory-regexps-history nil "Regexp history for matching files.") (defvaralias 'vm-mime-attach-files-in-directory-regexps-history 'vm-attach-files-in-directory-regexps-history) (defcustom vm-attach-files-in-directory-default-type nil "*The default MIME-type for attached files. If set to nil you will be asked for the type if it cannot be guessed. For guessing mime-types we use `vm-mime-attachment-auto-type-alist'." :group 'vm-rfaddons :type '(choice (const :tag "Ask" nil) (string "application/octet-stream"))) (defvaralias 'vm-mime-attach-files-in-directory-default-type 'vm-attach-files-in-directory-default-type) (defcustom vm-attach-files-in-directory-default-charset 'guess "*The default charset used for attached files of type `text'. If set to nil you will be asked for the charset. If set to 'guess it will be determined by `vm-determine-proper-charset', but this may take some time, since the file needs to be visited." :group 'vm-rfaddons :type '(choice (const :tag "Ask" nil) (const :tag "Guess" guess))) (defvaralias 'vm-mime-attach-files-in-directory-default-charset 'vm-attach-files-in-directory-default-charset) ;; (define-obsolete-variable-alias 'vm-mime-save-all-attachments-types ;; 'vm-mime-saveable-types ;; "8.3.0" ;; "*List of MIME types which should be saved.") (defvaralias 'vm-mime-save-all-attachments-types 'vm-mime-saveable-types) (make-obsolete-variable 'vm-mime-save-all-attachments-types 'vm-mime-saveable-types "8.1.1") ;; (define-obsolete-variable-alias ;; 'vm-mime-save-all-attachments-types-exceptions ;; 'vm-mime-saveable-type-exceptions ;; "8.3.0" ;; "*List of MIME types which should not be saved.") (defvaralias 'vm-mime-save-all-attachments-types-exceptions 'vm-mime-saveable-type-exceptions) (make-obsolete-variable 'vm-mime-save-all-attachments-types-exceptions 'vm-mime-saveable-type-exceptions "8.1.1") ;; (define-obsolete-variable-alias 'vm-mime-delete-all-attachments-types ;; 'vm-mime-deleteable-types ;; "8.3.0" ;; "*List of MIME types which should be deleted.") (defvaralias 'vm-mime-delete-all-attachments-types 'vm-mime-deleteable-types) (make-obsolete-variable 'vm-mime-delete-all-attachments-types 'vm-mime-deleteable-types "8.1.1") ;; (define-obsolete-variable-alias ;; 'vm-mime-delete-all-attachments-types-exceptions ;; 'vm-mime-deleteable-type-exceptions ;; "8.3.0" ;; "*List of MIME types which should not be deleted.") (defvaralias 'vm-mime-delete-all-attachments-types-exceptions 'vm-mime-deleteable-type-exceptions) (make-obsolete-variable 'vm-mime-delete-all-attachments-types-exceptions 'vm-mime-deleteable-type-exceptions "8.1.1") ;;;###autoload (defun vm-attach-files-in-directory (directory &optional regexp) "Attach all files in DIRECTORY matching REGEXP. The optional argument MATCH might specify a regexp matching all files which should be attached, when empty all files will be attached. When called with a prefix arg it will do a literal match instead of a regexp match." (interactive (flet ((substitute-in-file-name (file) file)) (let ((file (vm-read-file-name "Attach files matching regexp: " (or vm-mime-all-attachments-directory vm-mime-attachment-save-directory default-directory) (or vm-mime-all-attachments-directory vm-mime-attachment-save-directory default-directory) nil nil vm-attach-files-in-directory-regexps-history))) (list (file-name-directory file) (file-name-nondirectory file))))) (setq vm-mime-all-attachments-directory directory) (message "Attaching files matching `%s' from directory %s " regexp directory) (if current-prefix-arg (setq regexp (concat "^" (regexp-quote regexp) "$"))) (let ((files (directory-files directory t regexp nil)) file type charset) (if (null files) (error "No matching files!") (while files (setq file (car files)) (if (file-directory-p file) nil ;; should we add recursion here? (setq type (or (vm-mime-default-type-from-filename file) vm-attach-files-in-directory-default-type)) (message "Attaching file %s with type %s ..." file type) (if (null type) (let ((default-type (or (vm-mime-default-type-from-filename file) "application/octet-stream"))) (setq type (completing-read (format "Content type for %s (default %s): " (file-name-nondirectory file) default-type) vm-mime-type-completion-alist) type (if (> (length type) 0) type default-type)))) (if (not (vm-mime-types-match "text" type)) nil (setq charset vm-attach-files-in-directory-default-charset) (cond ((eq 'guess charset) (save-excursion (let ((b (get-file-buffer file))) (set-buffer (or b (find-file-noselect file t t))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (if (null b) (kill-buffer (current-buffer)))))) ((null charset) (setq charset (completing-read (format "Character set for %s (default US-ASCII): " file) vm-mime-charset-completion-alist) charset (if (> (length charset) 0) charset))))) (vm-attach-file file type charset)) (setq files (cdr files)))))) (defalias 'vm-mime-attach-files-in-directory 'vm-attach-files-in-directory) (defcustom vm-mime-auto-save-all-attachments-subdir nil "*Subdirectory where to save the attachments of a message. This variable might be set to a string, a function or anything which evaluates to a string. If set to nil we use a concatenation of the from, subject and date header as subdir for the attachments." :group 'vm-rfaddons :type '(choice (directory :tag "Directory") (string :tag "No Subdir" "") (function :tag "Function") (sexp :tag "sexp"))) (defun vm-mime-auto-save-all-attachments-subdir (msg) "Return a subdir for the attachments of MSG. This will be done according to `vm-mime-auto-save-all-attachments-subdir'." (setq msg (vm-real-message-of msg)) (when (not (string-match (regexp-quote (vm-reencode-mime-encoded-words-in-string (vm-su-full-name msg))) (vm-get-header-contents msg "From:"))) (backtrace) (if (y-or-n-p (format "Is this wrong? %s <> %s " (vm-su-full-name msg) (vm-get-header-contents msg "From:"))) (error "Yes it is wrong!"))) (cond ((functionp vm-mime-auto-save-all-attachments-subdir) (funcall vm-mime-auto-save-all-attachments-subdir msg)) ((stringp vm-mime-auto-save-all-attachments-subdir) (vm-summary-sprintf vm-mime-auto-save-all-attachments-subdir msg)) ((null vm-mime-auto-save-all-attachments-subdir) (let (;; for the folder (basedir (buffer-file-name (vm-buffer-of msg))) ;; for the message (subdir (concat "/" (format "%04s.%02s.%02s-%s" (vm-su-year msg) (vm-su-month-number msg) (vm-su-monthday msg) (vm-su-hour msg)) "--" (or (vm-su-full-name msg) "unknown") "--" (vm-su-subject msg)))) (if (and basedir vm-folder-directory (string-match (concat "^" (expand-file-name vm-folder-directory)) basedir)) (setq basedir (replace-match "" nil nil basedir))) (setq subdir (vm-replace-in-string subdir "\\s-\\s-+" " " t)) (setq subdir (vm-replace-in-string subdir "[^A-Za-z0-9\241-_-]+" "_" t)) (setq subdir (vm-replace-in-string subdir "?_-?_" "-" nil)) (setq subdir (vm-replace-in-string subdir "^_+" "" t)) (setq subdir (vm-replace-in-string subdir "_+$" "" t)) (concat basedir "/" subdir))) (t (eval vm-mime-auto-save-all-attachments-subdir)))) (defun vm-mime-auto-save-all-attachments-path (msg) "Create a path for storing the attachments of MSG." (let ((subdir (vm-mime-auto-save-all-attachments-subdir (vm-real-message-of msg)))) (if (not vm-mime-attachment-save-directory) (error "Set `vm-mime-attachment-save-directory' for autosaving of attachments") (if subdir (if (string-match "/$" vm-mime-attachment-save-directory) (concat vm-mime-attachment-save-directory subdir) (concat vm-mime-attachment-save-directory "/" subdir)) vm-mime-attachment-save-directory)))) ;;;###autoload (defun vm-mime-auto-save-all-attachments (&optional count) "Save all attachments to a subdirectory. Root directory for saving is `vm-mime-attachment-save-directory'. You might add this to `vm-select-new-message-hook' in order to automatically save attachments. (add-hook 'vm-select-new-message-hook 'vm-mime-auto-save-all-attachments) " (interactive "P") (if vm-mime-auto-save-all-attachments-avoid-recursion nil (let ((vm-mime-auto-save-all-attachments-avoid-recursion t)) (vm-check-for-killed-folder) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-save-all-attachments count 'vm-mime-auto-save-all-attachments-path) (when (vm-interactive-p) (vm-discard-cached-data) (vm-present-current-message))))) ;;;###autoload (defun vm-mime-auto-save-all-attachments-delete-external (msg) "Deletes the external attachments created by `vm-save-all-attachments'. You may want to use this function in order to get rid of the external files when deleting a message. See the advice in `vm-rfaddons-infect-vm'." (interactive "") (vm-check-for-killed-folder) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (setq msg (or msg (car vm-message-pointer))) (if msg (let ((o (vm-mm-layout msg)) (no 0) parts layout file type) (if (eq 'none o) nil;; this is no mime message (setq type (car (vm-mm-layout-type o))) (cond ((or (vm-mime-types-match "multipart/alternative" type) (vm-mime-types-match "multipart/mixed" type)) (setq parts (copy-sequence (vm-mm-layout-parts o)))) (t (setq parts (list o)))) (while parts (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car parts)))) (setq parts (nconc (copy-sequence (vm-mm-layout-parts (car parts))) (cdr parts)))) (setq layout (car parts)) (if layout (setq type (car (vm-mm-layout-type layout)))) (if (not (string= type "message/external-body")) nil (setq file (vm-mime-get-parameter layout "name")) (if (and file (file-exists-p file)) (progn (delete-file file) (setq no (+ 1 no))))) (setq parts (cdr parts)))) (if (> no 0) (message "%s file%s deleted." (if (= no 1) "One" no) (if (= no 1) "" "s"))) (if (and file (file-name-directory file) (file-exists-p (file-name-directory file)) ;; is the directory empty? (let ((files (directory-files (file-name-directory file)))) (and files (= 2 (length files))))) (delete-directory (file-name-directory file)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-mail-check-recipients () "Check if the recipients are specified correctly. Actually it checks only if there are any missing commas or the like in the headers." (interactive) (let ((header-list '("To:" "CC:" "BCC:" "Resent-To:" "Resent-CC:" "Resent-BCC:")) (contents nil) (errors nil)) (while header-list (setq contents (vm-mail-mode-get-header-contents (car header-list))) (if (and contents (string-match "@[^,\"]*@" contents)) (setq errors (vm-replace-in-string (format "Missing separator in %s \"%s\"! " (car header-list) (match-string 0 contents)) "[\n\t ]+" " "))) (setq header-list (cdr header-list))) (if errors (error errors)))) (defcustom vm-mail-prompt-if-subject-empty t "*Prompt for a subject when empty." :group 'vm-rfaddons :type '(boolean)) ;;;###autoload (defun vm-mail-check-for-empty-subject () "Check if the subject line is empty and issue an error if so." (interactive) (let (subject) (setq subject (vm-mail-mode-get-header-contents "Subject:")) (if (or (not subject) (string-match "^[ \t]*$" subject)) (if (not vm-mail-prompt-if-subject-empty) (error "Empty subject") (mail-position-on-field "Subject") (insert (read-string "Subject: ")))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defface vm-shrunken-headers-face '((((class color) (background light)) (:background "grey")) (((class color) (background dark)) (:background "DimGrey")) (t (:dim t))) "Used for marking shrunken headers." :group 'vm-rfaddons) (defconst vm-shrunken-headers-keymap (let ((map (if vm-xemacs-p (make-keymap) (copy-keymap vm-mode-map)))) (define-key map [(return)] 'vm-shrunken-headers-toggle-this) (if vm-xemacs-p (define-key map [(button2)] 'vm-shrunken-headers-toggle-this-mouse) (define-key map [(mouse-2)] 'vm-shrunken-headers-toggle-this-mouse)) map) "Keymap used for shrunken-headers glyphs.") ;;;###autoload (defun vm-shrunken-headers-toggle () "Toggle display of shrunken headers." (interactive) (vm-shrunken-headers 'toggle)) ;;;###autoload (defun vm-shrunken-headers-toggle-this-mouse (&optional event) "Toggle display of shrunken headers." (interactive "e") (mouse-set-point event) (end-of-line) (vm-shrunken-headers-toggle-this)) ;;;###autoload (defun vm-shrunken-headers-toggle-this-widget (widget &rest event) (goto-char (widget-get widget :to)) (end-of-line) (vm-shrunken-headers-toggle-this)) ;;;###autoload (defun vm-shrunken-headers-toggle-this () "Toggle display of shrunken headers." (interactive) (save-excursion (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) (set-buffer (symbol-value 'vm-mail-buffer))) (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) (let ((o (or (car (vm-shrunken-headers-get-overlays (point))) (car (vm-shrunken-headers-get-overlays (save-excursion (end-of-line) (forward-char 1) (point))))))) (save-restriction (narrow-to-region (- (overlay-start o) 7) (overlay-end o)) (vm-shrunken-headers 'toggle) (widen))))) (defun vm-shrunken-headers-get-overlays (start &optional end) (let ((o-list (if end (overlays-in start end) (overlays-at start)))) (setq o-list (mapcar (lambda (o) (if (overlay-get o 'vm-shrunken-headers) o nil)) o-list) o-list (delete nil o-list)))) ;;;###autoload (defun vm-shrunken-headers (&optional toggle) "Hide or show headers which occupy more than one line. Well, one might do it more precisely with only some headers, but it is sufficient for me! If the optional argument TOGGLE, then hiding is toggled. The face used for the visible hidden regions is `vm-shrunken-headers-face' and the keymap used within that region is `vm-shrunken-headers-keymap'." (interactive "P") (save-excursion (let (headers-start headers-end start end o shrunken modified) (if (equal major-mode 'vm-summary-mode) (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) (set-buffer (symbol-value 'vm-mail-buffer)))) (if (equal major-mode 'vm-mode) (if vm-presentation-buffer (set-buffer vm-presentation-buffer))) ;; We cannot use the default functions (vm-headers-of, ...) since ;; we might also work within a presentation buffer. (setq modified (buffer-modified-p)) (goto-char (point-min)) (setq headers-start (point-min) headers-end (or (re-search-forward "\n\n" (point-max) t) (point-max))) (cond (toggle (setq shrunken (vm-shrunken-headers-get-overlays headers-start headers-end)) (while shrunken (setq o (car shrunken)) (let ((w (overlay-get o 'vm-shrunken-headers-widget))) (widget-toggle-action w)) (overlay-put o 'invisible (not (overlay-get o 'invisible))) (setq shrunken (cdr shrunken)))) (t (goto-char headers-start) (while (re-search-forward "^\\(\\s-+.*\n\\)+" headers-end t) (setq start (match-beginning 0) end (match-end 0)) (setq o (vm-shrunken-headers-get-overlays start end)) (if o (setq o (car o)) (setq o (make-overlay (1- start) end)) (overlay-put o 'face 'vm-shrunken-headers-face) (overlay-put o 'mouse-face 'highlight) (overlay-put o 'local-map vm-shrunken-headers-keymap) (overlay-put o 'priority 10000) ;; make a new overlay for the invisibility, the other one we ;; made before is just for highlighting and key-bindings ... (setq o (make-overlay start end)) (overlay-put o 'vm-shrunken-headers t) (goto-char (1- start)) (overlay-put o 'start-closed nil) (overlay-put o 'vm-shrunken-headers-widget (widget-create 'visibility :action 'vm-shrunken-headers-toggle-this-widget)) (overlay-put o 'invisible t))))) (set-buffer-modified-p modified) (goto-char (point-min))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-assimilate-html-command "striptags" "*Command/function which should be called for stripping tags. When this is a string, then it is a command which is fed with the html and which should return the text. Otherwise it should be a Lisp function which performs the stripping of the tags. I prefer to use lynx for this job: #!/bin/tcsh tmpfile=/tmp/$USER-stripttags.html cat > $tmpfile lynx -force_html -dump $tmpfile rm $tmpfile" :group 'vm-rfaddons :type '(string)) (defcustom vm-assimilate-html-mixed t "*Non-nil values cause messages to be assimilated as text/mixed. Otherwise they will be assimilated into a text/alternative message." :group 'vm-rfaddons :type '(boolean)) ;;;###autoload (defun vm-assimilate-html-message (&optional plain) "Try to assimilate a message which is only in html format. When called with a prefix argument then it will replace the message with the PLAIN text version otherwise it will create a text/mixed or text/alternative message depending on the value of the variable `vm-assimilate-html-mixed'." (interactive "P") (let ((vm-frame-per-edit nil) (boundary (concat (vm-mime-make-multipart-boundary))) (case-fold-search t) (qp-encoded nil) body start end charset) (vm-edit-message) (goto-char (point-min)) (goto-char (re-search-forward "\n\n")) (if (re-search-backward "^Content-Type:\\s-*\\(text/html\\)\\(.*\n?\\(^\\s-.*\\)*\\)$" (point-min) t) (progn (setq charset (buffer-substring (match-beginning 2) (match-end 2))) (if plain (progn (delete-region (match-beginning 1) (match-end 1)) (goto-char (match-beginning 1)) (insert "text/plain")) (progn (delete-region (match-beginning 1) (match-end 2)) (goto-char (match-beginning 1)) (insert "multipart/" (if vm-assimilate-html-mixed "mixed" "alternative") ";\n" " boundary=\"" boundary "\"")))) (progn (kill-this-buffer) (error "This message seems to be no HTML only message!"))) (goto-char (point-min)) (goto-char (re-search-forward "\n\n")) (setq qp-encoded (re-search-backward "^Content-Transfer-Encoding: quoted-printable" (point-min) t)) (goto-char (re-search-forward "\n\n")) (if plain (progn (setq body (point) start (point)) (goto-char (point-max)) (setq end (point))) (progn (insert "--" boundary "\n" "Content-Type: text/plain" charset "\n" "Content-Transfer-Encoding: 8bit\n\n") (setq body (point)) (insert "\n--" boundary "\n" "Content-Type: text/html" charset "\n" "Content-Transfer-Encoding: 8bit\n\n") (setq start (point-marker)) (goto-char (point-max)) (setq end (point-marker)) (insert "--" boundary "--\n"))) (if qp-encoded (vm-mime-qp-decode-region start end)) (goto-char body) (if (stringp vm-assimilate-html-command) (call-process-region start end vm-assimilate-html-command plain t) (funcall vm-assimilate-html-command start end plain)) (vm-edit-message-end) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Original Authors: Edwin Huffstutler & John Reynolds (defcustom vm-mail-mode-citation-kill-regexp-alist (list ;; empty lines multi quoted (cons (concat "^\\(" vm-included-text-prefix "[|{}>:;][^\n]*\n\\)+") "[...]\n") ;; empty quoted starting/ending lines (cons (concat "^\\([^|{}>:;]+.*\\)\n" vm-included-text-prefix "[|{}>:;]*$") "\\1") (cons (concat "^" vm-included-text-prefix "[|{}>:;]*\n" "\\([^|{}>:;]\\)") "\\1") ;; empty quoted multi lines (cons (concat "^" vm-included-text-prefix "[|{}>:;]*\\s-*\n\\(" vm-included-text-prefix "[|{}>:;]*\\s-*\n\\)+") (concat vm-included-text-prefix "\n")) ;; empty lines (cons "\n\n\n+" "\n\n") ;; signature & -----Ursprüngliche Nachricht----- (cons (concat "^" vm-included-text-prefix "--[^\n]*\n" "\\(" vm-included-text-prefix "[^\n]*\n\\)+") "\n") (cons (concat "^" vm-included-text-prefix "________[^\n]*\n" "\\(" vm-included-text-prefix "[^\n]*\n\\)+") "\n") ) "*Regexp replacement pairs for cleaning of replies." :group 'vm-rfaddons :type '(repeat (cons :tag "Kill Definition" (regexp :tag "Regexp") (string :tag "Replacement")))) (defun vm-mail-mode-citation-clean-up () "Remove doubly-cited text and extra lines in a mail message." (interactive) (save-excursion (mail-text) (let ((re-alist vm-mail-mode-citation-kill-regexp-alist) (pmin (point)) re subst) (while re-alist (goto-char pmin) (setq re (caar re-alist) subst (cdar re-alist)) (while (re-search-forward re (point-max) t) (replace-match subst)) (setq re-alist (cdr re-alist)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-summary-attachment-label "$" "*Label added to messages containing an attachments." :group 'vm-rfaddons :type '(choice (string) (const :tag "No Label" nil))) ;;;###autoload (defun vm-summary-attachment-label (msg) "Indicate if there are attachments in a message. The summary displays a `vm-summary-attachment-indicator', which is a '$' by default. In order to get this working, add a \"%1UA\" to your `vm-summary-format' and call `vm-fix-my-summary'. As a sideeffect a label can be added to new messages. Setting `vm-summary-attachment-label' to a string (the label) enables this. If you just want the label, then set `vm-summary-attachment-indicator' to nil and add an \"%0UA\" to your `vm-summary-format'." (let ((attachments 0)) (setq msg (vm-real-message-of msg)) (vm-mime-action-on-all-attachments nil (lambda (msg layout type file) (setq attachments (1+ attachments))) vm-summary-attachment-mime-types vm-summary-attachment-mime-type-exceptions (list msg) t) (when (and (> attachments 0 ) (vm-new-flag msg) (or (not (vm-labels-of msg)) (not (member vm-summary-attachment-label (vm-labels-of msg))))) (vm-set-labels msg (append (list vm-summary-attachment-label) (vm-labels-of msg)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-delete-quit () "Delete mails and quit. Expunge only if it's not the primary inbox." (interactive) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (and buffer-file-name (string-match (regexp-quote vm-primary-inbox) buffer-file-name)) (message "No auto-expunge for folder `%s'" buffer-file-name) (condition-case nil (vm-expunge-folder) (error nil))) (vm-quit))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-mail-mode-install-open-line () "Install the open-line hooks for `vm-mail-mode'. Add this to `vm-mail-mode-hook'." ;; these are not local even when using add-hook, so we make them local (vm-make-local-hook 'before-change-functions) (vm-make-local-hook 'after-change-functions) (add-hook 'before-change-functions 'vm-mail-mode-open-line nil t) (add-hook 'after-change-functions 'vm-mail-mode-open-line nil t)) (defvar vm-mail-mode-open-line nil "Flag used by `vm-mail-mode-open-line'.") (defcustom vm-mail-mode-open-line-regexp "[ \t]*>" "Regexp matching prefix of quoted text at line start.") (defun vm-mail-mode-open-line (start end &optional length) "Opens a line when inserting into the region of a reply. Insert newlines before and after an insert where necessary and does a cleanup of empty lines which have been quoted." (if (= start end) (save-excursion (beginning-of-line) (setq vm-mail-mode-open-line (if (and (eq this-command 'self-insert-command) (looking-at (concat "^" vm-mail-mode-open-line-regexp))) (if (< (point) start) (point) start)))) (if (and length (= length 0) vm-mail-mode-open-line) (let (start-mark end-mark) (save-excursion (if (< vm-mail-mode-open-line start) (progn (insert "\n\n" vm-included-text-prefix) (setq end-mark (point-marker)) (goto-char start) (setq start-mark (point-marker)) (insert "\n\n")) (if (looking-at (concat "\\(" vm-mail-mode-open-line-regexp "\\)+[ \t]*\n")) (replace-match "")) (insert "\n\n") (setq end-mark (point-marker)) (goto-char start) (setq start-mark (point-marker)) (insert "\n")) ;; clean leading and trailing garbage (let ((iq (concat "^" vm-mail-mode-open-line-regexp "[> \t]*\n"))) (save-excursion (goto-char start-mark) (beginning-of-line) (while (looking-at "^$") (forward-line -1)) ; (message "1%s<" (buffer-substring (point) (save-excursion (end-of-line) (point)))) (while (looking-at iq) (replace-match "") (forward-line -1)) (goto-char end-mark) (beginning-of-line) (while (looking-at "^$") (forward-line 1)) ; (message "3%s<" (buffer-substring (point) (save-excursion (end-of-line) (point)))) (while (looking-at iq) (replace-match ""))))) (setq vm-mail-mode-open-line nil))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-mail-mode-elide-reply-region "[...]\n" "*String which is used as replacement for elided text." :group 'vm-rfaddons :type '(string)) ;;;###autoload (defun vm-mail-mode-elide-reply-region (b e) "Replace marked region or current line with `vm-mail-elide-reply-region'. B and E are the beginning and end of the marked region or the current line." (interactive (if (mark) (if (< (mark) (point)) (list (mark) (point)) (list (point) (mark))) (list (save-excursion (beginning-of-line) (point)) (save-excursion (end-of-line) (point))))) (if (eobp) (insert "\n")) (if (mark) (delete-region b e) (delete-region b (+ 1 e))) (insert vm-mail-mode-elide-reply-region)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-save-everything () "Save all VM folder buffers, BBDB and newsrc if GNUS is started." (interactive) (save-excursion (let ((folders (vm-folder-buffers))) (while folders (set-buffer (car folders)) (message "Saving <%S>" (car folders)) (vm-save-folder) (setq folders (cdr folders)))) (if (fboundp 'bbdb-save-db) (bbdb-save-db))) (if (fboundp 'gnus-group-save-newsrc) (gnus-group-save-newsrc))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-get-all-new-mail () "Get mail for all opened VM folders." (interactive) (save-excursion (let ((buffers (buffer-list))) (while buffers (set-buffer (car buffers)) (if (eq major-mode 'vm-mode) (vm-get-new-mail)) (setq buffers (cdr buffers)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-save-message-preview (file) "Save preview of a message in FILE. It saves the decoded message and not the raw message like `vm-save-message'" (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command) filename) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (setq filename (vm-read-file-name (if vm-last-written-file (format "Write text to file: (default %s) " vm-last-written-file) "Write text to file: ") nil vm-last-written-file nil)) (if (and (file-exists-p filename) (not (yes-or-no-p (format "Overwrite '%s'? " filename)))) (error "Aborting `vm-save-message-preview'.")) (list filename)))) (save-excursion (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) (set-buffer (symbol-value 'vm-mail-buffer)) (if vm-presentation-buffer (set-buffer vm-presentation-buffer))) (write-region (point-min) (point-max) file))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This code is now obsolete. VM has built-in facilities for taking ;; actions on attachments. USR, 2010-01-05 ;; Subject: Re: How to Delete an attachment? ;; Newsgroups: gnu.emacs.vm.info ;; Date: 05 Oct 1999 11:09:19 -0400 ;; Organization: Road Runner ;; From: Dave Bakhash (defun vm-mime-take-action-on-attachment (action) "Do something with the MIME attachment at point." (interactive (list (vm-read-string "action: " '("save-to-file" "delete" "display-as-ascii" "pipe-to-command") nil))) (vm-mime-run-display-function-at-point (cond ((string= action "save-to-file") 'vm-mime-send-body-to-file) ((string= action "display-as-ascii") 'vm-mime-display-body-as-text) ((string= action "delete") (vm-delete-mime-object)) ((string= action "pipe-to-command") 'vm-mime-pipe-body-to-queried-command-discard-output)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This functionality has now been integrated into VM core. USR, 2011-01-30 (defvaralias 'vm-mime-display-internal-multipart/mixed-separator 'vm-mime-parts-display-separator) (make-obsolete-variable 'vm-mime-display-internal-multipart/mixed-separator 'vm-mime-parts-display-separator "8.2.0") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-assimilate-outlook-message () "Assimilate a message which has been forwarded by MS Outlook. You will need vm-pine.el in order to get this work." (interactive) (vm-continue-postponed-message t) (let ((pm (point-max))) (goto-char (point-min)) (if (re-search-forward "^.*\\(-----Urspr[u]ngliche Nachricht-----\\|-----Original Message-----\\)\n" pm) (delete-region 1 (match-end 0))) ;; remove the quotes from the forwarded message (while (re-search-forward "^> ?" pm t) (replace-match "")) (goto-char (point-min)) ;; rewrite headers (while (re-search-forward "^\\(Von\\|From\\):[ \t]*\\(.+\\) *\\[\\(SMTP\\|mailto\\):\\(.+\\)\\].*" pm t) (replace-match "From: \\2 <\\4>")) (while (re-search-forward "^\\(Gesendet[^:]*\\|Sent\\):[ \t]*\\(...\\).*, \\([0-9]+\\)\\. \\(...\\)[a-z]+[ \t]*\\(.*\\)" pm t) (replace-match "Date: \\3 \\4 \\5")) (while (re-search-forward "^\\(An\\|To\\):[ \t]*\\(.*\\)$" pm t) (replace-match "To: \\2")) (while (re-search-forward "^\\(Betreff\\|Subject\\):[ \t]*\\(.*\\)$" pm t) (replace-match "Subject: \\2")) (goto-char (point-min)) ;; insert mail header separator (re-search-forward "^$" pm) (goto-char (match-end 0)) (insert mail-header-separator "\n") ;; and put it back into the source folder (vm-postpone-message))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Highlighting faces ;;;###autoload (defun vm-install-rf-faces () (make-face 'message-url) (custom-set-faces '(message-url ((t (:foreground "blue" :bold t)))) '(message-headers ((t (:foreground "blue" :bold t)))) '(message-cited-text ((t (:foreground "red3")))) '(message-header-contents ((((type x)) (:foreground "green3")))) '(message-highlighted-header-contents ((((type x)) (:bold t)) (t (:bold t)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Well I like to have a different comment style a provided as default. ;; I'd like to have blank lines also prefixed by a comment char. ;; I overwrite the standard function by a slightly different version. ;;;###autoload (defun vm-mail-mode-comment-region (beg end &optional arg) "Comment or uncomment each line in the region BEG to END. With just a non-nil prefix ARG, uncomment each line in region. Numeric prefix arg ARG means use ARG comment characters. If ARG is negative, delete that many comment characters instead. Comments are terminated on each line, even for syntax in which newline does not end the comment. Blank lines do not get comments." ;; if someone wants it to only put a comment-start at the beginning and ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x ;; is easy enough. No option is made here for other than commenting ;; every line. (interactive "r\nP") (or comment-start (error "No comment syntax is defined")) (if (> beg end) (let (mid) (setq mid beg beg end end mid))) (save-excursion (save-restriction (let ((cs comment-start) (ce comment-end) numarg) (if (consp arg) (setq numarg t) (setq numarg (prefix-numeric-value arg)) ;; For positive arg > 1, replicate the comment delims now, ;; then insert the replicated strings just once. (while (> numarg 1) (setq cs (concat cs comment-start) ce (concat ce comment-end)) (setq numarg (1- numarg)))) ;; Loop over all lines from BEG to END. (narrow-to-region beg end) (goto-char beg) (while (not (eobp)) (if (or (eq numarg t) (< numarg 0)) (progn ;; Delete comment start from beginning of line. (if (eq numarg t) (while (looking-at (regexp-quote cs)) (delete-char (length cs))) (let ((count numarg)) (while (and (> 1 (setq count (1+ count))) (looking-at (regexp-quote cs))) (delete-char (length cs))))) ;; Delete comment end from end of line. (if (string= "" ce) nil (if (eq numarg t) (progn (end-of-line) ;; This is questionable if comment-end ends in ;; whitespace. That is pretty brain-damaged, ;; though. (skip-chars-backward " \t") (if (and (>= (- (point) (point-min)) (length ce)) (save-excursion (backward-char (length ce)) (looking-at (regexp-quote ce)))) (delete-char (- (length ce))))) (let ((count numarg)) (while (> 1 (setq count (1+ count))) (end-of-line) ;; This is questionable if comment-end ends in ;; whitespace. That is pretty brain-damaged though (skip-chars-backward " \t") (save-excursion (backward-char (length ce)) (if (looking-at (regexp-quote ce)) (delete-char (length ce)))))))) (forward-line 1)) ;; Insert at beginning and at end. (progn (insert cs) (if (string= "" ce) () (end-of-line) (insert ce))) (search-forward "\n" nil 'move))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Sometimes it's handy to fake a date. ;; I overwrite the standard function by a slightly different version. (defcustom vm-mail-mode-fake-date-p t "*Non-nil means `vm-mail-mode-insert-date-maybe' will not overwrite a existing date header." :group 'vm-rfaddons :type '(boolean)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-isearch-presentation () "Switches to the Presentation buffer and starts isearch." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((target (or vm-presentation-buffer (current-buffer)))) (if (get-buffer-window-list target) (select-window (car (get-buffer-window-list target))) (switch-to-buffer target))) (isearch-forward)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-delete-message-action "vm-next-message" "Command to do after deleting a message." :group 'vm-rfaddons) ;;;###autoload (defun vm-delete-message-action (&optional arg) "Delete current message and perform some action after it, e.g. move to next. Call it with a prefix ARG to change the action." (interactive "P") (when (and (listp arg) (not (null arg))) (setq vm-delete-message-action (completing-read "After delete: " '(("vm-rmail-up") ("vm-rmail-down") ("vm-previous-message") ("vm-previous-unread-message") ("vm-next-message") ("vm-next-unread-message") ("nothing")))) (message "action after delete is %S" vm-delete-message-action)) (vm-toggle-deleted (prefix-numeric-value arg)) (let ((fun (intern vm-delete-message-action))) (if (functionp fun) (call-interactively fun)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar vm-smtp-server-online-p-cache nil "Alist of cached (server online-status) entries.") (defun vm-smtp-server-online-p (&optional host port) "Opens SMTP connection to see if the server HOST on PORT is online. Results are cached in `smtp-server-online-p-cache' for non interactive calls." (interactive) (save-excursion (let (online-p server hp) (if (null host) (setq server (if (functionp 'esmtpmail-via-smtp-server) (esmtpmail-via-smtp-server) (smtpmail-via-smtp-server)) host (car server) port (cadr server))) (setq port (or port 25) hp (format "%s:%s" host port)) (if (vm-interactive-p) (setq vm-smtp-server-online-p-cache nil)) (if (assoc hp vm-smtp-server-online-p-cache) ;; take cache content (setq online-p (cadr (assoc hp vm-smtp-server-online-p-cache)) hp (concat hp " (cached)")) ;; do the check (let* ((n (format " *SMTP server check %s:%s *" host port)) (buf (get-buffer n)) (stream nil)) (if buf (kill-buffer buf)) (condition-case err (progn (setq stream (open-network-stream n n host port)) (setq online-p t)) (error (message (cadr err)) (if (and (get-buffer n) (< 0 (length (save-excursion (set-buffer (get-buffer n)) (buffer-substring (point-min) (point-max)))))) (pop-to-buffer n)))) (if stream (delete-process stream)) (when (setq buf (get-buffer n)) (set-buffer buf) (message "%S" (buffer-substring (point-min) (point-max))) (goto-char (point-min)) (when (re-search-forward "gethostbyname: Resource temporarily unavailable" (point-max) t) (setq online-p nil)))) ;; add to cache for further lookups (add-to-list 'vm-smtp-server-online-p-cache (list hp online-p))) (if (vm-interactive-p) (message "SMTP server %s is %s" hp (if online-p "online" "offline"))) online-p))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-mail-send-or-feed-it () "Sends a message if the SMTP server is online, queues it otherwise." (if (not (vm-smtp-server-online-p)) (feedmail-send-it) (if (functionp 'esmtpmail-send-it) (esmtpmail-send-it) (smtpmail-send-it)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Contributed by Alley Stoughton ;; gnu.emacs.vm.info, 2011-02-26 (defun vm-toggle-best-mime () "Toggle between best-internal and best mime decoding modes" (interactive) (if (eq vm-mime-alternative-show-method 'best-internal) (progn (vm-decode-mime-message 'undecoded) (setq vm-mime-alternative-show-method 'best) (vm-decode-mime-message 'decoded) (message "using best MIME decoding")) (progn (vm-decode-mime-message 'undecoded) (setq vm-mime-alternative-show-method 'best-internal) (vm-decode-mime-message 'decoded) (message "using best internal MIME decoding")))) ;;; vm-rfaddons.el ends here vm-8.2.0b/lisp/vm-serial.el0000755000175000017500000010411411676442160015762 0ustar srivastasrivasta;;; vm-serial.el --- automatic creation of personalized message bodies ;; and sending of personalized serial mails ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 2000-2005 Robert Widhopf-Fenk ;; ;; Author: Robert Widhopf-Fenk ;; Status: Tested with XEmacs 21.4.15 & VM 7.19 ;; Keywords: sending mail, default mail, multiple recipients, serial mails ;; X-URL: http://www.robf.de/Hacking/elisp ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; ;; ;;; Commentary: ;; ;; Are you lazy on the one hand, but you like salutations and greetings? ;; ;; YES? ;; ;; If so you got the right package here! The idea is similar to those of ;; autoinsert.el, tempo.el, template.el etc., but specialized for composing ;; mails with VM. ;; ;; You may want to use the following into your .vm file after adding other ;; vm-mail-mode-hooks ... ;; ;; (require 'vm-serial) ;; (add-hook 'vm-mail-mode-hook 'vm-serial-auto-yank-mail t) ;; (define-key vm-mail-mode-map "\C-c\C-t" 'vm-serial-expand-tokens) ;; ;; and check out what happens if you reply to a message or what happens after ;; specifying a recipient in the to header and typing [C-c C-t]. ;; ;; Isn't it cool? ;; ;; Now add multiple recipients to a mail before pressing [C-c C-t] and call ;; [M-x vm-serial-send-mail] in order to see what happens. If you are a ;; trustful guy you may add a prefix arg [C-u]. ;; ;; In order to learn more about valid tokens you should have a look at the ;; documentation mail template. ;; ;; Go to an newly mail buffer add a From and To header and type: ;; C-u M-x vm-serial-yank-mail RET doc RET ;; M-x vm-serial-expand-tokens RET ;; ;;; KNOWN PROBLEMS: ;; ;; - mail-signature: instead of using this variable, you should use ;; `vm-serial-mail-signature' with exaclty the same semantics. ;; ;;; Thanks: ;; ;; Ivan Kanis has contributed some bugfixes & enhancements. ;; ;;; Code: (provide 'vm-serial) (require 'vm-reply) (defgroup vm-serial nil "Sending personalized serial mails and getting message templates." :group 'vm-ext) (eval-when-compile (require 'cl)) (eval-when-compile (require 'vm-misc) (require 'vm-mime)) (eval-and-compile (require 'vm-pine) (require 'mail-utils) (require 'mail-extr) (require 'advice)) (declare-function bbdb-extract-address-components "ext:bbdb-snarf" (adstring &optional ignore-errors)) (declare-function bbdb-record-firstname "ext:bbdb" (record)) (declare-function bbdb-record-lastname "ext:bbdb" (record)) (declare-function bbdb-search-simple "ext:bbdb" (name net)) (declare-function bbdb-split "ext:bbdb" (string separators)) (declare-function bbdb/sc-consult-attr "ext:bbdb-sc" (from)) ;; vm-xemacs is a fake file meant to fool Emacs 23 compiler (declare-function region-exists-p "vm-xemacs" ()) (declare-function zmacs-region-buffer "vm-xemacs" ()) ;; The following function is erroneously called in fsfemacs too ;; (declare-function read-expression "vm-xemacs" ;; (prompt &optional initial-contents history default)) (let ((feature-list '(bbdb bbdb-sc))) (while feature-list (condition-case nil (require (car feature-list)) (error (if (load (format "%s" (car feature-list)) t) (message "Library %s loaded!" (car feature-list)) (message "Could not load feature %S. Related functions may not work correctly!" (car feature-list))))) (setq feature-list (cdr feature-list)))) (defvar vm-reply-list nil) (defvar vm-redistribute-list nil) (defvar vm-forward-list) ;;----------------------------------------------------------------------------- (defcustom vm-serial-token-alist '(;; standard tokens you should not change (or need not) ("to" (vm-serial-get-to) "to header of the mail") ("sir" (vm-serial-get-name 'last) "the last name of the recipient") ("you" (vm-serial-get-name 'first) "the first name of the recipient") ("mr" (vm-serial-get-name) "the full name of the recipient") ("bbdbsir" (vm-serial-get-bbdb-name 'last) "the last name of the recipient as returned by the BBDB") ("bbdbyou" (vm-serial-get-bbdb-name 'first) "the first name of the recipient as returned by the BBDB") ("bbdbmr" (vm-serial-get-bbdb-name) "the full name of the recipient as returned by the BBDB") ("me" (user-full-name) "your full name") ("i" (vm-serial-get-name 'first (user-full-name)) "your first name") ("I" (vm-serial-get-name 'last (user-full-name)) "your last name") ("point" (and (setq vm-serial-point (point)) nil) "the position of point after expanding tokens") ("reply" (if (and vm-reply-list vm-serial-body-contents) (insert vm-serial-body-contents)) "set to the message body when replying") ("forward" (if (and vm-forward-list vm-serial-body-contents) (insert vm-serial-body-contents)) "set to the message body when forwarding") ("body" (if vm-serial-body-contents (insert vm-serial-body-contents)) "set to the message body before yanking a mail template") ("sig" (cond ((not vm-serial-mail-signature) nil) ((stringp vm-serial-mail-signature) vm-serial-mail-signature) ((eq t vm-serial-mail-signature) (insert-file mail-signature-file)) ((functionp vm-serial-mail-signature) (funcall vm-serial-mail-signature)) (t (eval vm-serial-mail-signature))) "the signature obtained from `vm-serial-mail-signature'") ("fifosig" (concat "-- \n" (shell-command-to-string (concat "cat " mail-signature-file))) "a signature read from a FIFO") ;; english ("hi" ("Hi" "Hello" "Dear") "a randomly selected hi-style salutation") ("dear" ("Lovely" "Hello" "Dear" "Sweetheart") "a randomly selected dear-style salutation") ("bye" ("" "Bye " "Cheers " "CU ") "a randomly selected bye-style greeting") ("br" ("Best regards" "Sincerly" "Yours") "a randomly selected best-regards-style greeting") ("babe" ("honey" "sugar pie" "darling" "babe") "a randomly selected honey-style salutation") ("inlove" ("In love" "Dreaming of you" "1 billion kisses") "a randomly selected inlove-style greeting") ("your" ("honey" "sugar pie" "darling" "babe" (vm-serial-get-name 'first (user-full-name))) "a randomly selected your-style greeting") ;; german ("hallo" ("Hi" "Griass di" "Servus" "Hallo") "ein Hallo-Gruß") ("mausl" ("Mausl" "Liebling" "Schatzi" "Hallo") "die Freundin") ("ciao" ("" "Ciao " "Tschüß " "Servus " "Mach's gut " "Bis denn " "Bis die Tage mal ") "Verabschiedung") ("sg" ("Sehr geehrte Frau/Herr") "förmliche Anrede") ("mfg" ("Mit freundlichen Grüßen") "förmliche Verabschiedung") ;; french ("salut" ("Salut" "Bonjour") "Une salutation au hasard") ("merci" ("Merci" "Au revoir" "A+" "Amicalement") "Un au revoir au hasard") ) "*Alist for mapping tokens to real things, i.e., strings. Set this by calling `vm-serial-set-tokens'! The format of each record is: (TOKENNAME SEXPRESSION DOCUMENTATION) TOKENNAME and DOCUMENTATION have to be strings. SEXPRESSION one of - a list starting with a string, which might be followed by other string, functions or Lisp expressions - a function returning a string - a Lisp expression which evaluates to a string When a list starting with a string then `vm-serial-expand-tokens' will randomly select one of them during expansion." :group 'vm-serial :type '(repeat (list (string :tag "Tagname") (choice (repeat :tag "List of strings" (string)) (sexp :tag "Sexp evaluating to a string")) (string :tag "Documentation")))) (defcustom vm-serial-mails-alist '(("honey" "girlfriend" "$dear $babe, $point$reply $inlove $your $forward") ("german-reply" (and vm-reply-list (string-match "\\.\\(de\\|at\\|ch\\)>?$" (vm-mail-mode-get-header-contents "To:"))) "$reply $point $ciao$i") ("german-default" "\\.\\(de\\|at\\|ch\\)>?$" "$hallo $you, $point$reply $ciao$i $forward $sig") ("german-serious" "\\.\\(de\\|at\\|ch\\)>?$" "$sg $sir, $point$reply $mfg $me $forward $sig") ("english-reply" vm-reply-list "$reply $point $bye$i") ("english-default" t "$hi $you, $point$reply $bye$i $forward $sig ") ;; A test mail for showing what's possible ("doc" nil " A LECTURE ON VM-SERIAL The `vm-serial-mails-alist' contains a list of templates and associated conditions and names for these templates. When doing a `vm-serial-yank-mail' it will check for the first condition which matches and inserts this template. Tokens in the template are expanded by the function called `vm-serial-expand-tokens'. There are default tokens for various things. Tokens start with the string specified in `vm-serial-cookie' which is \"$(eval vm-serial-cookie)\" followed by a string matching the regexp \\([a-zA-Z][a-zA-Z0-9_-]*\\) which may be enclosed by {} or a lisp expressions. The first type is a named token and has to be listed in the variable `vm-serial-token-alist'. It will be expanded and if evaluating to a non nil object then it is inserted. In order to get just the `vm-serial-cookie' \"$(eval vm-serial-cookie)\" simply write it twice. You may also embed any kind of lisp expression. If they return a string, it will be inserted. Do [M-x vm-serial-expand-tokens] in order to see how things change ... Example of a embedded lisp expression: the current date is $$(format-time-string \"%D %r\"). $$(center-line) Center this line $$$no expansion The following tokens are currently defined: Token Documentation (the example follows in the next line) $(mapconcat (function (lambda (tk) (concat (car tk) \"\\t\" (caddr tk) \"\n\t$\" (car tk)))) vm-serial-token-alist \"\n\") If you thing there are other tokens which should be added to this list, please let me know! mailto:Robert Fenk")) "*Alist of default mail templates. Set this by calling `vm-serial-set-mail'! Format: ((SYMBOLIC-NAME CONDITION MAIL-FORM) ...) When calling `vm-serial-yank-mail' interactively one will be prompted for a SYMBOLIC-NAME of a mail from. If called non interactively it will search for the first condition which evaluates to true and inserts the corresponding mail. If CONDITION is a string it is matched against the To-header otherwise it is evaluated." :group 'vm-serial :type '(repeat (list (string :tag "Name") (choice :tag "Condition" (const :tag "NEVER" nil) (const :tag "ALWAYS" t) (string :tag "Regexp" "emailaddress") (variable-item :tag "Relpy" vm-reply-list) (variable-item :tag "Forward" vm-forward-list) (variable-item :tag "Redistribute" vm-redistribute-list) (sexp :tag "SEXP")) (string :tag "Message-Template")))) (defcustom vm-serial-cookie "$" "*The string which begins a token or Lisp expression. See `vm-serial-expand-tokens' for information about valid tokens." :group 'vm-serial :type 'string) (defcustom vm-serial-fcc nil "*Whether to keep a FCC from the source mail within each serial mail. If the function `vm-postpone-message' (from vm-pine) is present it will also save the source message in the specified folder otherwise there is no way to save the source message." :group 'vm-serial :type 'boolean) (defcustom vm-serial-mail-signature nil "*Text inserted at the `sig'-token of a mail buffer. The semantics are equal to those of variable `mail-signature', however you should disable variable `mail-signature', since it interacts badly with vm-serial, i.e. set vm-serial-mail-signature to the value of variable `mail-signature' and set variable `mail-signature' to nil!" :group 'vm-serial :type '(choice (const :tag "None" nil) (const :tag "The content of `mail-signature-file'" t) (function-item :tag "Function") (sexp :tag "Lisp-Form"))) (defvar vm-serial-to nil "The recipient of the currently expanded message.") (defvar vm-serial-body-contents nil "The message body of the currently replied or forwarded message.") (defcustom vm-serial-unknown-to "unknown" "*The string displayed for recipients without a real name. If set to something different than a string it will be evaluated in order to return a string." :group 'vm-serial :type 'string) (defvar vm-serial-source-buffer nil "The source buffer of the currently expanded template. When doing a `vm-serial-send-mail' this will point to the source buffer containing the original message.") (defvar vm-serial-send-mail-buffer "*vm-serial-mail*" "*Name of the buffer use by `vm-serial-send-mail' for expanded template.") (defvar vm-serial-send-mail-jobs nil "Remaining list of addresses which have to be processed after editing.") (make-variable-buffer-local 'vm-serial-source-buffer) (make-variable-buffer-local 'vm-serial-send-mail-jobs) ;;----------------------------------------------------------------------------- (defun vm-serial-get-completing-list (alist) "Return cars from ALIST for completion." (mapcar (lambda (e) (list (car e))) alist)) ;;----------------------------------------------------------------------------- (defvar vm-serial-token-history nil) (defun vm-serial-set-token (&optional token newvalue doc) "Set vm-serial TOKEN to NEWVALUE with DOC. You may remove a token by specifying just the TOKEN as argument." (interactive (let* ((token (completing-read "Token: " (vm-serial-get-completing-list vm-serial-token-alist) nil nil nil vm-serial-token-history)) (value (read-expression "Value: " (format "%S" (cdr (assoc token vm-serial-token-alist)))))) (list token value))) (let ((tk (assoc token vm-serial-token-alist))) (if tk (if newvalue (setcdr tk (list newvalue doc)) (setq vm-serial-token-alist (delete tk vm-serial-token-alist))) (setq vm-serial-token-alist (nconc vm-serial-token-alist (list (list token newvalue doc))))))) (defun vm-serial-set-tokens (token-list) "Set `vm-serial-token-alist' according to TOKEN-LIST. Is a list of (TOKEN NEWVALUE DOC) elements" (let (token-value) (while token-list (setq token-value (car token-list)) (vm-serial-set-token (car token-value) (cadr token-value) (caddr token-value)) (setq token-list (cdr token-list))))) (defun vm-serial-get-token (&optional token) "Return value of vm-serial TOKEN." (interactive (list (completing-read "Token: " (vm-serial-get-completing-list vm-serial-token-alist) nil nil nil vm-serial-token-history))) (let ((value (assoc token vm-serial-token-alist))) (if value (cadr value) (warn "There is no vm-serial token `%s'" token) nil))) (defun vm-serial-eval-token-value (&optional token-value) "Return string value by evaluation TOKEN-VALUE." (if (stringp token-value) token-value (condition-case err (cond ((and (listp token-value) (stringp (car token-value))) (setq token-value (vm-serial-random-string token-value))) ((functionp token-value) (setq token-value (funcall token-value))) (t (setq token-value (eval token-value)))) (error (setq token-value nil) (warn (format "Token `%s' caused a %S" token-value err)) nil)) token-value)) ;;----------------------------------------------------------------------------- (defun vm-serial-get-emails (&optional header) "Return the recipient of current message. Optional argument HEADER is the header to get the recipients from." (setq header (or header "To:")) (let ((to (vm-mail-mode-get-header-contents header))) (if (functionp 'bbdb-extract-address-components) (car (bbdb-extract-address-components to)) (mail-extract-address-components to)))) (defun vm-serial-get-to () "Return the recipient of current message." (or vm-serial-to (vm-serial-get-emails "To:"))) (defun vm-serial-get-name (&optional part name) (let ((name (or name (and vm-serial-to (car vm-serial-to)) (let ((to (vm-serial-get-to))) (and to (or (car to) (cadr to)))) (eval vm-serial-unknown-to))) (part (cond ((stringp part) part) ((equal part 'first) "^\\(\\w+\\)[\t ._]") ((equal part 'last) "^\\w+[\t ._]+\\(.+\\)$")))) (if (and part (string-match part name)) (match-string 1 name) name))) (defun vm-serial-get-bbdb-name (&optional part name) (let* ((to (vm-serial-get-to)) (rec (bbdb-search-simple nil (cadr to)))) (if rec (cond ((equal part 'first) (or (bbdb/sc-consult-attr (cadr to)) (bbdb-record-firstname rec))) ((equal part 'last) (bbdb-record-lastname rec))) (vm-serial-get-name part name)))) ;;----------------------------------------------------------------------------- (defun vm-serial-set-mails (mail-alist) "Set `vm-serial-mails-alist' according to MAIL-ALIST." (let (m) (setq mail-alist (reverse mail-alist)) (while mail-alist (setq m (assoc (caar mail-alist) vm-serial-mails-alist)) (if m (setq vm-serial-mails-alist (delete m vm-serial-mails-alist))) (add-to-list 'vm-serial-mails-alist (car mail-alist)) (setq mail-alist (cdr mail-alist))))) (defun vm-serial-get-mail (&optional mail) "Return the mail body associated with MAIL." (let ((value (assoc mail vm-serial-mails-alist))) (if value (car (last value)) nil))) (defvar vm-serial-mail-history nil "History for `vm-serial-yank-mail'.") (defun vm-serial-find-default-mail () "Return the first recipient." (let ((to (vm-decode-mime-encoded-words-in-string (or (vm-mail-mode-get-header-contents "To:") (vm-mail-mode-get-header-contents "CC:") (vm-mail-mode-get-header-contents "BCC:") ""))) (mails-alist vm-serial-mails-alist) m mail) (setq mail nil) (if (string-match "^\\s-*\\(.*[^ \t]\\)\\s-*$" to) (setq to (match-string 1 to))) (while mails-alist (setq m (car mails-alist)) (if (and (> (length m) 2) (cond ((stringp (cadr m)) (let ((case-fold-search t)) (string-match (cadr m) to))) ((functionp (cadr m)) (funcall (cadr m))) ((equal (cadr m) t)) (t (eval (cadr m))))) (setq mail (car m) mails-alist nil)) (setq mails-alist (cdr mails-alist))) mail)) (defun vm-serial-auto-yank-mail (&optional mail no-expand) "Yank the mail associated with MAIL. If MAIL is nil search for a default mail, i.e. the first which evaluates its condition to true. When called with a prefix argument or if NO-EXPAND is non nil no tokens will be expanded after yanking. This is like `vm-serial-yank-mail', but it ensures to yank only if the buffer is no serial mail buffer and if there was no yank-mail before!" (if (and (not vm-serial-source-buffer) (not vm-redistribute-list) (not (local-variable-p 'vm-serial-body-contents (current-buffer))) (boundp 'vm-postponed-message-folder-buffer) (not vm-postponed-message-folder-buffer)) (vm-serial-yank-mail (or mail (vm-serial-find-default-mail)) no-expand))) (defvar vm-serial-yank-mail-choice nil) (make-variable-buffer-local 'vm-serial-yank-mail-choice) (defun vm-serial-yank-mail (&optional mail no-expand) "Yank the template associated with MAIL. If MAIL is nil search for a default template, i.e. the first one which evaluates its condition to true. When called with a prefix argument ask for a template and with another prefix argument or if NO-EXPAND is non nil no tokens will be expanded after yanking. You may bind this to [C-c C-t] in mail-mode in order to automatically yank the right mail into the composition buffer and move the cursor to the editing point. I try to be clever when to delete the existing buffer contents and when to expand the tokens, however if this does not satisfy you please report it to me." (interactive "p") (if (numberp mail) (if (= mail 1) (setq mail nil) (setq no-expand (if (= mail 16) '(t)) mail (completing-read "Mail: " (vm-serial-get-completing-list vm-serial-mails-alist) nil t;; exact match (cons (vm-serial-find-default-mail) 0) vm-serial-mail-history) vm-serial-yank-mail-choice mail))) (setq mail (or mail vm-serial-yank-mail-choice (vm-serial-find-default-mail))) (let ((save-point (point))) (if (not mail) (message "There is no matching mail form!") (if (local-variable-p 'vm-serial-body-contents (current-buffer)) (progn (delete-region (mail-text) (point-max)) (setq no-expand (if (and no-expand (listp no-expand)) no-expand 'not)))) (if (or (vm-interactive-p) (local-variable-p 'vm-serial-body-contents (current-buffer))) (message "Inserting serial mail `%S'." mail) (let ((start (mail-text)) (end (goto-char (point-max)))) (make-local-variable 'vm-serial-body-contents) (make-local-variable 'vm-serial-to) (setq vm-serial-to nil vm-serial-body-contents nil) (if (not (or vm-reply-list vm-forward-list)) (setq no-expand (if (equal no-expand 'not) nil (if (and no-expand (listp no-expand)) no-expand t))) (setq vm-serial-body-contents (buffer-substring start end)) (delete-region start end)))) (let ((value (vm-serial-get-mail mail))) (save-excursion (insert value))) (if (or (and (not vm-forward-list) (not no-expand)) (equal no-expand 'not)) (vm-serial-expand-tokens) (goto-char save-point))))) ;;----------------------------------------------------------------------------- (defun vm-serial-random-string (string-list) "Randomly return one of the strings in STRING-LIST." (let ((value (nth (mod (random) (length string-list)) string-list))) (cond ((stringp value) value) ((functionp value) (funcall value)) (t (eval value))))) (defun vm-serial-expand-tokens (&optional rstart rend) "Expand all tokens within the current mail. This means we search for the `vm-serial-cookie' and if it is followed by a regexp of \"[a-zA-Z][a-zA-Z0-9_-]\" we treat this as a symbol to look up in our `vm-serial-token-alist'. Optionally one may enclose the symbol by curly parenthesis. See the test mail in `vm-serial-mails-alist' for examples. If the cookie is followed by a parenthesis then it is treated as a lisp expression which is evaluated Results evaluating to a string are inserted all other return values are ignored. For non existing tokens or errors during evaluation one will get a warning." (interactive) (let ((token-regexp (concat (regexp-quote vm-serial-cookie) "\\(" (regexp-quote vm-serial-cookie) "\\)*" "[{\(a-zA-Z]")) start end expr result vm-serial-point) (if (and vm-xemacs-p (region-exists-p) (eq (zmacs-region-buffer) (current-buffer))) (setq rstart (goto-char (region-beginning)) rend (region-end)) (setq rstart (mail-text) rend (point-max))) (narrow-to-region rstart rend) (while (re-search-forward token-regexp (point-max) t) (backward-char 1) (setq start (- (match-end 0) 1) result nil) (cond ((> (length (match-string 1)) 0) (delete-region (match-beginning 1) (match-end 1))) ((looking-at "(") (setq end (scan-sexps start 1)) (goto-char start) (setq expr (read (current-buffer))) (delete-region (- start 1) end) (setq result (vm-serial-eval-token-value expr))) ((looking-at "\\({\\)?\\([a-zA-Z][a-zA-Z0-9_-]*\\)\\(}\\)?") (setq start (match-beginning 2)) (setq end (match-end 2)) (setq expr (buffer-substring start end)) (if (and (not (and (match-end 1) (match-end 3))) (or (match-end 1) (match-end 3))) (error "Invalid token expression `%s'" (match-string 0))) (delete-region (- (match-beginning 0) 1) (match-end 0)) (setq result (vm-serial-eval-token-value (vm-serial-get-token expr)))) ) (if (and result (stringp result)) (insert (format "%s" result)))) (widen) (if vm-serial-point (goto-char vm-serial-point)))) (defvar vm-serial-insert-token-history nil) (defun vm-serial-insert-token (token) "Reads a valid token, inserts it at point and expands it." (interactive (list (completing-read (format "Token%s: " (if vm-serial-insert-token-history (concat " (default: " (car vm-serial-insert-token-history) ")") "")) (mapcar (lambda (tok) (list (car tok))) vm-serial-token-alist) nil t nil 'vm-serial-insert-token-history))) (setq vm-serial-insert-token-history (delete "" vm-serial-insert-token-history)) (if (string= "" token) (setq token (car vm-serial-insert-token-history))) (if (null token) (error "Error: you have to enter a toke name!")) (let ((start (point))) (insert vm-serial-cookie token) (vm-serial-expand-tokens start (point)))) ;;----------------------------------------------------------------------------- (defvar vm-serial-sent-cnt nil) (defvar vm-serial-edited-cnt nil) (defvar vm-serial-killed-cnt nil) (defvar vm-serial-send-mail-exit nil) (defun vm-serial-send-mail-increment (variable) (save-excursion (set-buffer vm-serial-source-buffer) (eval (list 'vm-increment variable)))) (defun vm-serial-send-mail-and-exit (&optional non-interactive) "Like `vm-serial-send-mail' but kills the buffer after sending all." (interactive "P") (make-local-variable 'vm-serial-send-mail-exit) (setq vm-serial-send-mail-exit t) (vm-serial-send-mail non-interactive)) (defun vm-serial-send-mail (&optional non-interactive done) "Send an expanded mail to each recipient listed in the To-header. This will create a new buffer for expanding the tokens and user interaction. You may send each mail interactively, that means you may send the message as it is, or you may edit it before sending or you may skip it. If called with a prefix argument or NON-INTERACTIVE set to non nil, no questions will bother you!" (interactive "P") (remove-hook 'kill-buffer-hook 'vm-serial-send-mail t) (if vm-serial-source-buffer (progn (set-buffer vm-serial-source-buffer) (setq done t))) (if (get-buffer vm-serial-send-mail-buffer) (save-excursion (kill-buffer (get-buffer vm-serial-send-mail-buffer)))) (let* ((work-buffer (save-excursion (let ((vm-frame-per-composition nil)) (flet ((vm-display (buffer display commands configs &optional do-not-raise) nil)) (vm-mail-internal :buffer-name vm-serial-send-mail-buffer)) (get-buffer vm-serial-send-mail-buffer)))) (source-buffer (current-buffer)) work to to-string) (if (and (not vm-serial-send-mail-jobs) (not done)) (if (not (setq to (mail-fetch-field "To" nil t))) (error "There are no recipients in %s!" (buffer-name)) (setq vm-serial-send-mail-jobs (if (functionp 'bbdb-extract-address-components) (bbdb-extract-address-components to) (mapcar 'mail-extract-address-components (bbdb-split to ",")))) (make-local-variable 'vm-serial-sent-cnt) (make-local-variable 'vm-serial-edited-cnt) (make-local-variable 'vm-serial-killed-cnt) (setq vm-serial-sent-cnt 0 vm-serial-edited-cnt 0 vm-serial-killed-cnt 0))) ;; mail-extract-address-components isn't good at all! Fix it! (save-excursion (set-buffer work-buffer) (setq major-mode 'mail-mode)) (while (and (not work) vm-serial-send-mail-jobs) (setq to (car vm-serial-send-mail-jobs) to-string (if (car to) (concat (car to) " <" (cadr to) ">") (cadr to))) (copy-to-buffer work-buffer (point-min) (point-max)) (save-excursion (set-buffer work-buffer) (goto-char (point-min)) (vm-mail-mode-remove-header "To:") (mail-position-on-field "To") (insert to-string) (if (not vm-serial-fcc) (vm-mail-mode-remove-header "FCC:")) (setq vm-serial-to to vm-serial-source-buffer source-buffer) (setq buffer-undo-list t) (vm-serial-expand-tokens) (if (not non-interactive) (let (command) (switch-to-buffer work-buffer) (while (not command) (message "(q)uit session or (e)dit, (s)end or (k)ill this mail to `%s'?" to) (setq command (read-char-exclusive)) (cond ((= command ?e) (vm-serial-send-mail-increment 'vm-serial-edited-cnt) (setq work 'edit)) ((= command ?s) (vm-serial-send-mail-increment 'vm-serial-sent-cnt) (vm-mail-send)) ((= command ?k) (vm-serial-send-mail-increment 'vm-serial-killed-cnt)) ((= command ?q) (setq work 'quit)) (t (message "Invalid command!") (sit-for 1) (setq command nil))))) (vm-mail-send) (vm-serial-send-mail-increment 'vm-serial-sent-cnt))) (setq vm-serial-send-mail-jobs (cdr vm-serial-send-mail-jobs))) ;; ok there was an exit or the like (if (equal work 'edit) (progn ;; and we want to edit the outgoing mail before sending (switch-to-buffer work-buffer) (run-hooks 'vm-mail-hook) (run-hooks 'vm-mail-mode-hook) (setq buffer-undo-list nil) (vm-make-local-hook 'kill-buffer-hook) (vm-make-local-hook 'mail-send-hook) (add-hook 'kill-buffer-hook (lambda () (vm-serial-send-mail-increment 'vm-serial-killed-cnt)) t t) (add-hook 'kill-buffer-hook 'vm-serial-send-mail t t) (add-hook 'mail-send-hook (lambda () (vm-serial-send-mail-increment 'vm-serial-sent-cnt)) t t) (remove-hook 'kill-buffer-hook 'vm-save-killed-message-hook t) (message "Kill or send this mail to get to the next mail!")) ;; get rid of the work buffer and go back to the source (kill-buffer work-buffer) (switch-to-buffer source-buffer) (if (not (equal work 'quit)) (let ((fcc (vm-mail-mode-get-header-contents "FCC:"))) ;; some statistics (message "%s mail%s sent, %s edited and %s killed by vm-serial!" (if (= vm-serial-sent-cnt 1) "One" vm-serial-sent-cnt) (if (= vm-serial-sent-cnt 1) "" "s") vm-serial-edited-cnt vm-serial-killed-cnt) ;; this was the last mail so is there some FCC work to do? (if (and fcc (not vm-serial-send-mail-jobs)) (if (not (functionp 'vm-postpone-message)) (error "vm-pine.el is needed to save source messages!") ;; no postponed header for this!! (vm-mail-mode-remove-header "FCC:") (vm-postpone-message fcc vm-serial-send-mail-exit t)) (if vm-serial-send-mail-exit (kill-this-buffer)))))))) (defadvice vm-mail-send-and-exit (after vm-serial-send-mail activate) (if vm-serial-source-buffer (kill-this-buffer))) ;;----------------------------------------------------------------------------- ;;; vm-serial.el ends here vm-8.2.0b/lisp/vm-mouse.el0000755000175000017500000006275411676442160015650 0ustar srivastasrivasta;;; vm-mouse.el --- Mouse related functions and commands ;; ;; This file is part of VM ;; ;; Copyright (C) 1995-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-mouse) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-thread) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-menu) ) (declare-function vm-mail-to-mailto-url "vm-reply" (url)) (declare-function event-window "vm-xemacs" (event)) (declare-function event-point "vm-xemacs" (event)) (defun vm-mouse-set-mouse-track-highlight (start end &optional overlay) "Create and return an overlay for mouse selection from START to END. If the optional argument OVERLAY is provided then that that overlay is moved to cover START to END. No new overlay is created in that case. USR, 2010-08-01" (if (null overlay) (cond (vm-fsfemacs-p (let ((o (make-overlay start end))) (overlay-put o 'mouse-face 'highlight) o )) (vm-xemacs-p (let ((o (vm-make-extent start end))) (vm-set-extent-property o 'start-open t) (vm-set-extent-property o 'priority 10) (vm-set-extent-property o 'highlight t) o ))) (cond (vm-fsfemacs-p (move-overlay overlay start end)) (vm-xemacs-p (vm-set-extent-endpoints overlay start end))))) ;;;###autoload (defun vm-mouse-button-2 (event) "The immediate action event in VM buffers, depending on where the mouse is clicked. See Info node `(VM) Using the Mouse'." (interactive "e") ;; go to where the event occurred (cond ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event)))) ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))))) ;; now dispatch depending on where we are (cond ((eq major-mode 'vm-summary-mode) (mouse-set-point event) (beginning-of-line) (if (let ((vm-follow-summary-cursor t)) (vm-follow-summary-cursor)) nil (setq this-command 'vm-scroll-forward) (call-interactively 'vm-scroll-forward))) ((eq major-mode 'vm-folders-summary-mode) (mouse-set-point event) (beginning-of-line) (vm-follow-folders-summary-cursor)) ((memq major-mode '(vm-mode vm-virtual-mode vm-presentation-mode)) (vm-mouse-popup-or-select event)))) ;;;###autoload (defun vm-mouse-button-3 (event) "Brings up the context-sensitive menu in VM buffers, depending on where the mouse is clicked. See Info node `(VM) Using the Mouse'." (interactive "e") (if vm-use-menus (progn ;; go to where the event occurred (cond ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event)))) ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))))) ;; now dispatch depending on where we are (cond ((eq major-mode 'vm-summary-mode) (vm-menu-popup-mode-menu event)) ((eq major-mode 'vm-mode) (vm-menu-popup-context-menu event)) ((eq major-mode 'vm-presentation-mode) (vm-menu-popup-context-menu event)) ((eq major-mode 'vm-virtual-mode) (vm-menu-popup-context-menu event)) ((eq major-mode 'mail-mode) (vm-menu-popup-context-menu event)))))) (defun vm-mouse-3-help (object) nil "Use mouse button 3 to see a menu of options.") (defun vm-mouse-get-mouse-track-string (event) (save-excursion ;; go to where the event occurred (cond ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event)))) ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))))) (cond (vm-fsfemacs-p (let ((o-list (overlays-at (point))) (string nil)) (while o-list (if (overlay-get (car o-list) 'mouse-face) (setq string (vm-buffer-substring-no-properties (overlay-start (car o-list)) (overlay-end (car o-list))) o-list nil) (setq o-list (cdr o-list)))) string )) (vm-xemacs-p (let ((e (vm-extent-at (point) 'highlight))) (if e (buffer-substring (vm-extent-start-position e) (vm-extent-end-position e)) nil))) (t nil)))) ;;;###autoload (defun vm-mouse-popup-or-select (event) (interactive "e") (cond ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) (let (o-list (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (cond ((overlay-get (car o-list) 'vm-url) (setq found t) (vm-mouse-send-url-at-event event)) ((overlay-get (car o-list) 'vm-mime-function) (setq found t) (funcall (overlay-get (car o-list) 'vm-mime-function) (car o-list)))) (setq o-list (cdr o-list))) (and (not found) (vm-menu-popup-context-menu event)))) ;; The XEmacs code is not actually used now, since all ;; selectable objects are handled by an extent keymap ;; binding that points to a more specific function. But ;; this might come in handy later if I want selectable ;; objects that don't have an extent keymap attached. ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event))) (let (e) (cond ((vm-extent-at (point) 'vm-url) (vm-mouse-send-url-at-event event)) ((setq e (vm-extent-at (point) 'vm-mime-function)) (funcall (vm-extent-property e 'vm-mime-function) e)) (t (vm-menu-popup-context-menu event))))))) ;;;###autoload (defun vm-mouse-send-url-at-event (event) (interactive "e") (cond ((vm-mouse-xemacs-mouse-p) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event))) (vm-mouse-send-url-at-position (event-point event))) ((vm-mouse-fsfemacs-mouse-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) (vm-mouse-send-url-at-position (posn-point (event-start event)))))) (defun vm-mouse-send-url-at-position (pos &optional browser) (save-restriction (widen) (cond ((vm-mouse-xemacs-mouse-p) (let ((e (vm-extent-at pos 'vm-url)) url) (if (null e) nil (setq url (buffer-substring (vm-extent-start-position e) (vm-extent-end-position e))) (vm-mouse-send-url url browser)))) ((vm-mouse-fsfemacs-mouse-p) (let (o-list url o) (setq o-list (overlays-at pos)) (while (and o-list (null (overlay-get (car o-list) 'vm-url))) (setq o-list (cdr o-list))) (if (null o-list) nil (setq o (car o-list)) (setq url (vm-buffer-substring-no-properties (overlay-start o) (overlay-end o))) (vm-mouse-send-url url browser))))))) (defun vm-mouse-send-url (url &optional browser switches) (if (string-match "^[A-Za-z0-9._-]+@[A-Za-z0-9._-]+$" url) (setq url (concat "mailto:" url))) (if (string-match "^mailto:" url) (vm-mail-to-mailto-url url) (let ((browser (or browser vm-url-browser)) (switches (or switches vm-url-browser-switches))) (cond ((symbolp browser) (funcall browser url)) ((stringp browser) (vm-inform 5 "Sending URL to %s..." browser) (apply 'vm-run-background-command browser (append switches (list url))) (vm-inform 5 "Sending URL to %s... done" browser)))))) (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) ;; Change commas to %2C to avoid confusing Netscape -remote. (while (string-match "," url) (setq url (replace-match "%2C" nil t url))) (vm-inform 5 "Sending URL to Netscape...") (if new-netscape (apply 'vm-run-background-command vm-netscape-program (append vm-netscape-program-switches (list url))) (or (equal 0 (apply 'vm-run-command vm-netscape-program (append vm-netscape-program-switches (list "-remote" (concat "openURL(" url (if new-window ",new-window" "") ")"))))) (vm-mouse-send-url-to-netscape url t new-window))) (vm-inform 5 "Sending URL to Netscape... done")) (defun vm-mouse-send-url-to-opera (url &optional new-opera new-window) ;; Change commas to %2C to avoid confusing Netscape -remote. (while (string-match "," url) (setq url (replace-match "%2C" nil t url))) (vm-inform 5 "Sending URL to Opera...") (if new-opera (apply 'vm-run-background-command vm-opera-program (append vm-opera-program-switches (list url))) (or (equal 0 (apply 'vm-run-command vm-opera-program (append vm-opera-program-switches (list "-remote" (concat "openURL(" url ")"))))) (vm-mouse-send-url-to-opera url t new-window))) (vm-inform 5 "Sending URL to Opera... done")) (defun vm-mouse-send-url-to-mozilla (url &optional new-mozilla new-window) ;; Change commas to %2C to avoid confusing Netscape -remote. (while (string-match "," url) (setq url (replace-match "%2C" nil t url))) (vm-inform 5 "Sending URL to Mozilla...") (if new-mozilla (apply 'vm-run-background-command vm-mozilla-program (append vm-mozilla-program-switches (list url))) (or (equal 0 (apply 'vm-run-command vm-mozilla-program (append vm-mozilla-program-switches (list "-remote" (concat "openURL(" url (if new-window ",new-window" "") ")"))))) (vm-mouse-send-url-to-mozilla url t new-window))) (vm-inform 5 "Sending URL to Mozilla... done")) (defun vm-mouse-send-url-to-netscape-new-window (url) (vm-mouse-send-url-to-netscape url nil t)) (defun vm-mouse-send-url-to-opera-new-window (url) (vm-mouse-send-url-to-opera url nil t)) (defun vm-mouse-send-url-to-mozilla-new-window (url) (vm-mouse-send-url-to-mozilla url nil t)) (defvar buffer-file-type) (defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window) (vm-mouse-send-url-to-xxxx-mosaic 'mosaic url new-mosaic new-window)) (defun vm-mouse-send-url-to-mmosaic (url &optional new-mosaic new-window) (vm-mouse-send-url-to-xxxx-mosaic 'mmosaic url new-mosaic new-window)) (defun vm-mouse-send-url-to-xxxx-mosaic (m-type url &optional new-mosaic new-window) (let ((what (cond ((eq m-type 'mmosaic) "mMosaic") (t "Mosaic")))) (vm-inform 5 "Sending URL to %s..." what) (if (null new-mosaic) (let ((pid-file (cond ((eq m-type 'mmosaic) "~/.mMosaic/.mosaicpid") (t "~/.mosaicpid"))) (work-buffer " *mosaic work*") (coding-system-for-read (vm-line-ending-coding-system)) (coding-system-for-write (vm-line-ending-coding-system)) pid) (cond ((file-exists-p pid-file) (set-buffer (get-buffer-create work-buffer)) (setq selective-display nil) (erase-buffer) (insert-file-contents pid-file) (setq pid (int-to-string (string-to-number (buffer-string)))) (erase-buffer) (insert (if new-window "newwin" "goto") ?\n) (insert url ?\n) ;; newline convention used should be the local ;; one, whatever that is. (setq buffer-file-type nil) (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-line-ending-coding-system) nil)) (write-region (point-min) (point-max) (concat "/tmp/Mosaic." pid) nil 0) (set-buffer-modified-p nil) (kill-buffer work-buffer))) (cond ((or (null pid) (not (equal 0 (vm-run-command "kill" "-USR1" pid)))) (setq new-mosaic t))))) (if new-mosaic (apply 'vm-run-background-command (cond ((eq m-type 'mmosaic) vm-mmosaic-program) (t vm-mosaic-program)) (append (cond ((eq m-type 'mmosaic) vm-mmosaic-program-switches) (t vm-mosaic-program-switches)) (list url)))) (vm-inform 5 "Sending URL to %s... done" what))) (defun vm-mouse-send-url-to-mosaic-new-window (url) (vm-mouse-send-url-to-mosaic url nil t)) (defun vm-mouse-send-url-to-konqueror (url &optional new-konqueror) (vm-inform 5 "Sending URL to Konqueror...") (if new-konqueror (apply 'vm-run-background-command vm-konqueror-program (append vm-konqueror-program-switches (list url))) (or (equal 0 (apply 'vm-run-command vm-konqueror-client-program (append vm-konqueror-client-program-switches (list "openURL" url)))) (vm-mouse-send-url-to-konqueror url t))) (vm-inform 5 "Sending URL to Konqueror... done")) (defun vm-mouse-send-url-to-firefox (url &optional new-window) (vm-inform 5 "Sending URL to Mozilla Firefox...") (if new-window (apply 'vm-run-background-command vm-firefox-program (append vm-firefox-program-switches (list url))) (or (equal 0 (apply 'vm-run-command vm-firefox-client-program (append vm-firefox-client-program-switches (list (format "openURL(%s)" url))))) (vm-mouse-send-url-to-firefox url t))) (vm-inform 5 "Sending URL to Mozilla Firefox... done")) (defun vm-mouse-send-url-to-konqueror-new-window (url) (vm-mouse-send-url-to-konqueror url t)) (defvar vm-warn-for-interprogram-cut-function t) (defun vm-mouse-send-url-to-window-system (url) (unless interprogram-cut-function (when vm-warn-for-interprogram-cut-function (vm-warn 1 2 (concat "Copying to kill ring only; " "Customize interprogram-cut-function to copy to Window system")) (setq vm-warn-for-interprogram-cut-function nil))) (kill-new url)) (defun vm-mouse-send-url-to-clipboard (url &optional type) (unless type (setq type 'CLIPBOARD)) (vm-inform 5 "Sending URL to %s..." type) (cond ((fboundp 'own-selection) ; XEmacs (own-selection url type)) ((fboundp 'x-set-selection) ; Gnu Emacs (x-set-selection type url)) ((fboundp 'x-own-selection) ; lselect for Emacs21? (x-own-selection url type))) (vm-inform 5 "Sending URL to %s... done" type)) ;;;###autoload (defun vm-mouse-install-mouse () (cond ((vm-mouse-xemacs-mouse-p) (if (null (lookup-key vm-mode-map 'button2)) (define-key vm-mode-map 'button2 'vm-mouse-button-2))) ((vm-mouse-fsfemacs-mouse-p) (if (null (lookup-key vm-mode-map [mouse-2])) (define-key vm-mode-map [mouse-2] 'vm-mouse-button-2)) (if vm-popup-menu-on-mouse-3 (progn (define-key vm-mode-map [mouse-3] 'ignore) (define-key vm-mode-map [down-mouse-3] 'vm-mouse-button-3)))))) (defun vm-run-background-command (command &rest arg-list) (vm-inform 5 "vm-run-background-command: %S %S" command arg-list) (apply (function call-process) command nil 0 nil arg-list)) (defun vm-run-command (command &rest arg-list) (vm-inform 5 "vm-run-command: %S %S" command arg-list) (apply (function call-process) command nil (get-buffer-create (concat " *" command "*")) nil arg-list)) ;; return t on zero exit status ;; return (exit-status . stderr-string) on nonzero exit status (defun vm-run-command-on-region (start end output-buffer command &rest arg-list) (let ((tempfile nil) ;; use binary coding system in FSF Emacs/MULE (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (buffer-file-format nil) ;; for DOS/Windows command to tell it that its input is ;; binary. (binary-process-input t) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (selective-display nil) status errstring) (unwind-protect (progn (setq tempfile (vm-make-tempfile-name)) (setq status (apply 'call-process-region start end command nil (list output-buffer tempfile) nil arg-list)) (cond ((equal status 0) t) ;; even if exit status non-zero, if there was no ;; diagnostic output the command probably ;; succeeded. I have tried to just use exit status ;; as the failure criterion and users complained. ((equal (nth 7 (file-attributes tempfile)) 0) (vm-warn 0 0 "%s exited non-zero (code %s)" command status) t) (t (save-excursion (vm-warn 0 0 "%s exited non-zero (code %s)" command status) (set-buffer (find-file-noselect tempfile)) (setq errstring (buffer-string)) (kill-buffer nil) (cons status errstring))))) (vm-error-free-call 'delete-file tempfile)))) ;; stupid yammering compiler (defvar vm-mouse-read-file-name-prompt) (defvar vm-mouse-read-file-name-dir) (defvar vm-mouse-read-file-name-default) (defvar vm-mouse-read-file-name-must-match) (defvar vm-mouse-read-file-name-initial) (defvar vm-mouse-read-file-name-history) (defvar vm-mouse-read-file-name-return-value) (defvar vm-mouse-read-file-name-should-delete-frame) (defun vm-mouse-read-file-name (prompt &optional dir default must-match initial history) "Like read-file-name, except uses a mouse driven interface. HISTORY argument is ignored." (save-excursion (or dir (setq dir default-directory)) (set-buffer (vm-make-work-buffer " *Files*")) (use-local-map (make-sparse-keymap)) (setq buffer-read-only t default-directory dir) (make-local-variable 'vm-mouse-read-file-name-prompt) (make-local-variable 'vm-mouse-read-file-name-dir) (make-local-variable 'vm-mouse-read-file-name-default) (make-local-variable 'vm-mouse-read-file-name-must-match) (make-local-variable 'vm-mouse-read-file-name-initial) (make-local-variable 'vm-mouse-read-file-name-history) (make-local-variable 'vm-mouse-read-file-name-return-value) (make-local-variable 'vm-mouse-read-file-name-should-delete-frame) (setq vm-mouse-read-file-name-prompt prompt) (setq vm-mouse-read-file-name-dir dir) (setq vm-mouse-read-file-name-default default) (setq vm-mouse-read-file-name-must-match must-match) (setq vm-mouse-read-file-name-initial initial) (setq vm-mouse-read-file-name-history history) (setq vm-mouse-read-file-name-prompt prompt) (setq vm-mouse-read-file-name-return-value nil) (setq vm-mouse-read-file-name-should-delete-frame nil) (if (and vm-mutable-frame-configuration vm-frame-per-completion (vm-multiple-frames-possible-p)) (save-excursion (setq vm-mouse-read-file-name-should-delete-frame t) (vm-goto-new-frame 'completion))) (switch-to-buffer (current-buffer)) (vm-mouse-read-file-name-event-handler) (save-excursion (local-set-key "\C-g" 'vm-mouse-read-file-name-quit-handler) (recursive-edit)) ;; buffer could have been killed (and (boundp 'vm-mouse-read-file-name-return-value) (prog1 vm-mouse-read-file-name-return-value (kill-buffer (current-buffer)))))) (defun vm-mouse-read-file-name-event-handler (&optional string) (let ((key-doc "Click here for keyboard interface.") start list) (if string (cond ((equal string key-doc) (condition-case nil (save-excursion (setq vm-mouse-read-file-name-return-value (save-excursion (vm-keyboard-read-file-name vm-mouse-read-file-name-prompt vm-mouse-read-file-name-dir vm-mouse-read-file-name-default vm-mouse-read-file-name-must-match vm-mouse-read-file-name-initial vm-mouse-read-file-name-history))) (vm-mouse-read-file-name-quit-handler t)) (quit (vm-mouse-read-file-name-quit-handler)))) ((file-directory-p string) (setq default-directory (expand-file-name string))) (t (setq vm-mouse-read-file-name-return-value (expand-file-name string)) (vm-mouse-read-file-name-quit-handler t)))) (setq buffer-read-only nil) (erase-buffer) (setq start (point)) (insert vm-mouse-read-file-name-prompt) (vm-set-region-face start (point) 'bold) (cond ((and (not string) vm-mouse-read-file-name-default) (setq start (point)) (insert vm-mouse-read-file-name-default) (vm-mouse-set-mouse-track-highlight start (point)) ) ((not string) nil) (t (insert default-directory))) (insert ?\n ?\n) (setq start (point)) (insert key-doc) (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n ?\n) (setq list (vm-delete-backup-file-names (vm-delete-auto-save-file-names (vm-delete-index-file-names (directory-files default-directory))))) ;; delete dot files (setq list (vm-delete (lambda (file) (string-match "^\\.\\([^.].*\\)?$" file)) list)) ;; append a "/" to directories (setq list (mapcar (lambda (file) (if (file-directory-p file) (concat file "/") file)) list)) (vm-show-list list 'vm-mouse-read-file-name-event-handler) (setq buffer-read-only t))) ;;;###autoload (defun vm-mouse-read-file-name-quit-handler (&optional normal-exit) (interactive) (if vm-mouse-read-file-name-should-delete-frame (vm-maybe-delete-windows-or-frames-on (current-buffer))) (if normal-exit (throw 'exit nil) (throw 'exit t))) (defvar vm-mouse-read-string-prompt) (defvar vm-mouse-read-string-completion-list) (defvar vm-mouse-read-string-multi-word) (defvar vm-mouse-read-string-return-value) (defvar vm-mouse-read-string-should-delete-frame) (defun vm-mouse-read-string (prompt completion-list &optional multi-word) (save-excursion (set-buffer (vm-make-work-buffer " *Choices*")) (use-local-map (make-sparse-keymap)) (setq buffer-read-only t) (make-local-variable 'vm-mouse-read-string-prompt) (make-local-variable 'vm-mouse-read-string-completion-list) (make-local-variable 'vm-mouse-read-string-multi-word) (make-local-variable 'vm-mouse-read-string-return-value) (make-local-variable 'vm-mouse-read-string-should-delete-frame) (setq vm-mouse-read-string-prompt prompt) (setq vm-mouse-read-string-completion-list completion-list) (setq vm-mouse-read-string-multi-word multi-word) (setq vm-mouse-read-string-return-value nil) (setq vm-mouse-read-string-should-delete-frame nil) (if (and vm-mutable-frame-configuration vm-frame-per-completion (vm-multiple-frames-possible-p)) (save-excursion (setq vm-mouse-read-string-should-delete-frame t) (vm-goto-new-frame 'completion))) (switch-to-buffer (current-buffer)) (vm-mouse-read-string-event-handler) (save-excursion (local-set-key "\C-g" 'vm-mouse-read-string-quit-handler) (recursive-edit)) ;; buffer could have been killed (and (boundp 'vm-mouse-read-string-return-value) (prog1 (if (listp vm-mouse-read-string-return-value) (mapconcat 'identity vm-mouse-read-string-return-value " ") vm-mouse-read-string-return-value) (kill-buffer (current-buffer)))))) (defun vm-mouse-read-string-event-handler (&optional string) (let ((key-doc "Click here for keyboard interface.") (bs-doc " .... to go back one word.") (done-doc " .... when you're done.") start list) (if string (cond ((equal string key-doc) (condition-case nil (save-excursion (setq vm-mouse-read-string-return-value (vm-keyboard-read-string vm-mouse-read-string-prompt vm-mouse-read-string-completion-list vm-mouse-read-string-multi-word)) (vm-mouse-read-string-quit-handler t)) (quit (vm-mouse-read-string-quit-handler)))) ((equal string bs-doc) (setq vm-mouse-read-string-return-value (nreverse (cdr (nreverse vm-mouse-read-string-return-value))))) ((equal string done-doc) (vm-mouse-read-string-quit-handler t)) (t (setq vm-mouse-read-string-return-value (nconc vm-mouse-read-string-return-value (list string))) (if (null vm-mouse-read-string-multi-word) (vm-mouse-read-string-quit-handler t))))) (setq buffer-read-only nil) (erase-buffer) (setq start (point)) (insert vm-mouse-read-string-prompt) (vm-set-region-face start (point) 'bold) (insert (mapconcat 'identity vm-mouse-read-string-return-value " ")) (insert ?\n ?\n) (setq start (point)) (insert key-doc) (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n) (if vm-mouse-read-string-multi-word (progn (setq start (point)) (insert bs-doc) (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n) (setq start (point)) (insert done-doc) (vm-mouse-set-mouse-track-highlight start (point)) (vm-set-region-face start (point) 'italic) (insert ?\n))) (insert ?\n) (vm-show-list vm-mouse-read-string-completion-list 'vm-mouse-read-string-event-handler) (setq buffer-read-only t))) ;;;###autoload (defun vm-mouse-read-string-quit-handler (&optional normal-exit) (interactive) (if vm-mouse-read-string-should-delete-frame (vm-maybe-delete-windows-or-frames-on (current-buffer))) (if normal-exit (throw 'exit nil) (throw 'exit t))) ;;; vm-mouse.el ends here vm-8.2.0b/lisp/vm-menu.el0000755000175000017500000017000011676442160015444 0ustar srivastasrivasta;;; vm-menu.el --- Menu related functions and commands ;; ;; This file is part of VM ;; ;; Copyright (C) 1994 Heiko Muenkel ;; Copyright (C) 1995, 1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;; ;;; History: ;; ;; Folders menu derived from ;; vm-folder-menu.el ;; v1.10; 03-May-1994 ;; Copyright (C) 1994 Heiko Muenkel ;; email: muenkel@tnt.uni-hannover.de ;; Used with permission and my thanks. ;; Changed 18-May-1995, Kyle Jones ;; Cosmetic string changes, changed some variable names ;; and interfaced it with FSF Emacs via easymenu.el. ;; ;; Tree menu code is essentially tree-menu.el with renamed functions ;; tree-menu.el ;; v1.20; 10-May-1994 ;; Copyright (C) 1994 Heiko Muenkel ;; email: muenkel@tnt.uni-hannover.de ;; ;; Changed 18-May-1995, Kyle Jones ;; Removed the need for the utils.el package and references thereto. ;; Changed file-truename calls to tree-menu-file-truename so ;; the calls could be made compatible with FSF Emacs 19's ;; file-truename function. ;; Changed 30-May-1995, Kyle Jones ;; Renamed functions: tree- -> vm-menu-hm-tree. ;; Changed 5-July-1995, Kyle Jones ;; Removed the need for -A in ls flags. ;; Some systems' ls don't support -A. ;;; Code: (provide 'vm-menu) (eval-when-compile (require 'vm-misc) (require 'vm-mime) (defvar current-menubar nil)) (declare-function event-window "vm-xemacs" (event)) (declare-function event-point "vm-xemacs" (event)) (declare-function popup-mode-menu "vm-xemacs" (&optional event)) (declare-function event-closest-point "vm-xemacs" (event)) (declare-function find-menu-item "vm-xemacs" (menubar item-path-list &optional parent)) (declare-function add-menu-button "vm-xemacs" (menu-path menu-leaf &optional before in-menu)) (declare-function add-menu-item "vm-xemacs" (menu-path item-name function enabled-p &optional before)) (declare-function add-menu "vm-xemacs" (menu-path menu-name menu-items &optional before)) (declare-function set-menubar-dirty-flag "vm-xemacs" ()) (declare-function set-buffer-menubar "vm-xemacs" (menubar)) (declare-function vm-pop-find-name-for-spec "vm-pop" (spec)) (declare-function vm-imap-folder-for-spec "vm-imap" (spec)) (declare-function vm-mime-plain-message-p "vm-mime" (message)) (declare-function vm-yank-message "vm-reply" (message)) (declare-function vm-mail "vm" (&optional to subject)) (declare-function vm-get-header-contents "vm-summary" (message header-name-regexp &optional clump-sep)) (declare-function vm-mail-mode-get-header-contents "vm-reply" (header-name-regexp)) (declare-function vm-create-virtual-folder "vm-virtual" (selector &optional arg read-only name bookmark)) (declare-function vm-create-virtual-folder-of-threads "vm-virtual" (selector &optional arg read-only name bookmark)) (declare-function vm-so-sortable-subject "vm-sort" (message)) (declare-function vm-su-from "vm-summary" (message)) ;; This will be extended in code (defvar vm-menu-folders-menu '("Manipulate Folders" ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]) "VM folder menu list.") (defconst vm-menu-folder-menu `("Folder" ,(if vm-fsfemacs-p ["Manipulate Folders" ignore (ignore)] vm-menu-folders-menu) "---" ["Display Summary" vm-summarize t] ["Toggle Threading" vm-toggle-threads-display t] "---" ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)] "---" ["Search" vm-isearch-forward vm-message-list] "---" ["Auto-Archive" vm-auto-archive-messages vm-message-list] ["Expunge" vm-expunge-folder vm-message-list] ["Expunge POP Messages" vm-expunge-pop-messages (vm-menu-can-expunge-pop-messages-p)] ["Expunge IMAP Messages" vm-expunge-imap-messages (vm-menu-can-expunge-imap-messages-p)] "---" ["Visit Local Folder" vm-visit-folder t] ["Visit POP Folder" vm-visit-pop-folder vm-pop-folder-alist] ["Visit IMAP Folder" vm-visit-imap-folder vm-imap-account-alist] ["Revert Folder (back to disk version)" vm-revert-buffer (vm-menu-can-revert-p)] ["Recover Folder (from auto-save file)" vm-recover-file (vm-menu-can-recover-p)] ["Save" vm-save-folder (vm-menu-can-save-p)] ["Save As..." vm-write-file t] ["Quit" vm-quit-no-change t] ["Save & Quit" vm-quit t] "---" ;; "---" ;; special string that marks the tail of this menu for ;; vm-menu-install-visited-folders-menu. "-------" )) (defconst vm-menu-dispose-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Dispose" "Dispose" "---" "---") (list "Dispose")))) `(,@title ["Reply to Author" vm-reply vm-message-list] ["Reply to All" vm-followup vm-message-list] ["Reply to Author (citing original)" vm-reply-include-text vm-message-list] ["Reply to All (citing original)" vm-followup-include-text vm-message-list] ["Forward" vm-forward-message vm-message-list] ["Forward in Plain Text" vm-forward-message-plain vm-message-list] ["Resend" vm-resend-message vm-message-list] ["Retry Bounce" vm-resend-bounced-message vm-message-list] "---" ["File" vm-save-message vm-message-list] ["Delete" vm-delete-message vm-message-list] ["Undelete" vm-undelete-message vm-message-list] ["Kill Current Subject" vm-kill-subject vm-message-list] ["Mark Unread" vm-mark-message-unread vm-message-list] ["Edit" vm-edit-message vm-message-list] ["Print" vm-print-message vm-message-list] ["Pipe to Command" vm-pipe-message-to-command vm-message-list] ["Attach to Message Composition" vm-attach-message-to-composition vm-message-list] "---" ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list] ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)] ))) (defconst vm-menu-motion-menu '("Motion" ["Page Up" vm-scroll-backward vm-message-list] ["Page Down" vm-scroll-forward vm-message-list] "----" ["Beginning" vm-beginning-of-message vm-message-list] ["End" vm-end-of-message vm-message-list] "----" ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list] "----" ["Next Message" vm-next-message t] ["Previous Message" vm-previous-message t] "---" ["Next, Same Subject" vm-next-message-same-subject t] ["Previous, Same Subject" vm-previous-message-same-subject t] "---" ["Next Unread" vm-next-unread-message t] ["Previous Unread" vm-previous-unread-message t] "---" ["Next Message (no skip)" vm-next-message-no-skip t] ["Previous Message (no skip)" vm-previous-message-no-skip t] "---" ["Go to Last Seen Message" vm-goto-message-last-seen t] ["Go to Message" vm-goto-message t] ["Go to Parent Message" vm-goto-parent-message t] )) (defconst vm-menu-virtual-menu '("Virtual" ["Visit Virtual Folder" vm-visit-virtual-folder t] ["Apply Virtual Folder Selectors" vm-apply-virtual-folder t] ["Omit Message" vm-virtual-omit-message t] ["Update all" vm-virtual-update-folders] "---" "Search Folders" ["Author" vm-create-author-virtual-folder t] ["Recipients" vm-create-author-or-recipient-virtual-folder t] ["Subject" vm-create-subject-virtual-folder t] ["Text (Body)" vm-create-text-virtual-folder t] ["Days" vm-create-date-virtual-folder t] ["Label" vm-create-label-virtual-folder t] ["Flagged" vm-create-flagged-virtual-folder t] ["Unseen" vm-create-unseen-virtual-folder t] ["Same Author as current" vm-create-virtual-folder-same-author t] ["Same Subject as current" vm-create-virtual-folder-same-subject t] ["Create General" vm-create-virtual-folder t] ["Create General (Threads)" vm-create-virtual-folder-of-threads t] "---" "Auto operations" ["Delete Message(s)" vm-virtual-auto-delete-message t] ["Save Message(s)" vm-virtual-save-message t] ["Archive Messages" vm-virtual-auto-archive-messages t] ;; special string that marks the tail of this menu for ;; vm-menu-install-known-virtual-folders-menu. "-------" )) (defconst vm-menu-send-menu '("Send" ["Compose" vm-mail t] ["Continue Composing" vm-continue-composing-message vm-message-list] ["Reply to Author" vm-reply vm-message-list] ["Reply to All" vm-followup vm-message-list] ["Reply to Author (citing original)" vm-reply-include-text vm-message-list] ["Reply to All (citing original)" vm-followup-include-text vm-message-list] ["Forward Message" vm-forward-message vm-message-list] ["Forward Message in Plain Text" vm-forward-message-plain vm-message-list] ["Resend Message" vm-resend-message vm-message-list] ["Retry Bounced Message" vm-resend-bounced-message vm-message-list] ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list] ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list] ["Send MIME Digest" vm-send-mime-digest vm-message-list] )) (defconst vm-menu-mark-menu '("Mark" ["Next Command Uses Marks..." vm-next-command-uses-marks :active vm-message-list :style radio :selected (eq last-command 'vm-next-command-uses-marks)] "----" ["Mark" vm-mark-message vm-message-list] ["Unmark" vm-unmark-message vm-message-list] ["Mark All" vm-mark-all-messages vm-message-list] ["Clear All Marks" vm-clear-all-marks vm-message-list] ["Mark Region in Summary" vm-mark-summary-region vm-message-list] ["Unmark Region in Summary" vm-unmark-summary-region vm-message-list] "----" ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list] ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list] ["Mark Same Author" vm-mark-messages-same-author vm-message-list] ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list] ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list] ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list] ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list] ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list] )) (defconst vm-menu-label-menu '("Label" ["Add Label" vm-add-message-labels vm-message-list] ["Add Existing Label" vm-add-existing-message-labels vm-message-list] ["Remove Label" vm-delete-message-labels vm-message-list] )) (defconst vm-menu-sort-menu '("Sort" "By ascending" "---" ["Date" (vm-sort-messages "date") vm-message-list] ["Activity" (vm-sort-messages "activity") vm-message-list] ["Subject" (vm-sort-messages "subject") vm-message-list] ["Author" (vm-sort-messages "author") vm-message-list] ["Recipients" (vm-sort-messages "recipients") vm-message-list] ["Lines" (vm-sort-messages "line-count") vm-message-list] ["Bytes" (vm-sort-messages "byte-count") vm-message-list] "---" "By descending" "---" ["Date" (vm-sort-messages "reversed-date") vm-message-list] ["Activity" (vm-sort-messages "reversed-activity") vm-message-list] ["Subject" (vm-sort-messages "reversed-subject") vm-message-list] ["Author" (vm-sort-messages "reversed-author") vm-message-list] ["Recipients" (vm-sort-messages "reversed-recipients") vm-message-list] ["Lines" (vm-sort-messages "reversed-line-count") vm-message-list] ["Bytes" (vm-sort-messages "reversed-byte-count") vm-message-list] "---" ["By Multiple Fields..." vm-sort-messages vm-message-list] ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list] "---" ["Toggle Threading" vm-toggle-threads-display t] ["Expand/Collapse Thread" vm-toggle-thread t] ["Expand All Threads" vm-expand-all-threads t] ["Collapse All Threads" vm-collapse-all-threads t] )) (defconst vm-menu-help-menu '("Help" ["Switch to Emacs Menubar" vm-menu-toggle-menubar t] "---" ["Customize VM" vm-customize t] ["Describe VM Mode" describe-mode t] ["VM News" vm-view-news t] ["VM Manual" vm-menu-view-manual t] ["Submit Bug Report" vm-submit-bug-report t] "---" ["What Now?" vm-help t] ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)] ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)] "---" ["Save Folder & Quit" vm-quit t] ["Quit Without Saving" vm-quit-no-change t] )) (defconst vm-menu-xemacs-undo-button ["[Undo]" vm-undo (vm-menu-can-undo-p)] ) (defconst vm-menu-undo-menu '("Undo" ["Undo" vm-undo (vm-menu-can-undo-p)] ) "Undo menu for FSF Emacs builds that do not allow menubar buttons.") (defconst vm-menu-emacs-button ["[Emacs Menubar]" vm-menu-toggle-menubar t] ) (defconst vm-menu-emacs-menu '("Menubar" ["Switch to Emacs Menubar" vm-menu-toggle-menubar t] ) "Menu with a \"Swich to Emacs\" action meant for FSF Emacs builds that do not allow menubar buttons.") (defconst vm-menu-vm-button ["[VM Menubar]" vm-menu-toggle-menubar t] ) (defconst vm-menu-mail-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Mail Commands" "Mail Commands" "---" "---") (list "Mail Commands")))) `(,@title ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)] ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)] ["Cancel" kill-buffer t] "----" ["Yank Original" vm-menu-yank-original vm-reply-list] "----" ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Send Using MIME..." "Send Using MIME..." "---" "---") (list "Send Using MIME...")) ["Use MIME" (progn (set (make-local-variable 'vm-send-using-mime) t) (vm-mail-mode-remove-tm-hooks)) :active t :style radio :selected vm-send-using-mime] ["Don't use MIME" (set (make-local-variable 'vm-send-using-mime) nil) :active t :style radio :selected (not vm-send-using-mime)]) ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Fragment Messages Larger Than ..." "Fragment Messages Larger Than ..." "---" "---") (list "Fragment Messages Larger Than ...")) ["Infinity, i.e., don't fragment" (set (make-local-variable 'vm-mime-max-message-size) nil) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size nil)] ["50000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 50000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 50000)] ["100000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 100000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 100000)] ["200000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 200000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 200000)] ["500000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 500000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 500000)] ["1000000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 1000000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 1000000)] ["2000000 bytes" (set (make-local-variable 'vm-mime-max-message-size) 2000000) :active vm-send-using-mime :style radio :selected (eq vm-mime-max-message-size 2000000)]) ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Encode 8-bit Characters Using ..." "Encode 8-bit Characters Using ..." "---" "---") (list "Encode 8-bit Characters Using ...")) ["Nothing, i.e., send unencoded" (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) '8bit) :active vm-send-using-mime :style radio :selected (eq vm-mime-8bit-text-transfer-encoding '8bit)] ["Quoted-Printable" (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) 'quoted-printable) :active vm-send-using-mime :style radio :selected (eq vm-mime-8bit-text-transfer-encoding 'quoted-printable)] ["BASE64" (set (make-local-variable 'vm-mime-8bit-text-transfer-encoding) 'base64) :active vm-send-using-mime :style radio :selected (eq vm-mime-8bit-text-transfer-encoding 'base64)]) "----" ["Attach File..." vm-attach-file vm-send-using-mime] ["Attach MIME Message..." vm-attach-mime-file vm-send-using-mime] ["Encode MIME, But Don't Send" vm-mime-encode-composition (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:")))] ["Preview MIME Before Sending" vm-preview-composition vm-send-using-mime] ))) (defconst vm-menu-mime-dispose-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Take Action on MIME body ..." "Take Action on MIME body ..." "---" "---") (list "Take Action on MIME body ...")))) `(,@title ["Display as Text (in default face)" vm-mime-reader-map-display-using-default t] ["Display using External Viewer" vm-mime-reader-map-display-using-external-viewer t] ["Convert to Text and Display" vm-mime-reader-map-convert-then-display (vm-menu-can-convert-to-text/plain (vm-mime-get-button-layout))] ;; FSF Emacs does not allow a non-string menu element name. ;; This is not working on XEmacs either. USR, 2011-03-05 ;; ,@(if (vm-menu-can-eval-item-name) ;; (list [(format "Convert to %s and Display" ;; (or (nth 1 (vm-mime-can-convert ;; (car ;; (vm-mm-layout-type ;; (vm-mime-get-button-layout))))) ;; "different type")) ;; (vm-mime-run-display-function-at-point ;; 'vm-mime-convert-body-then-display) ;; (vm-mime-can-convert ;; (car (vm-mm-layout-type ;; (vm-mime-get-button-layout))))])) "---" ["Undo" vm-undo] "---" ["Save to File" vm-mime-reader-map-save-file t] ["Save to Folder" vm-mime-reader-map-save-message (let ((layout (vm-mime-get-button-layout))) (if (null layout) nil (or (vm-mime-types-match "message/rfc822" (car (vm-mm-layout-type layout))) (vm-mime-types-match "message/news" (car (vm-mm-layout-type layout))))))] ["Send to Printer" vm-mime-reader-map-pipe-to-printer t] ["Pipe to Shell Command (display output)" vm-mime-reader-map-pipe-to-command t] ["Pipe to Shell Command (discard output)" vm-mime-reader-map-pipe-to-command-discard-output t] ["Attach to Message Composition Buffer" vm-mime-reader-map-attach-to-composition t] ["Delete" vm-delete-mime-object t]))) (defconst vm-menu-url-browser-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Send URL to ..." "Send URL to ..." "---" "---") (list "Send URL to ..."))) (w3 (cond ((fboundp 'w3-fetch-other-frame) 'w3-fetch-other-frame) ((fboundp 'w3-fetch) 'w3-fetch) (t 'w3-fetch-other-frame)))) `(,@title ["Window system (Copy)" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-window-system) t] ["X Clipboard" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-clipboard) t] ["browse-url" (vm-mouse-send-url-at-position (point) 'browse-url) browse-url-browser-function] ["Emacs W3" (vm-mouse-send-url-at-position (point) (quote ,w3)) (fboundp (quote ,w3))] ["Emacs W3M" (vm-mouse-send-url-at-position (point) 'w3m-browse-url) (fboundp 'w3m-browse-url)] "---" ["Firefox" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-firefox) vm-firefox-client-program] ["Konqueror" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-konqueror) vm-konqueror-client-program] ;; ["Mosaic" ;; (vm-mouse-send-url-at-position ;; (point) 'vm-mouse-send-url-to-mosaic) ;; vm-mosaic-program] ;; ["mMosaic" ;; (vm-mouse-send-url-at-position ;; (point) 'vm-mouse-send-url-to-mmosaic) ;; vm-mmosaic-program] ["Mozilla" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-mozilla) vm-mozilla-program] ;; ["Netscape" ;; (vm-mouse-send-url-at-position ;; (point) 'vm-mouse-send-url-to-netscape) ;; vm-netscape-program] ["Opera" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-opera) vm-opera-program]))) (defconst vm-menu-mailto-url-browser-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Send Mail using ..." "Send Mail using ..." "---" "---") (list "Send Mail using ...")))) `(,@title ["VM" (vm-mouse-send-url-at-position (point) 'ignore) t]))) (defconst vm-menu-subject-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Take Action on Subject..." "Take Action on Subject..." "---" "---") (list "Take Action on Subject...")))) `(,@title ["Kill Subject" vm-kill-subject vm-message-list] ["Next Message, Same Subject" vm-next-message-same-subject vm-message-list] ["Previous Message, Same Subject" vm-previous-message-same-subject vm-message-list] ["Mark Messages, Same Subject" vm-mark-messages-same-subject vm-message-list] ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject vm-message-list] ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder vm-message-list] ))) (defconst vm-menu-author-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Take Action on Author..." "Take Action on Author..." "---" "---") (list "Take Action on Author...")))) `(,@title ["Mark Messages, Same Author" vm-mark-messages-same-author vm-message-list] ["Unmark Messages, Same Author" vm-unmark-messages-same-author vm-message-list] ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder vm-message-list] ["Send a message" vm-menu-mail-to vm-message-list] ))) (defconst vm-menu-attachment-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Fiddle With Attachment" "Fiddle With Attachment" "---" "---") (list "Fiddle With Attachment")))) `(,@title ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Set Content Disposition..." "Set Content Disposition..." "---" "---") (list "Set Content Disposition...")) ["Unspecified" (vm-mime-set-attachment-disposition-at-point 'unspecified) :active vm-send-using-mime :style radio :selected (eq (vm-mime-attachment-disposition-at-point) 'unspecified)] ["Inline" (vm-mime-set-attachment-disposition-at-point 'inline) :active vm-send-using-mime :style radio :selected (eq (vm-mime-attachment-disposition-at-point) 'inline)] ["Attachment" (vm-mime-set-attachment-disposition-at-point 'attachment) :active vm-send-using-mime :style radio :selected (eq (vm-mime-attachment-disposition-at-point) 'attachment)]) ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Set Content Encoding..." "Set Content Encoding..." "---" "---") (list "Set Content Encoding...")) ["Guess" (vm-mime-set-attachment-encoding-at-point "guess") :active vm-send-using-mime :style radio :selected (eq (vm-mime-attachment-encoding-at-point) nil)] ["Binary" (vm-mime-set-attachment-encoding-at-point "binary") :active vm-send-using-mime :style radio :selected (string= (vm-mime-attachment-encoding-at-point) "binary")] ["7bit" (vm-mime-set-attachment-encoding-at-point "7bit") :active vm-send-using-mime :style radio :selected (string= (vm-mime-attachment-encoding-at-point) "7bit")] ["8bit" (vm-mime-set-attachment-encoding-at-point "8bit") :active vm-send-using-mime :style radio :selected (string= (vm-mime-attachment-encoding-at-point) "8bit")] ["quoted-printable" (vm-mime-set-attachment-encoding-at-point "quoted-printable") :active vm-send-using-mime :style radio :selected (string= (vm-mime-attachment-encoding-at-point) "quoted-printable")] ) ( ,@(if (vm-menu-fsfemacs19-menus-p) (list "Forward Local External Bodies" "Forward Local External Bodies" "---" "---") (list "Forward Local External Bodies")) ["Forward Unchanged" (vm-mime-set-attachment-forward-local-refs-at-point t) :active vm-send-using-mime :style radio :selected (vm-mime-attachment-forward-local-refs-at-point)] ["Convert to Internal Object" (vm-mime-set-attachment-forward-local-refs-at-point nil) :active vm-send-using-mime :style radio :selected (not (vm-mime-attachment-forward-local-refs-at-point))]) ["Delete" (vm-mime-delete-attachment-button) :style button] ["Delete, but keep infos" (vm-mime-delete-attachment-button-keep-infos) :style button] ))) (defconst vm-menu-image-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "Redisplay Image" "Redisplay Image" "---" "---") (list "Redisplay Image")))) `(,@title ["4x Larger" (vm-mime-run-display-function-at-point 'vm-mime-larger-image) (stringp vm-imagemagick-convert-program)] ["4x Smaller" (vm-mime-run-display-function-at-point 'vm-mime-smaller-image) (stringp vm-imagemagick-convert-program)] ["Rotate Left" (vm-mime-run-display-function-at-point 'vm-mime-rotate-image-left) (stringp vm-imagemagick-convert-program)] ["Rotate Right" (vm-mime-run-display-function-at-point 'vm-mime-rotate-image-right) (stringp vm-imagemagick-convert-program)] ["Mirror" (vm-mime-run-display-function-at-point 'vm-mime-mirror-image) (stringp vm-imagemagick-convert-program)] ["Brighter" (vm-mime-run-display-function-at-point 'vm-mime-brighten-image) (stringp vm-imagemagick-convert-program)] ["Dimmer" (vm-mime-run-display-function-at-point 'vm-mime-dim-image) (stringp vm-imagemagick-convert-program)] ["Monochrome" (vm-mime-run-display-function-at-point 'vm-mime-monochrome-image) (stringp vm-imagemagick-convert-program)] ["Revert to Original" (vm-mime-run-display-function-at-point 'vm-mime-revert-image) (get (vm-mm-layout-cache (vm-extent-property (vm-find-layout-extent-at-point) 'vm-mime-layout)) 'vm-image-modified)] ))) (defvar vm-menu-vm-menubar nil) (defconst vm-menu-vm-menu (let ((title (if (vm-menu-fsfemacs19-menus-p) (list "VM" "VM" "---" "---") (list "VM")))) `(,@title ,vm-menu-folder-menu ,vm-menu-motion-menu ,vm-menu-send-menu ,vm-menu-mark-menu ,vm-menu-label-menu ,vm-menu-sort-menu ,vm-menu-virtual-menu ;; ,vm-menu-undo-menu ,vm-menu-dispose-menu "---" "---" ,vm-menu-help-menu))) (defvar vm-mode-menu-map nil "If running in FSF Emacs, this variable stores the standard menu bar of VM internally. USR, 2011-02-27") (defun vm-menu-run-command (command &rest args) "Run COMMAND almost interactively, with ARGS. call-interactive can't be used unfortunately, but this-command is set to the command name so that window configuration will be done." (setq this-command command) (apply command args)) (defun vm-menu-can-revert-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (and (buffer-modified-p) buffer-file-name)) (error nil))) (defun vm-menu-can-recover-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (and buffer-file-name buffer-auto-save-file-name (file-newer-than-file-p buffer-auto-save-file-name buffer-file-name))) (error nil))) (defun vm-menu-can-save-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (or (eq major-mode 'vm-virtual-mode) (buffer-modified-p))) (error nil))) (defun vm-menu-can-get-new-mail-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (or (eq major-mode 'vm-virtual-mode) (and (not vm-block-new-mail) (not vm-folder-read-only)))) (error nil))) (defun vm-menu-can-undo-p () (condition-case nil (save-excursion (vm-select-folder-buffer) vm-undo-record-list) (error nil))) (defun vm-menu-can-decode-mime-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (and vm-display-using-mime vm-message-pointer vm-presentation-buffer ;; (not vm-mime-decoded) (not (vm-mime-plain-message-p (car vm-message-pointer))))) (error nil))) (defun vm-menu-can-convert-to-text/plain (layout) (let ((type (car (vm-mm-layout-type layout)))) (or (equal (nth 1 (vm-mime-can-convert type)) "text/plain") (and (equal type "message/external-body") (vm-menu-can-convert-to-text/plain (car (vm-mm-layout-parts layout))))))) (defun vm-menu-can-expunge-pop-messages-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (not (eq vm-folder-access-method 'pop))) (error nil))) (defun vm-menu-can-expunge-imap-messages-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (not (eq vm-folder-access-method 'imap))) (error nil))) (defun vm-menu-yank-original () (interactive) (save-excursion (let ((mlist vm-reply-list)) (while mlist (vm-yank-message (car mlist)) (goto-char (point-max)) (setq mlist (cdr mlist)))))) (defun vm-menu-can-send-mail-p () (save-match-data (catch 'done (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc")) h) (while headers (setq h (vm-mail-mode-get-header-contents (car headers))) (and (stringp h) (string-match "[^ \t\n,]" h) (throw 'done t)) (setq headers (cdr headers))) nil )))) (defun vm-menu-create-subject-virtual-folder () (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq this-command 'vm-create-virtual-folder) (vm-create-virtual-folder 'sortable-subject (regexp-quote (vm-so-sortable-subject (car vm-message-pointer))))) (defun vm-menu-create-author-virtual-folder () (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq this-command 'vm-create-virtual-folder) (vm-create-virtual-folder 'author (regexp-quote (vm-su-from (car vm-message-pointer))))) (defun vm-menu-mail-to () (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq this-command 'vm-mail) (vm-mail (vm-get-header-contents (car vm-message-pointer) "From:"))) (defun vm-menu-xemacs-global-menubar () (save-excursion (set-buffer (get-buffer-create "*scratch*")) current-menubar)) (defun vm-menu-fsfemacs-global-menubar () (lookup-key (current-global-map) [menu-bar])) (defun vm-menu-initialize-vm-mode-menu-map () (if (null vm-mode-menu-map) (let ((map (make-sparse-keymap)) (dummy (make-sparse-keymap))) ;; initialize all the vm-menu-fsfemacs-*-menu variables ;; with the menus. (easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil vm-menu-help-menu) (easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu))) (easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil vm-menu-dispose-menu) (easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil vm-menu-undo-menu) (easy-menu-define vm-menu-fsfemacs-emacs-menu (list dummy) nil vm-menu-emacs-menu) (easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil vm-menu-virtual-menu) (easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil vm-menu-sort-menu) (easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil vm-menu-label-menu) (easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil vm-menu-mark-menu) (easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil vm-menu-send-menu) (easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil vm-menu-motion-menu) ;; (easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil ;; vm-menu-folders-menu) (easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil vm-menu-folder-menu) (easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil vm-menu-vm-menu) ;; for mail mode (easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil vm-menu-mail-menu) ;; subject menu (easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil vm-menu-subject-menu) ;; author menu (easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil vm-menu-author-menu) ;; url browser menu (easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil vm-menu-url-browser-menu) ;; mailto url browser menu (easy-menu-define vm-menu-fsfemacs-mailto-url-browser-menu (list dummy) nil vm-menu-url-browser-menu) ;; mime dispose menu (easy-menu-define vm-menu-fsfemacs-mime-dispose-menu (list dummy) nil vm-menu-mime-dispose-menu) ;; attachment menu (easy-menu-define vm-menu-fsfemacs-attachment-menu (list dummy) nil vm-menu-attachment-menu) ;; image menu (easy-menu-define vm-menu-fsfemacs-image-menu (list dummy) nil vm-menu-image-menu) ;; block the global menubar entries in the map so that VM ;; can take over the menubar if necessary. (define-key map [rootmenu] (make-sparse-keymap)) (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM"))) (define-key map [rootmenu vm file] 'undefined) (define-key map [rootmenu vm files] 'undefined) (define-key map [rootmenu vm search] 'undefined) (define-key map [rootmenu vm edit] 'undefined) (define-key map [rootmenu vm options] 'undefined) (define-key map [rootmenu vm buffer] 'undefined) (define-key map [rootmenu vm tools] 'undefined) (define-key map [rootmenu vm help] 'undefined) (define-key map [rootmenu vm mule] 'undefined) ;; 19.29 changed the tag for the Help menu. (define-key map [rootmenu vm help-menu] 'undefined) ;; now build VM's menu tree. (let ((menu-alist '((dispose (cons "Dispose" vm-menu-fsfemacs-dispose-menu)) (folder (cons "Folder" vm-menu-fsfemacs-folder-menu)) (help (cons "Help" vm-menu-fsfemacs-help-menu)) (label (cons "Label" vm-menu-fsfemacs-label-menu)) (mark (cons "Mark" vm-menu-fsfemacs-mark-menu)) (motion (cons "Motion" vm-menu-fsfemacs-motion-menu)) (send (cons "Send" vm-menu-fsfemacs-send-menu)) (sort (cons "Sort" vm-menu-fsfemacs-sort-menu)) (virtual (cons "Virtual" vm-menu-fsfemacs-virtual-menu)) (emacs (if (and (vm-menubar-buttons-possible-p) vm-use-menubar-buttons) (cons "[Emacs Menubar]" 'vm-menu-toggle-menubar) (cons "Menubar" vm-menu-fsfemacs-emacs-menu))) (undo (if (and (vm-menubar-buttons-possible-p) vm-use-menubar-buttons) (cons "[Undo]" 'vm-undo) (cons "Undo" vm-menu-fsfemacs-undo-menu))))) (cons nil) (vec (vector 'rootmenu 'vm nil)) ;; menus appear in the opposite order that we ;; define-key them. (menu-list (if (consp vm-use-menus) (reverse vm-use-menus) (list 'help nil 'dispose 'undo 'virtual 'sort 'label 'mark 'send 'motion 'folder))) (menu nil)) (while menu-list (setq menu (car menu-list)) (if (null menu) nil;; no flushright support in FSF Emacs (aset vec 2 (intern (concat "vm-menubar-" (symbol-name menu)))) (setq cons (assq menu menu-alist)) (if cons (define-key map vec (eval (cadr cons))))) (setq menu-list (cdr menu-list)))) (setq vm-mode-menu-map map) (run-hooks 'vm-menu-setup-hook)))) (defun vm-menu-make-xemacs-menubar () (let ((menu-alist '((dispose . vm-menu-dispose-menu) (folder . vm-menu-folder-menu) (help . vm-menu-help-menu) (label . vm-menu-label-menu) (mark . vm-menu-mark-menu) (motion . vm-menu-motion-menu) (send . vm-menu-send-menu) (sort . vm-menu-sort-menu) (virtual . vm-menu-virtual-menu) (emacs . vm-menu-emacs-button) (undo . vm-menu-xemacs-undo-button))) cons (menubar nil) (menu-list vm-use-menus)) (while menu-list (if (null (car menu-list)) (setq menubar (cons nil menubar)) (setq cons (assq (car menu-list) menu-alist)) (if cons (setq menubar (cons (symbol-value (cdr cons)) menubar)))) (setq menu-list (cdr menu-list))) (nreverse menubar) )) (defun vm-menu-popup-mode-menu (event) (interactive "e") (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (set-buffer (window-buffer (event-window event))) (and (event-point event) (goto-char (event-point event))) (popup-mode-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) (vm-menu-popup-fsfemacs-menu event)))) (defvar vm-menu-fsfemacs-attachment-menu) (defun vm-menu-popup-context-menu (event) (interactive "e") ;; We should not need to do anything here for XEmacs. The ;; default binding of mouse-3 is popup-mode-menu which does ;; what we want for the normal case. For special context,s ;; like when the mouse is over an URL, XEmacs has local keymap ;; support for extents. Any context sensitive area should be ;; contained in an extent with a keymap that has mouse-3 bound ;; to a function that will pop up a context sensitive menu. (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) (if (get-text-property (point) 'vm-mime-object) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-attachment-menu) (let (o-list o menu (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (cond ((overlay-get (car o-list) 'vm-url) (setq found t) (vm-menu-popup-url-browser-menu event)) ((setq menu (overlay-get (car o-list) 'vm-header)) (setq found t) (vm-menu-popup-fsfemacs-menu event menu)) ((setq menu (overlay-get (car o-list) 'vm-image)) (setq found t) (vm-menu-popup-fsfemacs-menu event menu)) ((overlay-get (car o-list) 'vm-mime-layout) (setq found t) (vm-menu-popup-mime-dispose-menu event))) (setq o-list (cdr o-list))) (and (not found) (vm-menu-popup-fsfemacs-menu event))))))) ;; to quiet the byte-compiler (defvar vm-menu-fsfemacs-url-browser-menu) (defvar vm-menu-fsfemacs-mailto-url-browser-menu) (defvar vm-menu-fsfemacs-mime-dispose-menu) (defun vm-menu-goto-event (event) (cond ((vm-menu-xemacs-menus-p) ;; Must select window instead of just set-buffer because ;; popup-menu returns before the user has made a ;; selection. This will cause the command loop to ;; resume which might undo what set-buffer does. (select-window (event-window event)) (and (event-closest-point event) (goto-char (event-closest-point event)))) ((vm-menu-fsfemacs-menus-p) (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event)))))) (defun vm-menu-popup-url-browser-menu (event) (interactive "e") (vm-menu-goto-event event) (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (popup-menu vm-menu-url-browser-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-url-browser-menu)))) (defun vm-menu-popup-mailto-url-browser-menu (event) (interactive "e") (vm-menu-goto-event event) (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (popup-menu vm-menu-mailto-url-browser-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-mailto-url-browser-menu)))) (defun vm-menu-popup-mime-dispose-menu (event) (interactive "e") (vm-menu-goto-event event) (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (popup-menu vm-menu-mime-dispose-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-mime-dispose-menu)))) (defun vm-menu-popup-attachment-menu (event) (interactive "e") (vm-menu-goto-event event) (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (popup-menu vm-menu-attachment-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-attachment-menu)))) (defvar vm-menu-fsfemacs-image-menu) (defun vm-menu-popup-image-menu (event) (interactive "e") (vm-menu-goto-event event) (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus) (popup-menu vm-menu-image-menu)) ((and (vm-menu-fsfemacs-menus-p) vm-use-menus) (vm-menu-popup-fsfemacs-menu event vm-menu-fsfemacs-image-menu)))) ;; to quiet the byte-compiler (defvar vm-menu-fsfemacs-mail-menu) (defvar vm-menu-fsfemacs-dispose-popup-menu) (defvar vm-menu-fsfemacs-vm-menu) (defun vm-menu-popup-fsfemacs-menu (event &optional menu) (interactive "e") (set-buffer (window-buffer (posn-window (event-start event)))) (goto-char (posn-point (event-start event))) (let ((map (or menu mode-popup-menu)) key command func) (setq key (x-popup-menu event map) key (apply 'vector key) command (lookup-key map key) func (and (symbolp command) (symbol-function command))) (cond ((null func) (setq this-command last-command)) ((symbolp func) (setq this-command func) (call-interactively this-command)) (t (call-interactively command))))) (defun vm-menu-mode-menu () (if (vm-menu-xemacs-menus-p) (cond ((eq major-mode 'mail-mode) vm-menu-mail-menu) ((memq major-mode '(vm-mode vm-presentation-mode vm-summary-mode vm-virtual-mode)) vm-menu-dispose-menu) (t vm-menu-vm-menu)) (cond ((eq major-mode 'mail-mode) vm-menu-fsfemacs-mail-menu) ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode)) vm-menu-fsfemacs-dispose-popup-menu) (t vm-menu-fsfemacs-vm-menu)))) (defun vm-menu-set-menubar-dirty-flag () (cond ((vm-menu-xemacs-menus-p) (set-menubar-dirty-flag)) ((vm-menu-fsfemacs-menus-p) ;; force-mode-line-update seems to have been buggy in Emacs ;; 21, 22, and 23. So we do it ourselves. USR, 2011-02-26 ;; (force-mode-line-update t) (set-buffer-modified-p (buffer-modified-p)) (when (and vm-user-interaction-buffer (buffer-live-p vm-user-interaction-buffer)) (with-current-buffer vm-user-interaction-buffer (set-buffer-modified-p (buffer-modified-p))))))) (defun vm-menu-fsfemacs-add-vm-menu () "Add a menu or a menubar button to the Emacs menubar for switching to a VM menubar." (if (and (vm-menubar-buttons-possible-p) vm-use-menubar-buttons) (define-key vm-mode-map [menu-bar vm] '(menu-item "[VM Menubar]" vm-menu-toggle-menubar)) (define-key vm-mode-map [menu-bar vm] (cons "Menubar" (make-sparse-keymap "VM"))) (define-key vm-mode-map [menu-bar vm vm-toggle] '(menu-item "Switch to VM Menubar" vm-menu-toggle-menubar)))) (defun vm-menu-toggle-menubar (&optional buffer) "Toggle between the VM's dedicated menu bar and the standard Emacs menu bar. USR, 2011-02-27" (interactive) (if buffer (set-buffer buffer) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p))) (cond ((vm-menu-xemacs-menus-p) (if (null (car (find-menu-item current-menubar '("[Emacs Menubar]")))) (set-buffer-menubar vm-menu-vm-menubar) ;; copy the current menubar in case it has been changed. (make-local-variable 'vm-menu-vm-menubar) (setq vm-menu-vm-menubar (copy-sequence current-menubar)) (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) (condition-case nil (add-menu-button nil vm-menu-vm-button nil) (void-function (add-menu-item nil "Menubar" 'vm-menu-toggle-menubar t)))) (vm-menu-set-menubar-dirty-flag) (vm-check-for-killed-summary) (and vm-summary-buffer (save-excursion (vm-menu-toggle-menubar vm-summary-buffer))) (vm-check-for-killed-presentation) (and vm-presentation-buffer-handle (save-excursion (vm-menu-toggle-menubar vm-presentation-buffer-handle)))) ((vm-menu-fsfemacs-menus-p) (if (not (eq (lookup-key vm-mode-map [menu-bar]) (lookup-key vm-mode-menu-map [rootmenu vm]))) (define-key vm-mode-map [menu-bar] (lookup-key vm-mode-menu-map [rootmenu vm])) (define-key vm-mode-map [menu-bar] (make-sparse-keymap "Menu")) (vm-menu-fsfemacs-add-vm-menu)) (vm-menu-set-menubar-dirty-flag)))) (defun vm-menu-install-menubar () "Install the dedicated menu bar of VM. USR, 2011-02-27" (cond ((vm-menu-xemacs-menus-p) (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar)) (set-buffer-menubar vm-menu-vm-menubar) (run-hooks 'vm-menu-setup-hook) (setq vm-menu-vm-menubar current-menubar)) ((and (vm-menu-fsfemacs-menus-p) ;; menus only need to be installed once for FSF Emacs (not (fboundp 'vm-menu-undo-menu))) (vm-menu-initialize-vm-mode-menu-map) (define-key vm-mode-map [menu-bar] (lookup-key vm-mode-menu-map [rootmenu vm]))))) (defun vm-menu-install-menubar-item () "Install VM's menu on the current - presumably the standard - menu bar. USR, 2011-02-27" (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar)) (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) (add-menu nil "VM" (cdr vm-menu-vm-menu))) ((and (vm-menu-fsfemacs-menus-p) ;; menus only need to be installed once for FSF Emacs (not (fboundp 'vm-menu-undo-menu))) (vm-menu-initialize-vm-mode-menu-map) (define-key vm-mode-map [menu-bar] (lookup-key vm-mode-menu-map [rootmenu]))))) (defun vm-menu-install-vm-mode-menu () "This function strangely does nothing! USR, 2011-02-27." ;; nothing to do here. ;; handled in vm-mouse.el (cond ((vm-menu-xemacs-menus-p) t ) ((vm-menu-fsfemacs-menus-p) t ))) (defun vm-menu-install-mail-mode-menu () (cond ((vm-menu-xemacs-menus-p) ;; mail-mode doesn't have mode-popup-menu bound to ;; mouse-3 by default. fix that. (if vm-popup-menu-on-mouse-3 (define-key vm-mail-mode-map 'button3 'popup-mode-menu)) ;; put menu on menubar also. (if (vm-menu-xemacs-global-menubar) (progn (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar))) (add-menu nil "Mail" (cdr vm-menu-mail-menu)))) t ) ((vm-menu-fsfemacs-menus-p) ;; I'd like to do this, but the result is a combination ;; of the Emacs and VM Mail menus glued together. ;; Poorly. ;;(define-key vm-mail-mode-map [menu-bar mail] ;; (cons "Mail" vm-menu-fsfemacs-mail-menu)) (defvar mail-mode-map) (define-key mail-mode-map [menu-bar mail] (cons "Mail" vm-menu-fsfemacs-mail-menu)) (if vm-popup-menu-on-mouse-3 (define-key vm-mail-mode-map [down-mouse-3] 'vm-menu-popup-context-menu))))) (defun vm-menu-install-menus () "Install VM menus, either in the current menu bar or in a separate dedicated menu bar, depending on the value of `vm-use-menus'. USR, 2011-02-27" (cond ((consp vm-use-menus) (vm-menu-install-vm-mode-menu) (vm-menu-install-menubar) (vm-menu-install-known-virtual-folders-menu)) ((eq vm-use-menus 1) (vm-menu-install-vm-mode-menu) (vm-menu-install-menubar-item) (vm-menu-install-known-virtual-folders-menu)) (t nil))) (defun vm-menu-install-known-virtual-folders-menu () (let ((folders (sort (mapcar 'car vm-virtual-folder-alist) (function string-lessp))) (menu nil) tail ;; special string indicating tail of Virtual menu (special "-------")) (while folders (setq menu (cons (vector " " (list 'vm-menu-run-command ''vm-visit-virtual-folder (car folders)) :suffix (car folders)) menu) folders (cdr folders))) (and menu (setq menu (nreverse menu) menu (nconc (list "Visit:" "---") menu))) (setq tail (vm-member special vm-menu-virtual-menu)) (if (and menu tail) (progn (setcdr tail menu) (vm-menu-set-menubar-dirty-flag) (cond ((vm-menu-fsfemacs-menus-p) (makunbound 'vm-menu-fsfemacs-virtual-menu) (easy-menu-define vm-menu-fsfemacs-virtual-menu (list (make-sparse-keymap)) nil vm-menu-virtual-menu) (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual] (cons "Virtual" vm-menu-fsfemacs-virtual-menu)))))))) (defun vm-menu-install-visited-folders-menu () (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history))) (menu nil) tail foo spool-files (i 0) ;; special string indicating tail of Folder menu (special "-------")) (while (and folders (< i 10)) (setq menu (cons (vector " " (cond ((and (vm-pop-folder-spec-p (car folders)) (setq foo (vm-pop-find-name-for-spec (car folders)))) (list 'vm-menu-run-command ''vm-visit-pop-folder foo)) ((and (vm-imap-folder-spec-p (car folders)) (setq foo (vm-imap-folder-for-spec (car folders)))) (list 'vm-menu-run-command 'vm'visit-imap-folder foo)) (t (list 'vm-menu-run-command ''vm-visit-folder (car folders)))) :suffix (car folders)) menu) folders (cdr folders) i (1+ i))) (and menu (setq menu (nreverse menu) menu (nconc (list "Visit:" "---") menu))) (setq spool-files (vm-spool-files) folders (cond ((and (consp spool-files) (consp (car spool-files))) (mapcar (function car) spool-files)) ((and (consp spool-files) (stringp (car spool-files)) (stringp vm-primary-inbox)) (list vm-primary-inbox)) (t nil))) (if (and menu folders) (nconc menu (list "---" "---"))) (while folders (setq menu (nconc menu (list (vector " " (list 'vm-menu-run-command ''vm-visit-folder (car folders)) :suffix (car folders)))) folders (cdr folders))) (setq tail (vm-member special vm-menu-folder-menu)) (if (and menu tail) (progn (setcdr tail menu) (vm-menu-set-menubar-dirty-flag) (cond ((vm-menu-fsfemacs-menus-p) (makunbound 'vm-menu-fsfemacs-folder-menu) (easy-menu-define vm-menu-fsfemacs-folder-menu (list (make-sparse-keymap)) nil vm-menu-folder-menu) (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder] (cons "Folder" vm-menu-fsfemacs-folder-menu)))))))) (defun vm-customize () "Customize VM options." (interactive) (customize-group 'vm)) (defun vm-view-news () "View NEWS for the current VM version." (interactive) (let* ((vm-dir (file-name-directory (locate-library "vm"))) (doc-dirs (list (and vm-configure-docdir (expand-file-name vm-configure-docdir)) (and vm-configure-datadir (expand-file-name vm-configure-datadir)) (concat vm-dir "../"))) doc-dir) (while doc-dirs (setq doc-dir (car doc-dirs)) (if (and doc-dir (file-exists-p (expand-file-name "NEWS" doc-dir))) (setq doc-dirs nil) (setq doc-dirs (cdr doc-dirs)))) (view-file-other-frame (expand-file-name "NEWS" doc-dir)))) (defun vm-view-manual () "View the VM manual." (interactive) (info "VM")) ;;; Muenkel Folders menu code (defvar vm-menu-hm-no-hidden-dirs t "*Hidden directories are suppressed in the folder menus, if non nil.") (defconst vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~")) (defun vm-menu-hm-delete-folder (folder) "Query deletes a folder." (interactive "fDelete folder: ") (if (file-exists-p folder) (if (y-or-n-p (concat "Delete the folder " folder " ? ")) (progn (if (file-directory-p folder) (delete-directory folder) (delete-file folder)) (vm-inform 5 "Folder deleted.") (vm-menu-hm-make-folder-menu) (vm-menu-hm-install-menu) ) (vm-inform 0 "Aborted")) (error "Folder %s does not exist." folder) (vm-menu-hm-make-folder-menu) (vm-menu-hm-install-menu) )) (defun vm-menu-hm-rename-folder (folder) "Rename a folder." (interactive "fRename folder: ") (if (file-exists-p folder) (rename-file folder (read-file-name (concat "Rename " folder " to ") (directory-file-name folder) folder)) (error "Folder %s does not exist." folder)) (vm-menu-hm-make-folder-menu) (vm-menu-hm-install-menu) ) (defun vm-menu-hm-create-dir (parent-dir) "Create a subdir in PARENT-DIR." (interactive "DCreate new directory in: ") (setq parent-dir (or parent-dir vm-folder-directory)) (make-directory (expand-file-name (read-file-name (format "Create directory in %s called: " parent-dir) parent-dir) vm-folder-directory) t) (vm-menu-hm-make-folder-menu) (vm-menu-hm-install-menu) ) (defun vm-menu-hm-make-folder-menu () "Makes a menu with the mail folders of the directory `vm-folder-directory'." (interactive) (vm-inform 5 "Building folders menu...") (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory)) (inbox-list (if (listp (car vm-spool-files)) (mapcar 'car vm-spool-files) (list vm-primary-inbox)))) (setq vm-menu-folders-menu (cons "Manipulate Folders" (list (cons "Visit Inboxes " (vm-menu-hm-tree-make-menu inbox-list 'vm-visit-folder t)) (cons "Visit Folder " (vm-menu-hm-tree-make-menu folder-list 'vm-visit-folder t vm-menu-hm-no-hidden-dirs vm-menu-hm-hidden-file-list)) (cons "Save Message " (vm-menu-hm-tree-make-menu folder-list 'vm-save-message t vm-menu-hm-no-hidden-dirs vm-menu-hm-hidden-file-list)) "----" (cons "Delete Folder " (vm-menu-hm-tree-make-menu folder-list 'vm-menu-hm-delete-folder t nil nil t )) (cons "Rename Folder " (vm-menu-hm-tree-make-menu folder-list 'vm-menu-hm-rename-folder t nil nil t )) (cons "Make New Directory in..." (vm-menu-hm-tree-make-menu (cons (list vm-folder-directory) folder-list) 'vm-menu-hm-create-dir t nil '(".*") t )) "----" ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory] )))) (vm-inform 5 "Building folders menu... done") (vm-menu-hm-install-menu)) (defun vm-menu-hm-install-menu () (cond ((vm-menu-xemacs-menus-p) (cond ((car (find-menu-item current-menubar '("VM"))) (add-menu '("VM") "Folders" (cdr vm-menu-folders-menu) "Motion")) ((car (find-menu-item current-menubar '("Folder" "Manipulate Folders"))) (add-menu '("Folder") "Manipulate Folders" (cdr vm-menu-folders-menu) "Motion")))) ((vm-menu-fsfemacs-menus-p) (easy-menu-define vm-menu-fsfemacs-folders-menu (list (make-sparse-keymap)) nil vm-menu-folders-menu) (define-key vm-mode-menu-map [rootmenu vm folder folders] (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu))))) ;;; Muenkel tree-menu code (defconst vm-menu-hm-tree-ls-flags "-aFLR" "*A String with the flags used in the function vm-menu-hm-tree-ls-in-temp-buffer for the ls command. Be careful if you want to change this variable. The ls command must append a / on all files which are directories. The original flags are -aFLR.") (defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer) "List the directory DIR in the TEMP-BUFFER." (switch-to-buffer temp-buffer) (erase-buffer) (let ((process-connection-type nil)) (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir)) (goto-char (point-min)) (while (search-forward "//" nil t) (replace-match "/")) (goto-char (point-min)) (while (re-search-forward "\\.\\.?/\n" nil t) (replace-match "")) (goto-char (point-min))) (defconst vm-menu-hm-tree-temp-buffername "*tree*" "Name of the temp buffers in tree.") (defun vm-menu-hm-tree-make-file-list-1 (root list) (let ((filename (buffer-substring (point) (progn (end-of-line) (point))))) (while (not (string= filename "")) (setq list (append list (list (cond ((char-equal (char-after (- (point) 1)) ?/) ;; Directory (setq filename (substring filename 0 (1- (length filename)))) (save-excursion (search-forward (concat root filename ":")) (forward-line) (vm-menu-hm-tree-make-file-list-1 (concat root filename "/") (list (vm-menu-hm-tree-menu-file-truename filename root))))) ((char-equal (char-after (- (point) 1)) ?*) ;; Executable (setq filename (substring filename 0 (1- (length filename)))) (vm-menu-hm-tree-menu-file-truename filename root)) (t (vm-menu-hm-tree-menu-file-truename filename root)))))) (forward-line) (setq filename (buffer-substring (point) (progn (end-of-line) (point))))) list)) (defun vm-menu-hm-tree-menu-file-truename (file &optional root) (file-truename (expand-file-name file root))) (defun vm-menu-hm-tree-make-file-list (dir) "Makes a list with the files and subdirectories of DIR. The list looks like: ((dirname1 file1 file2) file3 (dirname2 (dirname3 file4 file5) file6))" (save-window-excursion (setq dir (expand-file-name dir)) (if (not (string= (substring dir -1) "/")) (setq dir (concat dir "/"))) ;; (while (string-match "/$" dir) ;; (setq dir (substring dir 0 -1))) (vm-menu-hm-tree-ls-in-temp-buffer dir (generate-new-buffer-name vm-menu-hm-tree-temp-buffername)) (let ((list nil)) (setq list (vm-menu-hm-tree-make-file-list-1 dir nil)) (kill-buffer (current-buffer)) list))) (defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list) "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME." (cond ((not re-hidden-file-list) nil) ((string-match (car re-hidden-file-list) (vm-menu-hm-tree-menu-file-truename filename))) (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list))))) (defun vm-menu-hm-tree-make-menu (dirlist function selectable &optional no-hidden-dirs re-hidden-file-list include-current-dir) "Returns a menu list. Each item of the menu list has the form [\"subdir\" (FUNCTION \"dir\") SELECTABLE]. Hidden directories (with a leading point) are suppressed, if NO-HIDDEN-DIRS are non nil. Also all files which are matching a regexp in RE-HIDDEN-FILE-LIST are suppressed. If INCLUDE-CURRENT-DIR non nil, then an additional command for the current directory (.) is inserted." (let ((subdir nil) (menulist nil)) (while (setq subdir (car dirlist)) (setq dirlist (cdr dirlist)) (cond ((and (stringp subdir) (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list))) (setq menulist (append menulist (list (vector (file-name-nondirectory subdir) (list function subdir) selectable))))) ((and (listp subdir) (or (not no-hidden-dirs) (not (char-equal ?. (string-to-char (file-name-nondirectory (car subdir)))))) (setq menulist (append menulist (list (cons (file-name-nondirectory (car subdir)) (if include-current-dir (cons (vector "." (list function (car subdir)) selectable) (vm-menu-hm-tree-make-menu (cdr subdir) function selectable no-hidden-dirs re-hidden-file-list include-current-dir )) (vm-menu-hm-tree-make-menu (cdr subdir) function selectable no-hidden-dirs re-hidden-file-list )))))))) (t nil)) ) menulist ) ) ;;; vm-menu.el ends here vm-8.2.0b/lisp/vm-summary.el0000755000175000017500000023423411676442160016207 0ustar srivastasrivasta;;; vm-summary.el --- Summary gathering and formatting routines for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1995, 2000 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; Copyright (C) 2009-2010 Uday S Reddy ;; Copyright (C) 2010 Arik Mitschang ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-summary) (eval-when-compile (require 'vm-misc) (require 'vm-crypto) (require 'vm-folder) (require 'vm-window) (require 'vm-menu) (require 'vm-toolbar) (require 'vm-mouse) (require 'vm-motion) (require 'vm-mime) (require 'vm-thread) (require 'vm-pop) (require 'vm-summary-faces) ) (declare-function set-specifier "vm-xemacs" (specifier value &optional locale tag-set how-to-add)) (declare-function rfc822-addresses "ext:rfc822" (header-text)) (declare-function vm-visit-folder "vm.el" (folder &optional read-only)) (declare-function vm-set-folded-flag "vm-undo.el" (m flag &optional norecord)) (defvar scrollbar-height) ; defined for XEmacs (defun vm-summary-trace-message () (interactive) (add-to-list 'vm-summary-traced-messages (vm-number-of (vm-current-message))) (message "%s" vm-summary-traced-messages)) (defsubst vm-summary-debug (m) (if (and vm-debug (member (vm-number-of m) vm-summary-traced-messages)) (debug 'vm-summary m))) (defsubst vm-summary-message-at-point () "Returns the message of the current summary line." (save-excursion (forward-line 0) ;; The point often ends up preceding the invisible stuff. Skip it. (while (get-text-property (point) 'invisible) (forward-char)) (get-text-property (+ (point) 3) 'vm-message))) (defsubst vm-summary-padded-thread-count (m) "Returns a formatted thread count of the message M, usable in summary display." (let ((count (vm-thread-count m))) (if (> count 1) (format "+%-2s" (1- (vm-thread-count m))) " "))) (defsubst vm-summary-message-number-thread-descendant (m) "Returns the message number of M, padded with spaces to display as an interior message of a thread." (concat " " (vm-padded-number-of m) " ")) (defsubst vm-expanded-root-p (m) "Returns t if M is the root of a thread that is currently shown expanded (using the folded attribute of the message)." (and (vm-thread-root-p m) (null (vm-folded-flag m)))) (defsubst vm-collapsed-root-p (m) "Returns t if M is the root fo a thread that is currently shown collapsed (usint the folded attribute of the message)." (and (vm-thread-root-p m) (vm-folded-flag m))) (defsubst vm-summary-mark-root-collapsed (m) "Mark a thread root message M as collapsed." (vm-set-folded-flag m t)) (defsubst vm-summary-mark-root-expanded (m) "Mark a thread root message M as expanded." (vm-set-folded-flag m nil)) (defsubst vm-visible-message (m) (apply 'vm-vs-or m vm-summary-visible)) ;; This variable is only in Emacs 24 (defvar bidi-paragraph-direction) (defun vm-summary-mode-internal () (setq mode-name "VM Summary" major-mode 'vm-summary-mode mode-line-format vm-mode-line-format ;; must come after the setting of major-mode mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t vm-summary-pointer nil vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "") vm-summary-no-=> (make-string (length vm-summary-=>) ? ) truncate-lines t ;; Needed for Emacs 24 bidi display bidi-paragraph-direction 'left-to-right) ;; horizontal scrollbar off by default ;; user can turn it on in summary hook if desired. (when (and vm-xemacs-p (featurep 'scrollbar)) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-summary-mode-map) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) ;; using the 'mouse-face property gives faster highlighting than this. ;; (and vm-mouse-track-summary ;; (vm-mouse-support-possible-p) ;; (vm-mouse-xemacs-mouse-p) ;; (add-hook 'mode-motion-hook 'mode-motion-highlight-line)) (when (and vm-mutable-frame-configuration (or vm-frame-per-folder vm-frame-per-summary)) (vm-set-hooks-for-frame-deletion)) (run-hooks 'vm-summary-mode-hook) ;; Lucid Emacs apparently used this name (run-hooks 'vm-summary-mode-hooks)) (fset 'vm-summary-mode 'vm-mode) (put 'vm-summary-mode 'mode-class 'special) ;;;###autoload (defun vm-summarize (&optional display raise) "Summarize the contents of the folder in a summary buffer. The format is as described by the variable `vm-summary-format'. Generally one line per message is most pleasing to the eye but this is not mandatory." (interactive "p\np") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (null vm-summary-buffer) (let ((b (current-buffer)) (read-only vm-folder-read-only) (summary-buffer-name (format "%s Summary" (buffer-name)))) (setq vm-summary-buffer (or (get-buffer summary-buffer-name) (vm-generate-new-multibyte-buffer summary-buffer-name))) (save-excursion (set-buffer vm-summary-buffer) (abbrev-mode 0) (auto-fill-mode 0) (vm-fsfemacs-nonmule-display-8bit-chars) (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (setq vm-mail-buffer b vm-folder-read-only read-only) (vm-summary-mode-internal)) (vm-set-summary-redo-start-point t))) (if display (save-excursion (vm-goto-new-summary-frame-maybe) (vm-display vm-summary-buffer t '(vm-summarize vm-summarize-other-frame) (list this-command) (not raise)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (set-buffer vm-summary-buffer) (vm-toolbar-install-or-uninstall-toolbar)) (vm-display nil nil '(vm-summarize vm-summarize-other-frame) (list this-command))) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-summarize-other-frame (&optional display) "Like vm-summarize, but run in a newly created frame." (interactive "p") (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'summary)) (vm-summarize display) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) (defun vm-do-summary (&optional start-point) "Generate summary lines for all the messages in the optional argument START-POINT (a list of messages) or, if it is nil, all the messages in the current folder." (let ((m-list (or start-point vm-message-list)) (n 0) (modulus 100) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces))) ;; (setq mp m-list) (save-excursion (set-buffer vm-summary-buffer) (setq line-move-ignore-invisible vm-summary-show-threads) (let ((buffer-read-only nil) (modified (buffer-modified-p)) (debug nil) ; vm-summary-debug, if necessary track) (unwind-protect (progn (if (null start-point) (setq vm-summary-pointer nil)) (if start-point (goto-char (or (vm-su-start-of (car m-list)) (point-max))) (goto-char (point-min))) (vm-disable-extents (point) (point-max)) (delete-region (point) (point-max)) ;; avoid doing long runs down the marker chain while ;; building the summary. use integers to store positions ;; and then convert them to markers after all the ;; insertions are done. Likewise, detach overlays and ;; re-establish them afterwards. (vm-inform 7 "Generating summary... %d" n) (overlay-recenter (point)) (let ((mp m-list) m start end track) (while mp (setq m (car mp)) (setq start (vm-su-start-of m) end (vm-su-end-of m) track (vm-su-summary-mouse-track-overlay-of m)) (when start (set-marker start nil)) (vm-set-su-start-of m nil) (when end (set-marker end nil)) (vm-set-su-end-of m nil) (when track (vm-detach-extent track)) (setq mp (cdr mp)))) (overlay-recenter (point-max)) (let ((mp m-list) m root) (while mp (setq m (car mp)) (vm-summary-debug m) (vm-set-su-start-of m (point)) (insert vm-summary-no-=>) (vm-tokenized-summary-insert m (vm-su-summary m)) (vm-set-su-end-of m (point)) (let ((s (vm-su-start-of m)) (e (vm-su-end-of m))) (when s (put-text-property s e 'vm-message m) (when (and vm-summary-enable-thread-folding vm-summary-show-threads) (if (= (vm-thread-indentation-of m) 0) (when (> (vm-thread-count m) 1) (if vm-summary-threads-collapsed (vm-summary-mark-root-collapsed m) (vm-summary-mark-root-expanded m))) (setq root (vm-thread-root m)) (when (and root (vm-collapsed-root-p root)) (unless (vm-visible-message m) (put-text-property s e 'invisible t)) ;; why mess with the root here? USR, 2010-07-20 ;; (vm-summary-mark-root-collapsed root) ))))) (setq mp (cdr mp) n (1+ n)) (when (zerop (% n modulus)) (vm-inform 7 "Generating summary... %d" n) (if debug (debug "vm-debug-summary: Generating summary")) (setq debug nil))))) ;; unwind-protection ;; convert the summary markers back from ints (let ((mp m-list) m start end) (while mp (setq m (car mp)) (setq start (or (vm-su-start-of m) (point-max)) end (or (vm-su-end-of m) (point-max)) track (vm-su-summary-mouse-track-overlay-of m)) (when do-mouse-track (vm-set-su-summary-mouse-track-overlay-of m (vm-mouse-set-mouse-track-highlight start end track))) (vm-set-su-start-of m (vm-marker start)) (vm-set-su-end-of m (vm-marker end)) (when vm-summary-enable-faces (vm-summary-faces-add m)) (setq mp (cdr mp)))) (set-buffer-modified-p modified)) (run-hooks 'vm-summary-redo-hook))) (if (>= n modulus) (unless vm-summary-debug (vm-inform 7 "Generating summary... done"))))) (defun vm-expand-thread (&optional root) "Expand the thread associated with the message at point. This will make visible all invisible elements of the thread tree and place a '-' character at the pointer position indicating that the thread can be collapsed. In a Lisp program, you should call it with an argument ROOT, which is the root of the thread you want expanded." (interactive) (unless vm-summary-enable-thread-folding (error "Thread folding not enabled")) (when (vm-interactive-p) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (vm-follow-summary-cursor) (set-buffer vm-summary-buffer)) (let ((buffer-read-only nil)) (unless root (setq root (vm-thread-root (vm-summary-message-at-point)))) (when (> (vm-thread-count root) 1) (vm-summary-mark-root-expanded root) (vm-mark-for-summary-update root) (mapc (lambda (m) (put-text-property (vm-su-start-of m) (vm-su-end-of m) 'invisible nil)) (vm-thread-subtree (vm-thread-symbol root))) (when (vm-interactive-p) (vm-update-summary-and-mode-line))))) (defun vm-collapse-thread (&optional nomove root) "Collapse the thread associated with the message at point. This will make invisible all read and non-new elements of the thread tree and will place a '+' character at the pointer position indicating the thread can be expanded. Optional argument nomove directs vm-collapse-thread to not take the default action of moving the pointer to the thread root after collapsing. In a Lisp program, you should call it with an additional argument ROOT, which is the root of the thread you want collapsed." (interactive "P") (unless vm-summary-enable-thread-folding (error "Thread folding not enabled")) (when (vm-interactive-p) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (vm-follow-summary-cursor) (set-buffer vm-summary-buffer)) (let ((buffer-read-only nil) (msg nil)) (unless root (setq msg (vm-summary-message-at-point)) (setq root (vm-thread-root msg))) (when (> (vm-thread-count root) 1) (vm-summary-mark-root-collapsed root) (vm-mark-for-summary-update root) (mapc (lambda (m) (unless (or (eq m root) (vm-visible-message m)) (put-text-property (vm-su-start-of m) (vm-su-end-of m) 'invisible t))) (vm-thread-subtree (vm-thread-symbol root))) ;; move to the parent thread only when not ;; instructed not to, AND when the currently ;; selected message will become invisible (when (vm-interactive-p) (unless nomove (when (get-text-property (+ (vm-su-start-of msg) 3) 'invisible) (goto-char (vm-su-start-of root)))) (vm-update-summary-and-mode-line))))) (defun vm-expand-all-threads () "Expand all threads in the folder, which might have been collapsed (folded) earlier." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (let ((ml vm-message-list)) (with-current-buffer vm-summary-buffer (save-excursion (mapc (lambda (m) (when (and (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (vm-expand-thread m))) ml)))) (setq vm-summary-threads-collapsed nil) (when (vm-interactive-p) (vm-update-summary-and-mode-line))) (defun vm-collapse-all-threads () "Collapse (fold) all threads in the folder so that only the roots of the threads are shown in the Summary window." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (unless vm-summary-show-threads (error "Summary is not sorted by threads")) (let ((ml vm-message-list) msg root) (with-current-buffer vm-summary-buffer (setq msg (vm-summary-message-at-point)) (setq root (vm-thread-root msg)) (save-excursion (mapc (lambda (m) (when (and (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (vm-collapse-thread t m))) ml)) (when (vm-interactive-p) (when (get-text-property (+ (vm-su-start-of msg) 3) 'invisible) (goto-char (vm-su-start-of root)))))) (setq vm-summary-threads-collapsed t) (when (vm-interactive-p) (vm-update-summary-and-mode-line))) (defun vm-toggle-thread () "Toggle collapse/expand thread associated with message at point. see `vm-expand-thread' and `vm-collapse-thread' for a description of action." (interactive) (when (and vm-summary-enable-thread-folding vm-summary-show-threads) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (when vm-summary-buffer (set-buffer vm-summary-buffer) (let ((buffer-read-only nil) root next) (setq root (vm-thread-root (vm-summary-message-at-point))) (if (vm-expanded-root-p root) (call-interactively 'vm-collapse-thread) (call-interactively 'vm-expand-thread)) )))) (defun vm-do-needed-summary-rebuild () "Rebuild the summary lines of all the messages starting at `vm-summary-redo-start-point'. Also, reset the summary pointer to the current message. Do the latter anyway if `vm-need-summary-pointer-update' is non-NIL. All this, only if the Summary buffer exists. " (if (and vm-summary-redo-start-point vm-summary-buffer) (progn (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads) (vm-do-summary (and (consp vm-summary-redo-start-point) vm-summary-redo-start-point)) (setq vm-summary-redo-start-point nil) (when vm-message-pointer (vm-set-summary-pointer (car vm-message-pointer))) (setq vm-need-summary-pointer-update nil)) (when (and vm-need-summary-pointer-update vm-summary-buffer vm-message-pointer) (vm-set-summary-pointer (car vm-message-pointer)) (setq vm-need-summary-pointer-update nil)))) (defun vm-update-message-summary (m) "Replace the summary line of the message M in the summary buffer by a regenerated summary line." (vm-summary-debug m) (if (and (buffer-name (vm-buffer-of m)) ; ignore deleted folders and (markerp (vm-su-start-of m)) ; markers into deleted buffers (marker-buffer (vm-su-start-of m))) (let ((modified (buffer-modified-p)) ; Folder or Presentation (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) summary) (save-excursion (setq summary (vm-su-summary m)) (set-buffer (marker-buffer (vm-su-start-of m))) (let ((buffer-read-only nil) s e i (selected nil) (indicator nil) (modified (buffer-modified-p))) ; Summary buffer (unwind-protect (save-excursion (goto-char (vm-su-start-of m)) (setq selected (looking-at "[+-]>")) (if (and vm-summary-show-threads (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (setq indicator (if (vm-collapsed-root-p m) "+" "-")) (setq indicator nil)) ;; We do a little dance to update the text in ;; order to make the markers in the text do ;; what we want. ;; ;; 1. We need to avoid having the su-start-of ;; and su-end-of markers clumping together at ;; the start position. ;; ;; 2. We want the window point marker (w->pointm ;; in the Emacs display code) to move to the ;; start of the summary entry if it is ;; anywhere within the su-start-of to ;; su-end-of region. ;; ;; We achieve (2) by deleting before inserting. ;; Reversing the order of insertion/deletion ;; pushes the point marker into the next ;; summary entry. We achieve (1) by inserting a ;; placeholder character at the end of the ;; summary entry before deleting the region. (goto-char (vm-su-end-of m)) (insert-before-markers "z") (goto-char (vm-su-start-of m)) (setq s (vm-su-start-of m)) (setq e (vm-su-end-of m)) (setq i (get-text-property (+ s 2) 'invisible)) (delete-region (point) (1- (vm-su-end-of m))) (if (not selected) (insert (concat (or indicator " ") " ")) (if indicator (insert (concat indicator ">")) (insert vm-summary-=>))) (vm-tokenized-summary-insert m (vm-su-summary m)) (delete-char 1) ; delete "z" (run-hooks 'vm-summary-update-hook) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of m) (vm-su-end-of m) (vm-su-summary-mouse-track-overlay-of m))) (if vm-summary-enable-faces (vm-summary-faces-add m) (if (and selected (facep vm-summary-highlight-face)) (vm-summary-highlight-region (vm-su-start-of m) (point) vm-summary-highlight-face)))) (when s (put-text-property s e 'vm-message m) (put-text-property s e 'invisible i)) (vm-reset-buffer-modified-p ; Summary buffer modified (current-buffer)) )))))) (defun vm-set-summary-pointer (m) "Set the summary-pointer in the summary window to the message M. Also move the cursor (point and window-point)." (if vm-summary-buffer (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) (old-window nil)) (with-current-buffer vm-summary-buffer (when w (setq old-window (selected-window)) (select-window w)) (unwind-protect (let ((buffer-read-only nil)) (when (and vm-summary-pointer (vm-su-start-of vm-summary-pointer)) (goto-char (vm-su-start-of vm-summary-pointer)) (if (not (get-text-property (+ (point) 3) 'invisible)) (let ((msg (vm-summary-message-at-point))) (if (and vm-summary-show-threads vm-summary-enable-thread-folding (eq msg (vm-thread-root msg)) (> (vm-thread-count msg) 1)) (if (vm-collapsed-root-p msg) (progn (insert "+ ") (delete-char (length vm-summary-=>))) (progn (insert "- ") (delete-char (length vm-summary-=>)))) (insert vm-summary-no-=>) (delete-char (length vm-summary-=>)))) (delete-char (length vm-summary-=>)) (insert vm-summary-no-=>) ;; re-invisible it so we dont have problems (put-text-property (- (point) (length vm-summary-no-=>)) (point) 'invisible t)) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of vm-summary-pointer) (vm-su-end-of vm-summary-pointer) (vm-su-summary-mouse-track-overlay-of vm-summary-pointer))) (when vm-summary-enable-faces (vm-summary-faces-add vm-summary-pointer))) (setq vm-summary-pointer m) (goto-char (vm-su-start-of m)) (let ((modified (buffer-modified-p))) (unwind-protect (progn ;; ;; when we move the cursor, the thread-state ;; indicator should have already changed, ;; check now to see if we should set the ;; cursor with indicator ;; ;; if, somehow, the cursor became on an ;; invisible message in a collapsed thread, ;; assume that there is a good reason for ;; this and expand the thread (e.g in ;; visiting a folder with bookmark on ;; sub-thread ;; (if vm-summary-show-threads (if (vm-collapsed-root-p m) (insert "+>") (if (get-text-property (+ (vm-su-start-of m) 3) 'invisible) (progn (insert vm-summary-=>) (vm-expand-thread (vm-thread-root m))) (insert vm-summary-=>))) (insert vm-summary-=>)) (delete-char (length vm-summary-=>)) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-su-start-of m) (vm-su-end-of m) (vm-su-summary-mouse-track-overlay-of m))) (when vm-summary-enable-faces (vm-summary-faces-add m))) (set-buffer-modified-p modified))) (forward-char (- (length vm-summary-=>))) (when vm-summary-highlight-face (vm-summary-highlight-region (vm-su-start-of m) (vm-su-end-of m) vm-summary-highlight-face)) (when (and w vm-auto-center-summary) (vm-auto-center-summary)) (run-hooks 'vm-summary-pointer-update-hook)) ;; unwind-protections (when old-window (select-window old-window))))))) (defun vm-summary-highlight-region (start end face) (vm-summary-xxxx-highlight-region start end face 'vm-summary-overlay)) (defun vm-folders-summary-highlight-region (start end face) (vm-summary-xxxx-highlight-region start end face 'vm-folders-summary-overlay)) (defun vm-summary-xxxx-highlight-region (start end face var) (let ((ooo (symbol-value var))) (cond (vm-fsfemacs-p (if (and ooo (overlay-buffer ooo)) (move-overlay ooo start end) (setq ooo (make-overlay start end)) (set var ooo) (overlay-put ooo 'evaporate nil) (overlay-put ooo 'face face))) (vm-xemacs-p (if (and ooo (vm-extent-end-position ooo)) (vm-set-extent-endpoints ooo start end) (setq ooo (vm-make-extent start end)) (set var ooo) ;; the reason this isn't needed under FSF Emacs is ;; that insert-before-markers also inserts before ;; overlays! so a summary update of an entry just ;; before this overlay in the summary buffer won't ;; leak into the overlay, but it _will_ leak into an ;; XEmacs extent. (vm-set-extent-property ooo 'start-open t) (vm-set-extent-property ooo 'detachable nil) (vm-set-extent-property ooo 'face face)))))) (defun vm-auto-center-summary () (if vm-auto-center-summary (if (or (eq vm-auto-center-summary t) (not (one-window-p t))) (recenter '(4))))) (defun vm-summary-sprintf (format message &optional tokenize) "Generates a summary in FORMAT for MESSAGE and return the result. The optional argument TOKENIZE says whether the summary should be in tokenized form. If so, the result is a list of tokens, including strings in mime-decoded form with text-properties. Otherwise, it is a string in mime-decoded form with text-properties. USR, 2010-05-13" ;; compile the format into an eval'able s-expression ;; if it hasn't been compiled already. (let* ((alist-var (if tokenize 'vm-summary-tokenized-compiled-format-alist 'vm-summary-untokenized-compiled-format-alist)) (match (assoc format (symbol-value alist-var)))) (unless match (vm-summary-compile-format format tokenize) (setq match (assoc format (symbol-value alist-var)))) ;; The local variable name `vm-su-message' is mandatory here for ;; the format s-expression to work. (let ((vm-su-message message)) (if (or tokenize (null vm-display-using-mime)) (eval (cdr match)) (vm-decode-mime-encoded-words-in-string (eval (cdr match))))))) (defun vm-summary-compile-format (format tokenize) "Compile FORMAT into an eval'able expression that generates the summary. If TOKENIZE is t, the the summary generated will be a list of tokens. Otherwise it is a string in mime-decoded form with text-propertiies. USR, 2010-05-13." (let ((return-value (nth 1 (vm-summary-compile-format-1 format tokenize)))) (if tokenize (setq vm-summary-tokenized-compiled-format-alist (cons (cons format return-value) vm-summary-tokenized-compiled-format-alist)) (setq vm-summary-untokenized-compiled-format-alist (cons (cons format return-value) vm-summary-untokenized-compiled-format-alist))))) ;; Inserts the summary line for MESSAGE created from TOKENS, which is ;; a list of tokens. A token is one of ;; - string, which is inserted literally, ;; - 'number, meaning message number, ;; - 'mark, meaning the message mark indicator, ;; - 'thread-indent, meaning the indentation space for the message ;; - 'group-begin and 'group-end (defun vm-tokenized-summary-insert (message tokens) "Insert a summary line for MESSAGE in the current buffer, using the tokenized summary TOKENS." (if (stringp tokens) (insert tokens) (let (token group-list) (while tokens (setq token (car tokens)) (cond ((stringp token) (if vm-display-using-mime (let ((vm-mime-qp-decoder-program nil) ; speed up decoding (vm-mime-base64-decoder-program nil)) (insert (vm-decode-mime-encoded-words-in-string token))) (insert token))) ((eq token 'group-begin) (setq group-list (cons (list (point) (nth 1 tokens) (nth 2 tokens)) group-list) tokens (cdr (cdr tokens)))) ((eq token 'group-end) (let* ((space (string-to-char " ")) (blob (car group-list)) (start (car blob)) (field-width (nth 1 blob)) (precision (nth 2 blob)) (end (vm-marker (point)))) (if (integerp field-width) (if (< (- end start) (vm-abs field-width)) (if (< field-width 0) (insert-char space (vm-abs (+ field-width (- end start)))) (save-excursion (goto-char start) (insert-char space (- field-width (- end start))))))) (if (integerp precision) (if (> (- end start) (vm-abs precision)) (if (> precision 0) (delete-char (- precision (- end start))) (save-excursion (goto-char start) (delete-char (vm-abs (+ precision (- end start)))))))) (setq group-list (cdr group-list)))) ((eq token 'number) (if (and vm-summary-enable-thread-folding vm-summary-show-threads vm-summary-show-thread-count) (if (= (vm-thread-indentation message) 0) (insert (concat (vm-padded-number-of message) (vm-summary-padded-thread-count message))) (insert (vm-summary-message-number-thread-descendant message))) (insert (vm-padded-number-of message)))) ((eq token 'mark) (insert (vm-su-mark message))) ((eq token 'thread-indent) (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level)) (insert-char ?\ (* vm-summary-thread-indent-level (min vm-summary-maximum-thread-indentation (vm-thread-indentation message))))))) (setq tokens (cdr tokens)))))) (defun vm-reencode-mime-encoded-words-in-tokenized-summary (summary) "Given a tokenized SUMMARY, with tokens including mime-decoded strings, returns another version where the strings are reencoded in mime. It is used for writing summary lines to disk. USR, 2010-05-13." (mapcar (function (lambda (token) (if (stringp token) (vm-reencode-mime-encoded-words-in-string token) token))) summary)) (defun vm-summary-compile-format-1 (format &optional tokenize start-index) (or start-index (setq start-index 0)) (let ((case-fold-search nil) (finished-parsing-format nil) (list nil) (sexp nil) (sexp-fmt nil) (saw-close-group nil) (last-match-end start-index) new-match-end token conv-spec splice) (store-match-data nil) (while (and (not saw-close-group) (not finished-parsing-format)) (setq token nil splice nil) (while (and (not saw-close-group) (not token) (string-match "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()pPaAbcSdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)" format last-match-end)) (setq conv-spec (aref format (match-beginning 5))) (setq new-match-end (match-end 0)) (if (and (memq conv-spec '(?\( ?\) ?p ?P ?a ?A ?b ?c ?S ?d ?f ?F ?h ?H ?i ?I ?l ?L ?M ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* )) ;; for the non-tokenized path, we don't want ;; the close group spcifier processed here, we ;; want to just bail out and return, which is ;; accomplished by setting a flag in the other ;; branch of this 'if'. (or tokenize (not (= conv-spec ?\))))) (progn (cond ((= conv-spec ?\() (if (not tokenize) (save-match-data (let ((retval (vm-summary-compile-format-1 format tokenize (match-end 5)))) (setq sexp (cons (nth 1 retval) sexp) new-match-end (car retval)))) (setq token `('group-begin ,(if (match-beginning 2) (string-to-number (concat (match-string 1 format) (match-string 2 format)))) ,(string-to-number (match-string 4 format))) splice t))) ((= conv-spec ?\)) (setq token ''group-end)) ((= conv-spec ?p) (setq sexp (cons (list 'vm-su-postponed-indicator 'vm-su-message) sexp))) ((= conv-spec ?P) (setq sexp (cons (list 'vm-su-attachment-indicator 'vm-su-message) sexp))) ((= conv-spec ?a) (setq sexp (cons (list 'vm-su-attribute-indicators 'vm-su-message) sexp))) ((= conv-spec ?A) (setq sexp (cons (list 'vm-su-attribute-indicators-long 'vm-su-message) sexp))) ((= conv-spec ?b) (setq sexp (cons (list 'vm-su-attribute-indicators-short 'vm-su-message) sexp))) ((= conv-spec ?c) (setq sexp (cons (list 'vm-su-byte-count 'vm-su-message) sexp))) ((= conv-spec ?S) (setq sexp (cons (list 'vm-su-size 'vm-su-message) sexp))) ((= conv-spec ?d) (setq sexp (cons (list 'vm-su-monthday 'vm-su-message) sexp))) ((= conv-spec ?f) (setq sexp (cons (list 'vm-su-interesting-from 'vm-su-message) sexp))) ((= conv-spec ?F) (setq sexp (cons (list 'vm-su-interesting-full-name 'vm-su-message) sexp))) ((= conv-spec ?h) (setq sexp (cons (list 'vm-su-hour 'vm-su-message) sexp))) ((= conv-spec ?H) (setq sexp (cons (list 'vm-su-hour-short 'vm-su-message) sexp))) ((= conv-spec ?i) (setq sexp (cons (list 'vm-su-message-id 'vm-su-message) sexp))) ((= conv-spec ?I) (if tokenize (setq token ''thread-indent) (setq sexp (cons (list 'vm-su-thread-indent 'vm-su-message) sexp)))) ((= conv-spec ?l) (setq sexp (cons (list 'vm-su-line-count 'vm-su-message) sexp))) ((= conv-spec ?L) (setq sexp (cons (list 'vm-su-labels 'vm-su-message) sexp))) ((= conv-spec ?m) (setq sexp (cons (list 'vm-su-month 'vm-su-message) sexp))) ((= conv-spec ?M) (setq sexp (cons (list 'vm-su-month-number 'vm-su-message) sexp))) ((= conv-spec ?n) (if tokenize (setq token ''number) (setq sexp (cons (list 'vm-padded-number-of 'vm-su-message) sexp)))) ((= conv-spec ?s) (setq sexp (cons (list 'vm-su-subject 'vm-su-message) sexp))) ((= conv-spec ?T) (setq sexp (cons (list 'vm-su-to-names 'vm-su-message) sexp))) ((= conv-spec ?t) (setq sexp (cons (list 'vm-su-to 'vm-su-message) sexp))) ((= conv-spec ?U) (setq sexp (cons (list 'vm-run-user-summary-function (list 'quote (intern (concat "vm-summary-function-" (substring format (1+ (match-beginning 5)) (+ 2 (match-beginning 5)))))) 'vm-su-message) sexp))) ((= conv-spec ?w) (setq sexp (cons (list 'vm-su-weekday 'vm-su-message) sexp))) ((= conv-spec ?y) (setq sexp (cons (list 'vm-su-year 'vm-su-message) sexp))) ((= conv-spec ?z) (setq sexp (cons (list 'vm-su-zone 'vm-su-message) sexp))) ((= conv-spec ?*) (if tokenize (setq token ''mark) (setq sexp (cons (list 'vm-su-mark 'vm-su-message) sexp))))) (cond ((and (not token) vm-display-using-mime) ;; strings might have been already mime-decoded, ;; but there is no harm in doing it again. USR, 2010-05-13 (setcar sexp (list 'vm-decode-mime-encoded-words-in-string (car sexp))))) (cond ((and (not token) (match-beginning 1) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-left-justify-string 'vm-left-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2)))))) ((and (not token) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-right-justify-string 'vm-right-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2))))))) (cond ((and (not token) (match-beginning 3)) (setcar sexp (list 'vm-truncate-string (car sexp) (string-to-number (substring format (match-beginning 4) (match-end 4))))))) ;; Why do we reencode decoded strings? USR, 2010-05-12 ;; (cond ((and (not token) vm-display-using-mime) ;; (setcar sexp ;; (list 'vm-reencode-mime-encoded-words-in-string ;; (car sexp))))) (setq sexp-fmt (cons (if token "" "%s") (cons (substring format last-match-end (match-beginning 0)) sexp-fmt)))) (setq sexp-fmt (cons (if (eq conv-spec ?\)) (prog1 "" (setq saw-close-group t)) "%%") (cons (substring format (or last-match-end 0) (match-beginning 0)) sexp-fmt)))) (setq last-match-end new-match-end)) (if (and (not saw-close-group) (not token)) (setq sexp-fmt (cons (substring format last-match-end (length format)) sexp-fmt) finished-parsing-format t)) (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) (if sexp (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) (setq sexp sexp-fmt)) (if tokenize (setq list (nconc list (if (equal sexp "") nil (list sexp)) (and token (if splice token (list token)))) sexp nil sexp-fmt nil))) (list last-match-end (if list (cons 'list list) sexp)))) ;;;###autoload (defun vm-get-header-contents (message header-name-regexp &optional clump-sep) "Return the header field of MESSAGE with the header name matching HEADER-NAME-REGEXP. The result will be a string that is mime-encoded. The optional argument CLUMP-SEP, if present, should be a string, which can be used as a separator to concatenate the fields of multiple header lines which might match HEADER-NAME-REGEXP. USR, 2010-05-13." (let ((contents nil) (regexp (concat "^\\(" header-name-regexp "\\)"))) (setq message (vm-real-message-of message)) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) (save-restriction (widen) (goto-char (vm-headers-of message)) (let ((case-fold-search t)) (while (and (or (null contents) clump-sep) (re-search-forward regexp (vm-text-of message) t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header))) (if contents (setq contents (concat contents clump-sep (vm-matched-header-contents))) (setq contents (vm-matched-header-contents)))))) contents ))) ;; Do not use Emacs 20's string-width here. ;; It does not consider buffer-display-table. (defun vm-string-width (string) (if (not (fboundp 'char-width)) (length string) (let ((i 0) (lim (length string)) (total 0)) (while (< i lim) (setq total (+ total (char-width (aref string i))) i (1+ i))) total ))) (defun vm-left-justify-string (string width) (let ((sw (vm-string-width string))) (if (>= sw width) string (concat string (make-string (- width sw) ?\ ))))) (defun vm-right-justify-string (string width) (let ((sw (vm-string-width string))) (if (>= sw width) string (concat (make-string (- width sw) ?\ ) string)))) ;; I don't think number glyphs ever have a width > 1 (defun vm-numeric-left-justify-string (string width) (let ((sw (length string))) (if (>= sw width) string (concat string (make-string (- width sw) ?0))))) ;; I don't think number glyphs ever have a width > 1 (defun vm-numeric-right-justify-string (string width) (let ((sw (length string))) (if (>= sw width) string (concat (make-string (- width sw) ?0) string)))) (defun vm-truncate-string (string width) (cond ((fboundp 'char-width) (cond ((> width 0) (let ((i 0) (lim (length string)) (total 0)) (while (and (< i lim) (< total width)) (setq total (+ total (char-width (aref string i))) i (1+ i))) (if (< total width) string (substring string 0 i)))) (t (let ((i (1- (length string))) (lim -1) (total 0)) (setq width (- width)) (while (and (> i lim) (< total width)) (setq total (+ total (char-width (aref string i))) i (1- i))) (if (< total width) string (substring string (1+ i))))))) (t (vm-truncate-roman-string string width)))) (defun vm-truncate-roman-string (string width) (cond ((<= (length string) (vm-abs width)) string) ((< width 0) (substring string width)) (t (substring string 0 width)))) (defvar vm-postponed-header) ; defined vm-pine.el (defun vm-su-postponed-indicator (msg) "Given a MESSAGE, ruturns a string indicating whether the message is a postponed draft that still needs to be sent. The indicator string is that defined by the variable `vm-summary-postponed-indicator'. USR, 2010-05-13." (if (vm-get-header-contents msg vm-postponed-header) vm-summary-postponed-indicator "")) (defun vm-su-attachment-indicator (msg) "Given a MESSAGE, ruturns a string indicating whether the message has attachments. The indicator string is the value of `vm-summary-attachment-indicator' followed by the number of attachments. USR, 2010-05-13." (let ((attachments 0)) (setq msg (vm-real-message-of msg)) ;; If this calls back vm-update-summary-and-mode-line ;; an infinite regress happens! (vm-mime-operate-on-attachments nil :action (lambda (msg layout type file) (setq attachments (1+ attachments))) :included vm-summary-attachment-mime-types :excluded vm-summary-attachment-mime-type-exceptions :messages (list msg)) (if (= attachments 0) "" (if (stringp vm-summary-attachment-indicator) vm-summary-attachment-indicator (format "%s%d" vm-summary-attachment-indicator attachments))))) (defun vm-su-attribute-indicators (m) "Given a MESSAGE, ruturns a short string showing the attributes of the message. The string is 4 characters long. USR, 2010-05-13." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")) (cond ((vm-filed-flag m) "F") ((vm-written-flag m) "W") (t " ")) (cond ((vm-replied-flag m) "R") ((vm-forwarded-flag m) "Z") ((vm-redistributed-flag m) "B") (t " ")) (cond ((vm-edited-flag m) "E") (t " ")))) (defun vm-su-attribute-indicators-short (m) "Given a MESSAGE, ruturns a short string showing the attributes of the message. The string is 1 character long. USR, 2011-01-08." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")))) (defun vm-su-attribute-indicators-long (m) "Given a MESSAGE, ruturns a long string showing the attributes of the message. The string is 7 characters long. USR, 2010-05-13." (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") ((vm-flagged-flag m) "!") (t " ")) (if (vm-replied-flag m) "r" " ") (if (vm-forwarded-flag m) "z" " ") (if (vm-redistributed-flag m) "b" " ") (if (vm-filed-flag m) "f" " ") (if (vm-written-flag m) "w" " ") (if (vm-edited-flag m) "e" " "))) (defun vm-su-byte-count (m) "Given a MESSAGE, ruturns a string showing the length of the message in bytes. USR, 2010-05-13." (or (vm-byte-count-of m) (vm-set-byte-count-of m (int-to-string (- (vm-text-end-of (vm-real-message-of m)) (vm-text-of (vm-real-message-of m))))))) (defun vm-su-size (msg) "Given a MESSAGE, return a string showing the the size of the message in bytes, kilobytes or megabytes. USR, 2010-05.13" (let ((size (string-to-number (vm-su-byte-count msg)))) (cond ((< size 1024) (format "%d" size)) ((< size 1048576) (setq size (/ size 1024)) (format "%dK" size)) (t (setq size (/ size 1048576)) (format "%dM" size))))) (defun vm-su-spam-score-aux (m) "Return the numeric spam level for M. The spam level is obtained from any of the headers listed in `vm-spam-score-headers'." (let ((spam-headers vm-spam-score-headers)) (catch 'done (while spam-headers (let* ((spam-selector (car spam-headers)) (score (vm-get-header-contents m (car spam-selector)))) (when (and score (string-match (nth 1 spam-selector) score)) (throw 'done (funcall (nth 2 spam-selector) (match-string 0 score)))) (setq spam-headers (cdr spam-headers)))) 0))) (defun vm-su-spam-score (m) "Return the numeric spam level for M (possibly using the cached-data)." (or (vm-spam-score-of m) (vm-set-spam-score-of m (vm-su-spam-score-aux m)))) (defun vm-su-weekday (m) "Given a MESSAGE, returns a string showing the week day on which it was sent. USR, 2010-05-13" (or (vm-weekday-of m) (progn (vm-su-do-date m) (vm-weekday-of m)))) (defun vm-su-monthday (m) "Given a MESSAGE, returns a string showing the month day on which it was sent. USR, 2010-05-13" (or (vm-monthday-of m) (progn (vm-su-do-date m) (vm-monthday-of m)))) (defun vm-su-month (m) (or (vm-month-of m) (progn (vm-su-do-date m) (vm-month-of m)))) (defun vm-su-month-number (m) (or (vm-month-number-of m) (progn (vm-su-do-date m) (vm-month-number-of m)))) (defun vm-su-year (m) (or (vm-year-of m) (progn (vm-su-do-date m) (vm-year-of m)))) (defun vm-su-hour-short (m) (let ((string (vm-su-hour m))) (if (> (length string) 5) (substring string 0 5) string))) (defun vm-su-hour (m) (or (vm-hour-of m) (progn (vm-su-do-date m) (vm-hour-of m)))) (defun vm-su-zone (m) (or (vm-zone-of m) (progn (vm-su-do-date m) (vm-zone-of m)))) (defun vm-su-mark (m) (if (vm-mark-of m) "*" " ")) ;; Some yogurt-headed delivery agents don't provide a Date: header. (defun vm-grok-From_-date (message) ;; This works only on the From_ types, obviously (if (not (memq (vm-message-type-of message) '(BellFrom_ From_ From_-with-Content-Length))) nil (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) (save-excursion (save-restriction (widen) (goto-char (vm-start-of message)) (let ((case-fold-search nil)) (if (or (looking-at ;; special case this so that the "remote from blah" ;; isn't included. "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*") (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)")) (vm-buffer-substring-no-properties (match-beginning 1) (match-end 1))))))))) (defun vm-su-do-date (m) (let ((case-fold-search t) vector date) (setq date (or ;; (and vm-sort-messages-by-delivery-date ;; (vm-get-header-contents m "Delivery-Date:")) (vm-get-header-contents m "Date:") (vm-grok-From_-date m))) (cond ((null date) (vm-set-weekday-of m "") (vm-set-monthday-of m "") (vm-set-month-of m "") (vm-set-month-number-of m "") (vm-set-year-of m "") (vm-set-hour-of m "") (vm-set-zone-of m "")) ((string-match ;; The date format recognized here is the one specified in RFC 822. ;; Some slop is allowed e.g. dashes between the monthday, month and year ;; because such malformed headers have been observed. "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)" date) (if (match-beginning 2) (vm-su-do-weekday m (substring date (match-beginning 2) (match-end 2))) (vm-set-weekday-of m "")) (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) (vm-su-do-month m (substring date (match-beginning 4) (match-end 4))) (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) (if (= 2 (length (vm-year-of m))) (save-match-data (cond ((string-match "^[0-6]" (vm-year-of m)) (vm-set-year-of m (concat "20" (vm-year-of m)))) (t (vm-set-year-of m (concat "19" (vm-year-of m))))))) (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6))) (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7)))) ((string-match ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for ;; the possibility of a timezone at the end. "\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|\\(-\\|\\+\\)[01][0-9][0-9][0-9]\\)?" date) (vm-su-do-weekday m (substring date (match-beginning 1) (match-end 1))) (vm-su-do-month m (substring date (match-beginning 2) (match-end 2))) (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3))) (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4))) (vm-set-year-of m (substring date (match-beginning 5) (match-end 5))) (if (match-beginning 6) (vm-set-zone-of m (substring date (match-beginning 6) (match-end 6))) (vm-set-zone-of m ""))) (t (setq vector (vm-parse-date date)) (vm-su-do-weekday m (elt vector 0)) (vm-set-monthday-of m (elt vector 1)) (vm-su-do-month m (elt vector 2)) (vm-set-year-of m (elt vector 3)) (vm-set-hour-of m (elt vector 4)) (vm-set-zone-of m (elt vector 5))))) ;; Normalize all hour and date specifications to avoid jagged margins. ;; If the hour is " 3:..." or "3:...", turn it into "03:...". ;; If the date is "03", turn it into " 3". (cond ((null (vm-hour-of m)) nil) ((string-match "\\`[0-9]:" (vm-hour-of m)) (vm-set-hour-of m (concat "0" (vm-hour-of m))))) (cond ((null (vm-monthday-of m)) nil) ((string-match "\\`0[0-9]\\'" (vm-monthday-of m)) (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2)))) ) (defun vm-su-do-month (m month-abbrev) (let ((val (assoc (downcase month-abbrev) vm-month-alist))) (if val (progn (vm-set-month-of m (nth 1 val)) (vm-set-month-number-of m (nth 2 val))) (vm-set-month-of m "") (vm-set-month-number-of m "")))) (defun vm-su-do-weekday (m weekday-abbrev) (let ((val (assoc (downcase weekday-abbrev) vm-weekday-alist))) (if val (vm-set-weekday-of m (nth 1 val)) (vm-set-weekday-of m "")))) (defun vm-run-user-summary-function (function message) ;; (condition-case nil (let ((m (vm-real-message-of message))) (save-excursion (set-buffer (vm-buffer-of m)) (save-restriction (widen) (save-excursion (narrow-to-region (vm-headers-of m) (vm-text-end-of m)) (funcall function m))))) ;; (error " ")) ) (defun vm-su-full-name (m) "Returns the author name of M as a string, either from the stored entry (vm-full-name-of) or recalculating it if necessary. The result is a mime-decoded string with text-properties. USR 2010-05-13" (or (vm-full-name-of m) (progn (vm-su-do-author m) (vm-full-name-of m)))) (defun vm-su-interesting-full-name (m) "Returns the author name of M as a string, but if the author is \"uninteresting\" then returns the value of `vm-summary-uninteresting-senders-arrow' followed by recipient names. The result is a mime-decoded string with text properties. USR 2010-05-13" (if vm-summary-uninteresting-senders (let ((case-fold-search nil)) (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m)) (vm-su-full-name m))) (vm-su-full-name m))) (defun vm-su-from (m) "Returns the author address of M as a string, either from the stored entry (vm-from-of) or recalculating it if necessary. The result is a mime-encoded string, but this is not certain. USR 2010-05-13" (or (vm-from-of m) (progn (vm-su-do-author m) (vm-from-of m)))) (defun vm-su-interesting-from (m) "Returns the author address of M as a string, but if the author is \"uninteresting\" then returns the value of `vm-summary-uninteresting-senders-arrow' followed by recipient addresses. The result is a mime-encoded string, but this not certain. USR 2010-05-13" (if vm-summary-uninteresting-senders (let ((case-fold-search nil)) (if (string-match vm-summary-uninteresting-senders (vm-su-from m)) (concat vm-summary-uninteresting-senders-arrow (vm-su-to m)) (vm-su-from m))) (vm-su-from m))) ;; Some yogurt-headed delivery agents don't even provide a From: header. (defun vm-grok-From_-author (message) ;; This works only on the From_ types, obviously (if (not (memq (vm-message-type-of message) '(From_ BellFrom_ From_-with-Content-Length))) nil (save-excursion (set-buffer (vm-buffer-of message)) (save-excursion (save-restriction (widen) (goto-char (vm-start-of message)) (let ((case-fold-search nil)) (if (looking-at "From \\([^ \t\n]+\\)") (vm-buffer-substring-no-properties (match-beginning 1) (match-end 1))))))))) (defun vm-su-do-author (m) "Parses the From headers of the message M and stores the results in the from and full-name entries of the cached-data vector. USR, 2010-05-13" (let ((full-name (vm-get-header-contents m "Full-Name:")) (from (or (vm-get-header-contents m "From:" ", ") (vm-grok-From_-author m))) pair i) (if (and full-name (string-match "^[ \t]*$" full-name)) (setq full-name nil)) (if (null from) (progn (setq from "???") (if (null full-name) (setq full-name "???"))) (setq pair (funcall vm-chop-full-name-function from) from (or (nth 1 pair) from) full-name (or full-name (nth 0 pair) from))) (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" full-name i)) (aset full-name i ?\ )) (vm-set-full-name-of m (vm-decode-mime-encoded-words-in-string full-name)) (vm-set-from-of m (vm-decode-mime-encoded-words-in-string from)))) (defun vm-default-chop-full-name (address) (let ((from address) (full-name nil)) (cond ((string-match "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'" address) (if (match-beginning 1) (setq full-name (substring address (match-beginning 1) (match-end 1)))) (setq from (substring address (match-beginning 3) (match-end 3)))) ((string-match "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'" address) (if (match-beginning 3) (setq full-name (substring address (match-beginning 3) (match-end 3)))) (setq from (substring address (match-beginning 1) (match-end 1))))) (list full-name from))) ;; test for existence and functionality of mail-extract-address-components ;; there are versions out there that don't work right, so we run ;; some test data through it to see if we can trust it. (defun vm-choose-chop-full-name-function (address) (let ((test-data '(("kyle@uunet.uu.net" . (nil "kyle@uunet.uu.net")) ("c++std=lib@inet.research.att.com" . (nil "c++std=lib@inet.research.att.com")) ("\"Piet.Rypens\" " . ("Piet Rypens" "rypens@reks.uia.ac.be")) ("makke@wins.uia.ac.be (Marc.Gemis)" . ("Marc Gemis" "makke@wins.uia.ac.be")) ("" . (nil nil)))) (failed nil) result) (while test-data (setq result (condition-case nil (mail-extract-address-components (car (car test-data))) (error nil))) (if (not (equal result (cdr (car test-data)))) ;; failed test, use default (setq failed t test-data nil) (setq test-data (cdr test-data)))) (if failed ;; it failed, use default (setq vm-chop-full-name-function 'vm-default-chop-full-name) ;; it passed the tests (setq vm-chop-full-name-function 'mail-extract-address-components)) (funcall vm-chop-full-name-function address))) (defun vm-su-do-recipients (m) (let ((mail-use-rfc822 t) i names addresses to cc all list full-name) (setq to (or (vm-get-header-contents m "To:" ", ") (vm-get-header-contents m "Apparently-To:" ", ") (vm-get-header-contents m "Newsgroups:" ", ") ;; desperation.... (user-login-name)) cc (or (vm-get-header-contents m "Cc:" ", ") (vm-get-header-contents m "Bcc:" ", ")) all to all (if all (concat all ", " cc) cc) addresses (condition-case err (rfc822-addresses all) (error (vm-warn 0 5 err) (list "corrupted-header")))) (setq list (vm-parse-addresses all)) ; adds text properties for charsets (while list ;; Just like vm-su-do-author: (setq full-name (or (nth 0 (funcall vm-chop-full-name-function (car list))) (car list))) ;; If double quotes are around the full name, fish the name out. (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name) (setq full-name (substring full-name (match-beginning 1) (match-end 1)))) (while (setq i (string-match "\n" full-name i)) (aset full-name i ?\ )) (setq names (cons full-name names)) (setq list (cdr list))) (setq names (nreverse names)) ;; added by jwz for fixed vm-parse-addresses (vm-set-to-of m (mapconcat 'identity addresses ", ")) (vm-set-to-names-of m (mapconcat 'identity names ", ")))) (defun vm-su-to (m) "Returns the recipient addresses of M as a string, either from the stored entry (vm-to-of) or recalculating them if necessary. The result is a mime-decoded string with text properties. USR 2010-05-13" (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m)))) (defun vm-su-to-names (m) "Returns the recipient names of M as a string, either from the stored entry (vm-to-names-of) or recalculating them if necessary. The result is a mime-decoded string with text properties. USR 2010-05-13" (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m)))) ;;;###autoload (defun vm-su-message-id (m) "Returns the message id of M. It is a mime-encoded string. USR 2010-12-16" (or (vm-message-id-of m) (vm-set-message-id-of m (or (let ((id (vm-get-header-contents m "Message-Id:"))) (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)")))) ;; try running md5 on the message body to produce an ID ;; better than nothing. (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (save-restriction (widen) (condition-case nil (concat "") (error nil)))) (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>"))))) (defun vm-su-line-count (m) "Returns the line count of M as a string, either from the stored entry (vm-line-count-of) or recalculating it if necessary. USR 2010-05-13" (or (vm-line-count-of m) (vm-set-line-count-of m (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (save-restriction (widen) (int-to-string (count-lines (vm-text-of (vm-real-message-of m)) (vm-text-end-of (vm-real-message-of m))))))))) ;;;###autoload (defun vm-su-subject (m) "Returns the subject string of M, either from the stored entry (vm-subject-of) or recalculating it if necessary. It is a mime-decoded string with text properties. USR 2010-05-13" (or (vm-subject-of m) (vm-set-subject-of m (let ((subject (vm-decode-mime-encoded-words-in-string (or (vm-get-header-contents m "Subject:") ""))) (i nil)) (while (string-match "\n[ \t]*" subject) (setq subject (replace-match " " nil t subject))) subject )))) (defun vm-su-summary (m) "Returns the tokenized summary line of M, either from the stored entry (vm-summary-of) or recalculating it if necessary. The summary line is a mime-decoded string with text properties. USR 2010-05-13" (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m))) (or (vm-virtual-summary-of m) (save-excursion (vm-select-folder-buffer) (vm-set-virtual-summary-of m (vm-summary-sprintf vm-summary-format m t)) (vm-virtual-summary-of m))) (or (vm-summary-of m) (save-excursion (vm-select-folder-buffer) (vm-set-summary-of m (vm-summary-sprintf vm-summary-format m t)) (vm-summary-of m))))) ;;;###autoload (defun vm-fix-my-summary (&optional kill-local-summary) "Rebuild the summary. Call this function if you made changes to `vm-summary-format'." (interactive "P") (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if kill-local-summary (kill-local-variable 'vm-summary-format)) (vm-inform 5 "Fixing your summary... %s" vm-summary-format) (let ((mp vm-message-list)) ;; Erase all the cached summary and threading data (while mp (vm-set-summary-of (car mp) nil) (vm-set-thread-indentation-of (car mp) nil) (vm-set-thread-list-of (car mp) nil) (vm-set-thread-subtree-of (car mp) nil) (vm-mark-for-summary-update (car mp)) (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp))) ;; Erase threading information (setq vm-thread-obarray 'bonk vm-thread-subject-obarray 'bonk) ;; Generate fresh summary data and stuff it ;; (vm-inform 7 "Stuffing cached data...") ;; (vm-stuff-folder-data nil) ;; (vm-inform 7 "Stuffing cached data... done") ;; (set-buffer-modified-p t) ;; Regenerate the summary (vm-inform 5 "Recreating summary...") (vm-update-summary-and-mode-line) (unless vm-summary-debug (vm-inform 5 "Recreating summary... done"))) (if vm-thread-debug (vm-check-thread-integrity)) (vm-inform 5 "Fixing your summary... done")) (defun vm-su-thread-indent (m) (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level)) (make-string (* (vm-thread-indentation m) vm-summary-thread-indent-level) ?\ ) "" )) (defun vm-su-labels (m) (or (vm-label-string-of m) (vm-set-label-string-of m (mapconcat 'identity (sort (vm-labels-of m) 'string-lessp) ",")) (vm-label-string-of m))) (defun vm-make-folder-summary () (make-vector vm-folder-summary-vector-length nil)) (defun vm-fs-folder-of (fs) (aref fs 0)) (defun vm-fs-total-count-of (fs) (aref fs 1)) (defun vm-fs-new-count-of (fs) (aref fs 2)) (defun vm-fs-unread-count-of (fs) (aref fs 3)) (defun vm-fs-deleted-count-of (fs) (aref fs 4)) (defun vm-fs-start-of (fs) (aref fs 5)) (defun vm-fs-end-of (fs) (aref fs 6)) (defun vm-fs-folder-key-of (fs) (aref fs 7)) (defun vm-fs-mouse-track-overlay-of (fs) (aref fs 8)) (defun vm-fs-short-folder-of (fs) (aref fs 9)) (defun vm-fs-modflag-of (fs) (aref fs 10)) (defun vm-set-fs-folder-of (fs x) (aset fs 0 x)) (defun vm-set-fs-total-count-of (fs x) (aset fs 1 x)) (defun vm-set-fs-new-count-of (fs x) (aset fs 2 x)) (defun vm-set-fs-unread-count-of (fs x) (aset fs 3 x)) (defun vm-set-fs-deleted-count-of (fs x) (aset fs 4 x)) (defun vm-set-fs-start-of (fs x) (aset fs 5 x)) (defun vm-set-fs-end-of (fs x) (aset fs 6 x)) (defun vm-set-fs-folder-key-of (fs x) (aset fs 7 x)) (defun vm-set-fs-mouse-track-overlay-of (fs x) (aset fs 8 x)) (defun vm-set-fs-short-folder-of (fs x) (aset fs 9 x)) (defun vm-set-fs-modflag-of (fs x) (aset fs 10 x)) (defun vm-fs-spooled (fs) (let ((count 0) (list (symbol-value (intern-soft (vm-fs-folder-key-of fs) vm-folders-summary-folder-hash)))) (while list (setq count (+ count (car (vm-get-folder-totals (car list)))) list (cdr list))) (int-to-string count))) (defun vm-make-folders-summary-key (folder &optional dir) (cond ((vm-pop-folder-spec-p folder) (or (vm-pop-find-name-for-spec folder) (vm-safe-popdrop-string folder))) ((vm-imap-folder-spec-p folder) (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder))) (t (concat "folder-summary0:" (file-truename (expand-file-name folder (or dir vm-folder-directory))))))) (defun vm-open-folders-summary-database (mode) (condition-case data (open-database vm-folders-summary-database 'berkeley-db 'hash mode) (error (vm-warn 0 2 "open-database signaled: %S" data) nil ))) (defun vm-get-folder-totals (folder) (let ((default "(0 0 0 0)") fs db key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done (read default))) (if (not (featurep 'berkeley-db)) (throw 'done (read default))) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done (read default))) (setq key (vm-make-folders-summary-key folder) data (read (get-database key db default))) (close-database db) data ))) (defun vm-store-folder-totals (folder totals) (let (fs db key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done nil)) (setq key (vm-make-folders-summary-key folder) data (prin1-to-string totals)) (put-database key data db t) (close-database db) (if (null vm-folders-summary-hash) nil (setq fs (intern-soft key vm-folders-summary-hash) fs (symbol-value fs)) (if (null fs) nil (vm-set-fs-total-count-of fs (int-to-string (car totals))) (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals))))) (vm-mark-for-folders-summary-update folder)))) (defun vm-modify-folder-totals (folder action &rest objects) (let (fs db totals key data) (catch 'done (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "r"))) (throw 'done nil)) (setq key (vm-make-folders-summary-key folder)) (setq totals (get-database key db)) (close-database db) (if (null totals) (throw 'done nil)) (setq totals (read totals)) (cond ((eq action 'arrived) (let ((arrived (car objects)) c n) (setcar totals (+ (car totals) arrived)) (setq c (cdr totals)) (setcar c (+ (car c) arrived)))) ((eq action 'saved) (let ((arrived (car objects)) (m (nth 1 objects)) c n) (setcar totals (+ (car totals) arrived)) ;; increment new and unread counts if necessary. ;; messages are never saved with the deleted flag ;; set no need to check that. (setq c (cdr totals)) (if (eq (car c) -1) nil (if (vm-new-flag m) (setcar c (+ (car c) arrived)))) (setq c (cdr c)) (if (eq (car c) -1) nil (if (vm-unread-flag m) (setcar c (+ (car c) arrived))))))) (setq data (prin1-to-string totals)) (if (null (setq db (vm-open-folders-summary-database "rw+"))) (throw 'done nil)) (put-database key data db t) (close-database db) (if (null vm-folders-summary-hash) nil (setq fs (intern-soft key vm-folders-summary-hash) fs (symbol-value fs)) (if (null fs) nil (vm-set-fs-total-count-of fs (int-to-string (car totals))) (vm-set-fs-new-count-of fs (int-to-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (int-to-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (int-to-string (nth 3 totals))))) (vm-mark-for-folders-summary-update folder)))) (defun vm-folders-summary-sprintf (format layout) ;; compile the format into an eval'able s-expression ;; if it hasn't been compiled already. (let ((match (assoc format vm-folders-summary-compiled-format-alist))) (if (null match) (progn (vm-folders-summary-compile-format format) (setq match (assoc format vm-folders-summary-compiled-format-alist)))) ;; The local variable name `vm-folder-summary' is mandatory here for ;; the format s-expression to work. (let ((vm-folder-summary layout)) (eval (cdr match))))) (defun vm-folders-summary-compile-format (format) (let ((return-value (vm-folders-summary-compile-format-1 format 0))) (setq vm-folders-summary-compiled-format-alist (cons (cons format (nth 1 return-value)) vm-folders-summary-compiled-format-alist)))) (defun vm-folders-summary-compile-format-1 (format start-index) (let ((case-fold-search nil) (done nil) (sexp nil) (sexp-fmt nil) (last-match-end start-index) new-match-end conv-spec) (store-match-data nil) (while (not done) (while (and (not done) (string-match "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()dfnstu%]\\)" format last-match-end)) (setq conv-spec (aref format (match-beginning 5))) (setq new-match-end (match-end 0)) (if (memq conv-spec '(?\( ?d ?f ?n ?s ?t ?u)) (progn (cond ((= conv-spec ?\() (save-match-data (let ((retval (vm-folders-summary-compile-format-1 format (match-end 5)))) (setq sexp (cons (nth 1 retval) sexp) new-match-end (car retval))))) ((= conv-spec ?d) (setq sexp (cons (list 'vm-fs-deleted-count-of 'vm-folder-summary) sexp))) ((= conv-spec ?f) (setq sexp (cons (list 'vm-fs-short-folder-of 'vm-folder-summary) sexp))) ((= conv-spec ?n) (setq sexp (cons (list 'vm-fs-new-count-of 'vm-folder-summary) sexp))) ((= conv-spec ?t) (setq sexp (cons (list 'vm-fs-total-count-of 'vm-folder-summary) sexp))) ((= conv-spec ?s) (setq sexp (cons (list 'vm-fs-spooled 'vm-folder-summary) sexp))) ((= conv-spec ?u) (setq sexp (cons (list 'vm-fs-unread-count-of 'vm-folder-summary) sexp)))) (cond ((and (match-beginning 1) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-left-justify-string 'vm-left-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2)))))) ((match-beginning 2) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-right-justify-string 'vm-right-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2))))))) (cond ((match-beginning 3) (setcar sexp (list 'vm-truncate-string (car sexp) (string-to-number (substring format (match-beginning 4) (match-end 4))))))) (setq sexp-fmt (cons "%s" (cons (substring format last-match-end (match-beginning 0)) sexp-fmt)))) (setq sexp-fmt (cons (if (eq conv-spec ?\)) (prog1 "" (setq done t)) "%%") (cons (substring format (or last-match-end 0) (match-beginning 0)) sexp-fmt)))) (setq last-match-end new-match-end)) (if (not done) (setq sexp-fmt (cons (substring format last-match-end (length format)) sexp-fmt) done t)) (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) (if sexp (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) (setq sexp sexp-fmt))) (list last-match-end sexp))) (defun vm-update-folders-summary-entry (fs) (if (and (vm-fs-start-of fs) (marker-buffer (vm-fs-start-of fs))) (let ((modified (buffer-modified-p)) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) summary) (save-excursion (set-buffer (marker-buffer (vm-fs-start-of fs))) (let ((buffer-read-only nil)) (unwind-protect (save-excursion (goto-char (vm-fs-start-of fs)) ;; We do a little dance to update the text in ;; order to make the markers in the text do ;; what we want. ;; ;; 1. We need to avoid having the start ;; and end markers clumping together at ;; the start position. ;; ;; 2. We want the window point marker (w->pointm ;; in the Emacs display code) to move to the ;; start of the summary entry if it is ;; anywhere within the su-start-of to ;; su-end-of region. ;; ;; We achieve (2) by deleting before inserting. ;; Reversing the order of insertion/deletion ;; pushes the point marker into the next ;; summary entry. We achieve (1) by inserting a ;; placeholder character at the end of the ;; summary entry before deleting the region. (goto-char (vm-fs-end-of fs)) (insert-before-markers "z") (goto-char (vm-fs-start-of fs)) (delete-region (point) (1- (vm-fs-end-of fs))) (insert (vm-folders-summary-sprintf vm-folders-summary-format fs)) (delete-char 1) (when do-mouse-track (vm-mouse-set-mouse-track-highlight (vm-fs-start-of fs) (vm-fs-end-of fs) (vm-fs-mouse-track-overlay-of fs))) ;; VM Summary Faces may not work for this yet ;; (when vm-summary-enable-faces ;; (vm-summary-faces-add fs)) ) (set-buffer-modified-p modified))))))) (defun vm-folders-summary-mode-internal () (setq mode-name "VM Folders Summary" major-mode 'vm-folders-summary-mode mode-line-format '(" %b") ;; must come after the setting of major-mode mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t buffer-offer-save nil truncate-lines t) (when (and vm-xemacs-p (featurep 'scrollbar)) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-folders-summary-mode-map) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) (when (and vm-mutable-frame-configuration vm-frame-per-folders-summary) (vm-set-hooks-for-frame-deletion)) (run-hooks 'vm-folders-summary-mode-hook)) (defun vm-do-folders-summary () (catch 'done (let ((fs-hash (make-vector 89 0)) db dp fp f key fs totals (format vm-folders-summary-format) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces))) (save-excursion (set-buffer vm-folders-summary-buffer) (erase-buffer) (let ((buffer-read-only nil)) (if (null vm-folders-summary-database) (throw 'done nil)) (if (not (featurep 'berkeley-db)) (throw 'done nil)) (if (null (setq db (vm-open-folders-summary-database "r"))) (throw 'done nil)) (setq dp vm-folders-summary-directories) (while dp (if (cdr vm-folders-summary-directories) (insert (car dp) ":\n")) (let ((default-directory (car dp))) (setq fp (sort (vm-delete-backup-file-names (vm-delete-auto-save-file-names (vm-delete-index-file-names (vm-delete-directory-names (directory-files (car dp)))))) (function string-lessp)))) (while fp (setq f (car fp) key (vm-make-folders-summary-key f (car dp)) totals (get-database key db)) (if (null totals) (let ((ff (expand-file-name f (car dp)))) (setq totals (list (or (vm-count-messages-in-file ff) -1) -1 -1 -1)) (if (eq (car totals) -1) nil (vm-store-folder-totals ff totals))) (setq totals (read totals))) (if (eq (car totals) -1) nil (setq fs (vm-make-folder-summary)) (vm-set-fs-folder-of fs (expand-file-name f (car dp))) (vm-set-fs-short-folder-of fs f) (vm-set-fs-total-count-of fs (vm-nonneg-string (car totals))) (vm-set-fs-new-count-of fs (vm-nonneg-string (nth 1 totals))) (vm-set-fs-unread-count-of fs (vm-nonneg-string (nth 2 totals))) (vm-set-fs-deleted-count-of fs (vm-nonneg-string (nth 3 totals))) (vm-set-fs-folder-key-of fs key) (vm-set-fs-start-of fs (vm-marker (point))) (insert (vm-folders-summary-sprintf format fs)) (vm-set-fs-end-of fs (vm-marker (point))) (when do-mouse-track (vm-set-fs-mouse-track-overlay-of fs (vm-mouse-set-mouse-track-highlight (vm-fs-start-of fs) (vm-fs-end-of fs)))) ;; VM Summary Faces may not work here yet ;; (when vm-summary-enable-faces ;; (vm-summary-faces-add fs)) (set (intern key fs-hash) fs)) (setq fp (cdr fp))) (setq dp (cdr dp))) (close-database db) (setq vm-folders-summary-hash fs-hash)) (goto-char (point-min)))))) (defun vm-update-folders-summary-highlight () (if (or (null vm-mail-buffer) (null (buffer-file-name vm-mail-buffer)) (null vm-folders-summary-hash)) (progn (and vm-folders-summary-overlay (vm-set-extent-endpoints vm-folders-summary-overlay 1 1)) (setq vm-mail-buffer nil)) (let ((ooo vm-folders-summary-overlay) (fs (symbol-value (intern-soft (vm-make-folders-summary-key (buffer-file-name vm-mail-buffer)) vm-folders-summary-hash)))) (if (and fs (or (null ooo) (null (vm-extent-object ooo)) (/= (vm-extent-end-position ooo) (vm-fs-end-of fs)))) (vm-folders-summary-highlight-region (vm-fs-start-of fs) (vm-fs-end-of fs) vm-summary-highlight-face))))) (defun vm-do-needed-folders-summary-update () (if (null vm-folders-summary-buffer) nil (save-excursion (set-buffer vm-folders-summary-buffer) (if (or (eq vm-modification-counter vm-flushed-modification-counter) (null vm-folders-summary-hash)) nil (mapatoms (function (lambda (sym) (let ((fs (symbol-value sym))) (if (null (vm-fs-modflag-of fs)) nil (vm-update-folders-summary-entry fs) (vm-set-fs-modflag-of fs nil))))) vm-folders-summary-hash) (vm-update-folders-summary-highlight) (setq vm-flushed-modification-counter vm-modification-counter))))) (defun vm-mark-for-folders-summary-update (folder &optional dont-descend) (let ((key (vm-make-folders-summary-key folder)) (hash vm-folders-summary-hash) (spool-hash vm-folders-summary-spool-hash) list fs ) (setq fs (symbol-value (intern-soft key hash))) (if (not fs) nil (vm-set-fs-modflag-of fs t) (vm-check-for-killed-summary) (if vm-folders-summary-buffer (save-excursion (set-buffer vm-folders-summary-buffer) (vm-increment vm-modification-counter)))) (if dont-descend nil (setq list (symbol-value (intern-soft key spool-hash))) (while list (vm-mark-for-folders-summary-update (car list) t) (setq list (cdr list)))))) (defun vm-make-folders-summary-associative-hashes () (let ((triples (vm-compute-spool-files t)) (spool-hash (make-vector 61 0)) (folder-hash (make-vector 61 0)) s-list f-list folder-key spool-key) (while triples (setq folder-key (vm-make-folders-summary-key (car (car triples))) spool-key (vm-make-folders-summary-key (nth 1 (car triples))) s-list (symbol-value (intern-soft spool-key spool-hash)) s-list (cons (car (car triples)) s-list) f-list (symbol-value (intern-soft folder-key folder-hash)) f-list (cons (nth 1 (car triples)) f-list) triples (cdr triples)) (set (intern spool-key spool-hash) s-list) (set (intern folder-key folder-hash) f-list)) (setq vm-folders-summary-spool-hash spool-hash) (setq vm-folders-summary-folder-hash folder-hash))) (defun vm-follow-folders-summary-cursor () (if (or (not (eq major-mode 'vm-folders-summary-mode)) (null vm-folders-summary-hash)) nil (catch 'done (mapatoms (function (lambda (sym) (let ((fs (symbol-value sym))) (if (and (>= (point) (vm-fs-start-of fs)) (< (point) (vm-fs-end-of fs)) (or (null vm-mail-buffer) (not (eq vm-mail-buffer (vm-get-file-buffer (vm-fs-folder-of fs)))))) (progn (setq vm-mail-buffer (save-excursion (vm-visit-folder (vm-fs-folder-of fs)) (current-buffer))) (vm-increment vm-modification-counter) (vm-update-summary-and-mode-line) (throw 'done t)))))) vm-folders-summary-hash) nil ))) ;;; vm-summary.el ends here vm-8.2.0b/lisp/vm-user.el0000755000175000017500000000430511676442161015463 0ustar srivastasrivasta;;; vm-user.el --- Interface functions to VM internal data ;; ;; This file is part of VM ;; ;; Copyright (C) 1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-user) (defun vm-user-composition-folder-buffer () "Return the folder buffer associated with the current buffer. The current buffer must be a composition buffer created by VM for a reply, resend or forward. Nil is returned if the current buffer is not associated with any VM folder. Note that the buffer returned might be a virtual folder buffer, which might have several underlying real folders associated with it. To get the list of real folder buffers associated with a composition buffer, use vm-user-composition-real-folder-buffers instead." (if (eq major-mode 'mail-mode) vm-mail-buffer nil )) (defun vm-user-composition-real-folder-buffers () "Returns a list of the real folder buffers associated with the current buffer. The current buffer must be a composition buffer created by VM for a reply, resend or forward." (if (eq major-mode 'mail-mode) (let ((list nil) (newlist nil)) (cond ((eq vm-system-state 'replying) (setq list vm-reply-list)) ((eq vm-system-state 'forwarding) (setq list vm-forward-list)) ((eq vm-system-state 'redistributing) (setq list vm-redistribute-list))) (while list (setq newlist (cons (vm-buffer-of (vm-real-message-of (car list))) newlist) list (cdr list))) newlist ) nil )) ;;; vm-user.el ends here vm-8.2.0b/lisp/vm-mime.el0000755000175000017500000114554511676442160015450 0ustar srivastasrivasta;;; vm-mime.el --- MIME support functions ;; ;; This file is part of VM ;; ;; Copyright (C) 1997-2003 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-mime) (eval-and-compile (require 'vm-misc)) (eval-when-compile (require 'vm-minibuf) (require 'vm-toolbar) (require 'vm-mouse) (require 'vm-summary) (require 'vm-folder) (require 'vm-menu) (require 'vm-crypto) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-reply) (require 'vm-digest) (require 'vm-edit) ) ;; vm-xemacs.el is a fake file to fool the Emacs 23 compiler (declare-function get-itimer "vm-xemacs" (name)) (declare-function start-itimer "vm-xemacs" (name function value &optional restart is-idle with-args &rest function-arguments)) (declare-function set-itimer-restart "vm-xemacs" (itimer restart)) (declare-function find-coding-system "vm-xemacs" (coding-system-or-name)) (declare-function latin-unity-representations-feasible-region "vm-xemacs" (start end)) (declare-function latin-unity-representations-present-region "vm-xemacs" (start end)) (declare-function latin-unity-massage-name "vm-xemacs" (a b)) (declare-function latin-unity-maybe-remap "vm-xemacs" (a1 a2 a3 a4 a5 a6)) (declare-function device-sound-enabled-p "vm-xemacs" (&optional device)) (declare-function device-bitplanes "vm-xemacs" (&optional device)) (declare-function font-height "vm-xemacs" (font &optional domain charset)) (declare-function make-glyph "vm-xemacs" (&optional spec-list type)) (declare-function set-glyph-baseline "vm-xemacs" (glyph spec &optional locale tag-set how-to-add)) (declare-function set-glyph-face "vm-xemacs" (glyph face)) (declare-function extent-list "vm-xemacs" (&optional buffer-or-string from to flags property value)) (declare-function extent-begin-glyph "vm-xemacs" (extent)) (declare-function set-extent-begin-glyph "vm-xemacs" (extent begin-glyph &optional layout)) (declare-function extent-live-p "vm-xemacs" (object)) (declare-function vm-mode "vm" (&optional read-only)) (defvar enable-multibyte-characters) ;; The following variables are defined in the code, depending on the ;; Emacs version being used. They should not be initialized here. (defvar vm-image-list) (defvar vm-image-type) (defvar vm-image-type-name) (defvar vm-extent-list) (defvar vm-overlay-list) (defun vm-mime-error (&rest args) (signal 'vm-mime-error (list (apply 'format args))) (error "can't return from vm-mime-error")) (if (fboundp 'define-error) (progn (define-error 'vm-image-too-small "Image too small") (define-error 'vm-mime-error "MIME error")) (put 'vm-image-too-small 'error-conditions '(vm-image-too-small error)) (put 'vm-image-too-small 'error-message "Image too small") (put 'vm-mime-error 'error-conditions '(vm-mime-error error)) (put 'vm-mime-error 'error-message "MIME error")) (defsubst vm-mime-handler (op type) (intern (concat "vm-mime-" op "-" type))) ;; A lot of the more complicated MIME character set processing is only ;; practical under MULE. (eval-when-compile (defvar latin-unity-ucs-list) (defvar latin-unity-character-sets) (defvar coding-system-list)) (defun vm-get-coding-system-priorities () "Return the value of `vm-coding-system-priorities', or a reasonable default for it if it's nil. " (if vm-coding-system-priorities vm-coding-system-priorities (let ((res '(iso-8859-1 iso-8859-2 iso-8859-15 iso-8859-16 utf-8))) (dolist (list-item res) ;; Assumes iso-8859-1 is always available, which is reasonable. (unless (vm-coding-system-p list-item) (delq list-item res))) res))) (defun vm-mime-charset-to-coding (charset) "Return the Emacs coding system corresonding to the given mime CHARSET." ;; We can depend on the fact that, in FSF Emacsen, coding systems ;; have aliases that correspond to MIME charset names. (let ((tmp nil)) (cond (vm-fsfemacs-mule-p (cond ((vm-coding-system-p (setq tmp (intern (downcase charset)))) tmp) ((equal charset "us-ascii") 'raw-text) ((equal charset "unknown") 'iso-8859-1) (t 'undecided))) (t ;; What about the case where vm-m-m-c-t-c-a doesn't have an ;; entry for the given charset? That shouldn't happen, if ;; vm-mime-mule-coding-to-charset-alist and ;; vm-mime-mule-charset-to-coding-alist have complete and ;; matching entries. Admittedly this last is not a ;; given. Should we make it so on startup? (By setting the ;; key for any missing entries in ;; vm-mime-mule-coding-to-charset-alist to being (format ;; "%s" coding-system), if necessary.) RWF, 2005-03-25 (setq tmp (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist)) (if tmp (cadr tmp) nil)) ))) (defun vm-get-mime-ucs-list () "Return the value of `vm-mime-ucs-list', or a reasonable default for it if it's nil. This is used instead of `vm-mime-ucs-list' directly in order to allow runtime checks for optional features like `mule-ucs' or `latin-unity'. " (if vm-mime-ucs-list vm-mime-ucs-list (if (featurep 'latin-unity) latin-unity-ucs-list (if (vm-coding-system-p 'utf-8) '(utf-8 iso-2022-jp ctext escape-quoted) '(iso-2022-jp ctext escape-quoted))))) (defun vm-update-mime-charset-maps () "Check for the presence of certain Mule coding systems, and add information about the corresponding MIME character sets to VM's configuration. " ;; Add some extra charsets that may not have been defined onto the end ;; of vm-mime-mule-charset-to-coding-alist. (mapc (lambda (x) (and (vm-coding-system-p x) ;; Not using vm-string-assoc because of some quoting ;; weirdness it's doing. (if (not (assoc (format "%s" x) vm-mime-mule-charset-to-coding-alist)) (add-to-list 'vm-mime-mule-charset-to-coding-alist (list (format "%s" x) x))))) '(utf-8 iso-8859-15 iso-8859-14 iso-8859-16 alternativnyj iso-8859-6 iso-8859-7 koi8-c koi8-o koi8-ru koi8-t koi8-u macintosh windows-1250 windows-1251 windows-1252 windows-1253 windows-1256)) ;; And make sure that the map back from coding-systems is good for ;; those charsets. (mapc (lambda (x) (or (assoc (car (cdr x)) vm-mime-mule-coding-to-charset-alist) (add-to-list 'vm-mime-mule-coding-to-charset-alist (list (car (cdr x)) (car x))))) vm-mime-mule-charset-to-coding-alist) ;; Whoops, doesn't get picked up for some reason. (add-to-list 'vm-mime-mule-coding-to-charset-alist '(iso-8859-1 "iso-8859-1"))) (eval-when-compile (when vm-fsfemacs-p (defvar latin-unity-character-sets nil))) (when vm-xemacs-mule-p (require 'vm-vars) (vm-update-mime-charset-maps) ;; If the user loads Mule-UCS, re-evaluate the MIME charset maps. (unless (vm-coding-system-p 'utf-8) (eval-after-load "un-define" `(vm-update-mime-charset-maps))) ;; Ditto for latin-unity. (unless (featurep 'latin-unity) (eval-after-load "latin-unity" `(vm-update-mime-charset-maps)))) ;;---------------------------------------------------------------------------- ;;; MIME layout structs (vm-mm) ;;---------------------------------------------------------------------------- (defconst vm-mime-layout-fields '[:type :qtype :encoding :id :description :disposition :qdisposition :header-start :header-end :body-start :body-end :parts :cache :message-symbol :display-error :layout-is-converted :unconverted-layout]) (defun vm-pp-mime-layout (layout) (pp (vm-zip-vectors vm-mime-layout-fields layout)) nil) (defun vm-make-layout (&rest plist) (vector (plist-get plist 'type) (plist-get plist 'qtype) (plist-get plist 'encoding) (plist-get plist 'id) (plist-get plist 'description) (plist-get plist 'disposition) (plist-get plist 'qdisposition) (plist-get plist 'header-start) (plist-get plist 'header-end) (plist-get plist 'body-start) (plist-get plist 'body-end) (plist-get plist 'parts) (plist-get plist 'cache) (plist-get plist 'message-symbol) (plist-get plist 'display-error) (plist-get plist 'layout-is-converted) (plist-get plist 'unconverted-layout))) (defun vm-mime-copy-layout (from to) "Copy a MIME layout FROM to the layout TO. The previous contents of TO are overwritten. USR, 2011-03-27" (let ((i (1- (length from)))) (while (>= i 0) (aset to i (aref from i)) (setq i (1- i))))) (defun vm-mime-layouts-equal (layout1 layout2) (catch 'return (if (equal layout1 layout2) (throw 'return t)) (vm-mapc (lambda (i) (unless (equal (aref layout1 i) (aref layout2 i)) (throw 'return nil))) '(0 1 2 3 4 5 6)) ; type through q-disposition (vm-mapc (lambda (i) (unless (equal (marker-position (aref layout1 i)) (marker-position (aref layout2 i))) (throw 'return nil))) '(7 9 10)) ; header-start, body-start, body-end (vm-mapc (lambda (part1 part2) (unless (vm-mime-layouts-equal part1 part2) (throw 'return nil))) (vm-mm-layout-parts layout1) (vm-mm-layout-parts layout2)) t)) (defun vm-mm-layout-type (e) (aref e 0)) (defun vm-mm-layout-qtype (e) (aref e 1)) (defun vm-mm-layout-encoding (e) (aref e 2)) (defun vm-mm-layout-id (e) (aref e 3)) (defun vm-mm-layout-description (e) (aref e 4)) (defun vm-mm-layout-disposition (e) (aref e 5)) (defun vm-mm-layout-qdisposition (e) (aref e 6)) (defun vm-mm-layout-header-start (e) (aref e 7)) (defun vm-mm-layout-header-end (e) (aref e 8)) (defun vm-mm-layout-body-start (e) (aref e 9)) (defun vm-mm-layout-body-end (e) (aref e 10)) (defun vm-mm-layout-parts (e) (aref e 11)) (defun vm-mm-layout-cache (e) (aref e 12)) (defun vm-mm-layout-message-symbol (e) (aref e 13)) (defun vm-mm-layout-message (e) (symbol-value (vm-mm-layout-message-symbol e))) ;; if display of MIME part fails, error string will be here. (defun vm-mm-layout-display-error (e) (aref e 14)) (defun vm-mm-layout-is-converted (e) (aref e 15)) (defun vm-mm-layout-unconverted-layout (e) (aref e 16)) (defun vm-set-mm-layout-type (e type) (aset e 0 type)) (defun vm-set-mm-layout-qtype (e type) (aset e 1 type)) (defun vm-set-mm-layout-encoding (e encoding) (aset e 2 encoding)) (defun vm-set-mm-layout-id (e id) (aset e 3 id)) (defun vm-set-mm-layout-description (e des) (aset e 4 des)) (defun vm-set-mm-layout-disposition (e d) (aset e 5 d)) (defun vm-set-mm-layout-qdisposition (e d) (aset e 6 d)) (defun vm-set-mm-layout-header-start (e start) (aset e 7 start)) (defun vm-set-mm-layout-header-end (e start) (aset e 8 start)) (defun vm-set-mm-layout-body-start (e start) (aset e 9 start)) (defun vm-set-mm-layout-body-end (e end) (aset e 10 end)) (defun vm-set-mm-layout-parts (e parts) (aset e 11 parts)) (defun vm-set-mm-layout-cache (e c) (aset e 12 c)) (defun vm-set-mm-layout-message-symbol (e s) (aset e 13 s)) (defun vm-set-mm-layout-display-error (e c) (aset e 14 c)) (defun vm-set-mm-layout-is-converted (e c) (aset e 15 c)) (defun vm-set-mm-layout-unconverted-layout (e l) (aset e 16 l)) (defun vm-mime-type-with-params (type params) "Returns a string concatenating MIME TYPE (a string) and PARAMS (a list of strings)." (if params (if vm-mime-avoid-folding-content-type (concat type ";\n\t " (mapconcat 'identity params ";\n\t")) (concat type "; " (mapconcat 'identity params "; "))) type)) (defun vm-mime-make-message-symbol (m) (let ((s (make-symbol "<>"))) (set s m) s )) (defun vm-mime-make-cache-symbol () (let ((s (make-symbol "<>"))) (set s s) s )) (defun vm-mm-layout (m) "Returns the mime layout of message M, either from the cache or by freshly parsing the message contents." (or (vm-mime-layout-of m) (progn (vm-set-mime-layout-of m (vm-mime-parse-entity-safe m)) (vm-mime-layout-of m)))) (defun vm-mm-encoded-header (m) (or (vm-mime-encoded-header-flag-of m) (progn (setq m (vm-real-message-of m)) (vm-set-mime-encoded-header-flag-of m (save-excursion (set-buffer (vm-buffer-of m)) (save-excursion (save-restriction (widen) (goto-char (vm-headers-of m)) (let ((case-fold-search t)) (or (re-search-forward vm-mime-encoded-word-regexp (vm-text-of m) t) 'none)))))) (vm-mime-encoded-header-flag-of m)))) ;;---------------------------------------------------------------------------- ;;; MIME encoding/decoding ;;---------------------------------------------------------------------------- (defun vm-mime-Q-decode-region (start end) (interactive "r") (let ((buffer-read-only nil)) (subst-char-in-region start end ?_ (string-to-char " ") t) (vm-mime-qp-decode-region start end))) (fset 'vm-mime-B-decode-region 'vm-mime-base64-decode-region) (defun vm-mime-Q-encode-region (start end) (let ((buffer-read-only nil) (val)) (setq val (vm-mime-qp-encode-region start end t)) ; may modify buffer (subst-char-in-region start (min end (point-max)) (string-to-char " ") ?_ t) val )) (defun vm-mime-B-encode-region (start end) (vm-mime-base64-encode-region start end nil t)) (defun vm-mime-base64-decode-string (string) (vm-with-string-as-temp-buffer string (function (lambda () (vm-mime-base64-decode-region (point-min) (point-max)))))) (defun vm-mime-base64-encode-string (string) (vm-with-string-as-temp-buffer string (function (lambda () (vm-mime-base64-encode-region (point-min) (point-max) nil t))))) (defun vm-mime-crlf-to-lf-region (start end) (let ((buffer-read-only nil)) (save-excursion (save-restriction (narrow-to-region start end) (goto-char start) (while (search-forward "\r\n" nil t) (delete-char -2) (insert "\n")))))) (defun vm-mime-lf-to-crlf-region (start end) (let ((buffer-read-only nil)) (save-excursion (save-restriction (narrow-to-region start end) (goto-char start) (while (search-forward "\n" nil t) (delete-char -1) (insert "\r\n")))))) (defun vm-encode-coding-region (b-start b-end coding-system &rest foo) (let ((work-buffer nil) start end oldsize retval (b (current-buffer))) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert-buffer-substring b b-start b-end) (setq oldsize (buffer-size)) (setq retval (apply 'encode-coding-region (point-min) (point-max) coding-system foo)) (setq start (point-min) end (point-max)) (setq retval (buffer-size)) (save-excursion (set-buffer b) (goto-char b-start) (insert-buffer-substring work-buffer start end) (delete-region (point) (+ (point) oldsize)) ;; Fixup the end point. I have found no other way to ;; let the calling function know where the region ends ;; after encode-coding-region has scrambled the markers. (and (markerp b-end) (set-marker b-end (point))) retval )) (and work-buffer (kill-buffer work-buffer))))) (defun vm-decode-coding-region (b-start b-end coding-system &rest foo) "This is a wrapper for decode-coding-region, having the same effect." (let ((work-buffer nil) start end oldsize retval (b (current-buffer))) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (setq oldsize (- b-end b-start)) (set-buffer work-buffer) (insert-buffer-substring b b-start b-end) (setq retval (apply 'decode-coding-region (point-min) (point-max) coding-system foo)) (and vm-fsfemacs-p (set-buffer-multibyte t)) ; is this safe? (setq start (point-min) end (point-max)) (save-excursion (set-buffer b) (goto-char b-start) (delete-region (point) (+ (point) oldsize)) (insert-buffer-substring work-buffer start end) ;; Fixup the end point. I have found no other way to ;; let the calling function know where the region ends ;; after decode-coding-region has scrambled the markers. (and (markerp b-end) (set-marker b-end (point))) retval )) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-charset-decode-region (charset start end) (or (markerp end) (setq end (vm-marker end))) (cond ((or vm-xemacs-mule-p vm-fsfemacs-mule-p) (if (or (and vm-xemacs-p (memq (vm-device-type) '(x gtk mswindows))) vm-fsfemacs-p (vm-mime-tty-can-display-mime-charset charset) nil) (let ((buffer-read-only nil) (coding (vm-mime-charset-to-coding charset)) (opoint (point))) ;; decode 8-bit indeterminate char to correct ;; char in correct charset. (vm-decode-coding-region start end coding) (put-text-property start end 'vm-string t) (put-text-property start end 'vm-charset charset) (put-text-property start end 'vm-coding coding) ;; In XEmacs 20.0 beta93 decode-coding-region moves point. (goto-char opoint)))) ((not (vm-multiple-fonts-possible-p)) nil) ((vm-mime-default-face-charset-p charset) nil) (t (let ((font (cdr (vm-string-assoc charset vm-mime-charset-font-alist))) (face (make-face (make-symbol "temp-face"))) (e (vm-make-extent start end))) (put-text-property start end 'vm-string t) (put-text-property start end 'vm-charset charset) (if font (condition-case data (progn (set-face-font face font) (if vm-fsfemacs-p (put-text-property start end 'face face) (vm-set-extent-property e 'duplicable t) (vm-set-extent-property e 'face face))) (error nil))))))) (defun vm-mime-transfer-decode-region (layout start end) "Decode the body of a mime part given by LAYOUT at positions START to END, and replace it by the decoded content. The decoding carried out includes base-64, quoted-printable, uuencode and CRLF conversion." (let ((case-fold-search t) (crlf nil)) (if (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) (vm-mime-types-match "message" (car (vm-mm-layout-type layout)))) (setq crlf t)) (cond ((string-match "^base64$" (vm-mm-layout-encoding layout)) (vm-mime-base64-decode-region start end crlf)) ((string-match "^quoted-printable$" (vm-mm-layout-encoding layout)) (vm-mime-qp-decode-region start end)) ((string-match "^x-uue$\\|^x-uuencode$" (vm-mm-layout-encoding layout)) (vm-mime-uuencode-decode-region start end crlf))))) (defun vm-mime-base64-decode-region (start end &optional crlf) (or (markerp end) (setq end (vm-marker end))) (and (> (- end start) 10000) (vm-emit-mime-decoding-message "Decoding base64...")) (let ((work-buffer nil) (done nil) (counter 0) (bits 0) (lim 0) inputpos (non-data-chars (concat "^=" vm-mime-base64-alphabet))) (unwind-protect (save-excursion (cond ((and (featurep 'base64) (fboundp 'base64-decode-region) ;; W3 reportedly has a Lisp version of this, and ;; there's no point running it. (subrp (symbol-function 'base64-decode-region)) ;; The FSF Emacs version of this is unforgiving ;; of errors, which is not in the spirit of the ;; MIME spec, so avoid using it. (not vm-fsfemacs-p)) (condition-case data (base64-decode-region start end) (error (vm-mime-error "%S" data))) (and crlf (vm-mime-crlf-to-lf-region start end))) (t (setq work-buffer (vm-make-work-buffer)) (if vm-mime-base64-decoder-program (let* ((binary-process-output t) ; any text already has CRLFs ;; use binary coding system in FSF Emacs/MULE (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (status (apply 'vm-run-command-on-region start end work-buffer vm-mime-base64-decoder-program vm-mime-base64-decoder-switches))) (if (not (eq status t)) (vm-mime-error "%s" (cdr status)))) (goto-char start) (skip-chars-forward non-data-chars end) (while (not done) (setq inputpos (point)) (cond ((> (skip-chars-forward vm-mime-base64-alphabet end) 0) (setq lim (point)) (while (< inputpos lim) (setq bits (+ bits (aref vm-mime-base64-alphabet-decoding-vector (char-after inputpos)))) (vm-increment counter) (vm-increment inputpos) (cond ((= counter 4) (vm-insert-char (lsh bits -16) 1 nil work-buffer) (vm-insert-char (logand (lsh bits -8) 255) 1 nil work-buffer) (vm-insert-char (logand bits 255) 1 nil work-buffer) (setq bits 0 counter 0)) (t (setq bits (lsh bits 6))))))) (cond ((= (point) end) (if (not (zerop counter)) (vm-mime-error "at least %d bits missing at end of base64 encoding" (* (- 4 counter) 6))) (setq done t)) ((= (char-after (point)) 61) ; 61 is ASCII equals (setq done t) (cond ((= counter 1) (vm-mime-error "at least 2 bits missing at end of base64 encoding")) ((= counter 2) (vm-insert-char (lsh bits -10) 1 nil work-buffer)) ((= counter 3) (vm-insert-char (lsh bits -16) 1 nil work-buffer) (vm-insert-char (logand (lsh bits -8) 255) 1 nil work-buffer)) ((= counter 0) t))) (t (skip-chars-forward non-data-chars end))))) (and crlf (save-excursion (set-buffer work-buffer) (vm-mime-crlf-to-lf-region (point-min) (point-max)))) (goto-char start) (insert-buffer-substring work-buffer) (delete-region (point) end)))) (and work-buffer (kill-buffer work-buffer)))) (and (> (- end start) 10000) (vm-emit-mime-decoding-message "Decoding base64... done"))) (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding) (or (markerp end) (setq end (vm-marker end))) (and (> (- end start) 200) (vm-inform 7 "Encoding base64...")) (let ((work-buffer nil) (buffer-undo-list t) (counter 0) (cols 0) (bits 0) (alphabet vm-mime-base64-alphabet) inputpos) (unwind-protect (save-excursion (and crlf (vm-mime-lf-to-crlf-region start end)) (cond ((and (featurep 'base64) (fboundp 'base64-encode-region) ;; W3 reportedly has a Lisp version of this, and ;; there's no point running it. (subrp (symbol-function 'base64-encode-region))) (condition-case data (base64-encode-region start end B-encoding) (wrong-number-of-arguments ;; call with two args and then strip out the ;; newlines if we're doing B encoding. (condition-case data (base64-encode-region start end) (error (vm-mime-error "%S" data))) (if B-encoding (save-excursion (goto-char start) (while (search-forward "\n" end t) (delete-char -1))))) (error (vm-mime-error "%S" data)))) (t (setq work-buffer (vm-make-work-buffer)) (if vm-mime-base64-encoder-program (let ((status (apply 'vm-run-command-on-region start end work-buffer vm-mime-base64-encoder-program vm-mime-base64-encoder-switches))) (if (not (eq status t)) (vm-mime-error "%s" (cdr status))) (if B-encoding (save-excursion (set-buffer work-buffer) ;; if we're B encoding, strip out the line breaks (goto-char (point-min)) (while (search-forward "\n" nil t) (delete-char -1))))) (setq inputpos start) (while (< inputpos end) (setq bits (+ bits (char-after inputpos))) (vm-increment counter) (cond ((= counter 3) (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil work-buffer) (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) 1 nil work-buffer) (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) 1 nil work-buffer) (vm-insert-char (aref alphabet (logand bits 63)) 1 nil work-buffer) (setq cols (+ cols 4)) (cond ((= cols 72) (setq cols 0) (if (not B-encoding) (vm-insert-char ?\n 1 nil work-buffer)))) (setq bits 0 counter 0)) (t (setq bits (lsh bits 8)))) (vm-increment inputpos)) ;; write out any remaining bits with appropriate padding (if (= counter 0) nil (setq bits (lsh bits (- 16 (* 8 counter)))) (vm-insert-char (aref alphabet (lsh bits -18)) 1 nil work-buffer) (vm-insert-char (aref alphabet (logand (lsh bits -12) 63)) 1 nil work-buffer) (if (= counter 1) (vm-insert-char ?= 2 nil work-buffer) (vm-insert-char (aref alphabet (logand (lsh bits -6) 63)) 1 nil work-buffer) (vm-insert-char ?= 1 nil work-buffer))) (if (> cols 0) (vm-insert-char ?\n 1 nil work-buffer))) (or (markerp end) (setq end (vm-marker end))) (goto-char start) (insert-buffer-substring work-buffer) (delete-region (point) end))) (and (> (- end start) 200) (vm-inform 7 "Encoding base64... done")) (- end start)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-qp-decode-region (start end) (and (> (- end start) 10000) (vm-emit-mime-decoding-message "Decoding quoted-printable...")) (let ((work-buffer nil) (buf (current-buffer)) (case-fold-search nil) (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) (?C . 12) (?D . 13) (?E . 14) (?F . 15) ;; some mailer uses lower-case hex ;; digits despite this being forbidden ;; by the MIME spec. (?a . 10) (?b . 11) (?c . 12) (?d . 13) (?e . 14) (?f . 15))) inputpos stop-point copy-point) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (if vm-mime-qp-decoder-program (let* ((binary-process-output t) ; any text already has CRLFs ;; use binary coding system in FSF Emacs/MULE (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (status (apply 'vm-run-command-on-region start end work-buffer vm-mime-qp-decoder-program vm-mime-qp-decoder-switches))) (if (not (eq status t)) (vm-mime-error "%s" (cdr status)))) (goto-char start) (setq inputpos start) (while (< inputpos end) (skip-chars-forward "^=\n" end) (setq stop-point (point)) (cond ((looking-at "\n") ;; spaces or tabs before a hard line break must be ignored (skip-chars-backward " \t") (setq copy-point (point)) (goto-char stop-point)) (t (setq copy-point stop-point))) (save-excursion (set-buffer work-buffer) (insert-buffer-substring buf inputpos copy-point)) (cond ((= (point) end) t) ((looking-at "\n") (vm-insert-char ?\n 1 nil work-buffer) (forward-char)) (t;; looking at = (forward-char) ;; a-f because some mailers use lower case hex ;; digits despite them being forbidden by the ;; MIME spec. (cond ((looking-at "[0-9A-Fa-f][0-9A-Fa-f]") (vm-insert-char (+ (* (cdr (assq (char-after (point)) hex-digit-alist)) 16) (cdr (assq (char-after (1+ (point))) hex-digit-alist))) 1 nil work-buffer) (forward-char 2)) ((looking-at "\n") ; soft line break (forward-char)) ((looking-at "\r") ;; assume the user's goatloving ;; delivery software didn't convert ;; from Internet's CRLF newline ;; convention to the local LF ;; convention. (forward-char)) ((looking-at "[ \t]") ;; garbage added in transit (skip-chars-forward " \t" end)) (t (vm-mime-error "something other than line break or hex digits after = in quoted-printable encoding"))))) (setq inputpos (point)))) (or (markerp end) (setq end (vm-marker end))) (goto-char start) (insert-buffer-substring work-buffer) (delete-region (point) end)) (and work-buffer (kill-buffer work-buffer)))) (and (> (- end start) 10000) (vm-emit-mime-decoding-message "Decoding quoted-printable... done"))) (defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from) (and (> (- end start) 200) (vm-inform 7 "Encoding quoted-printable...")) (let ((work-buffer nil) (buf (current-buffer)) (cols 0) (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) (?C . 12) (?D . 13) (?E . 14) (?F . 15))) char inputpos) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (if vm-mime-qp-encoder-program (let* ((binary-process-output t) ; any text already has CRLFs ;; use binary coding system in FSF Emacs/MULE (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (status (apply 'vm-run-command-on-region start end work-buffer vm-mime-qp-encoder-program vm-mime-qp-encoder-switches))) (if (not (eq status t)) (vm-mime-error "%s" (cdr status))) (if quote-from (save-excursion (set-buffer work-buffer) (goto-char (point-min)) (while (re-search-forward "^From " nil t) (replace-match "=46rom " t t)))) (if Q-encoding (save-excursion (set-buffer work-buffer) ;; strip out the line breaks (goto-char (point-min)) (while (search-forward "=\n" nil t) (delete-char -2)) ;; strip out the soft line breaks (goto-char (point-min)) (while (search-forward "\n" nil t) (delete-char -1))))) (setq inputpos start) (while (< inputpos end) (setq char (char-after inputpos)) (cond ((= char ?\n) (vm-insert-char char 1 nil work-buffer) (setq cols 0)) ((and (= char 32) (not (= (1+ inputpos) end)) (not (= ?\n (char-after (1+ inputpos))))) (vm-insert-char char 1 nil work-buffer) (vm-increment cols)) ((or (< char 33) (> char 126) ;; = (= char 61) ;; ? (and Q-encoding (= char 63)) ;; _ (and Q-encoding (= char 95)) (and quote-from (= cols 0) (let ((case-fold-search nil)) (looking-at "From "))) (and (= cols 0) (= char ?.) (looking-at "\\.\\(\n\\|\\'\\)"))) (vm-insert-char ?= 1 nil work-buffer) (vm-insert-char (car (rassq (lsh (logand char 255) -4) hex-digit-alist)) 1 nil work-buffer) (vm-insert-char (car (rassq (logand char 15) hex-digit-alist)) 1 nil work-buffer) (setq cols (+ cols 3))) (t (vm-insert-char char 1 nil work-buffer) (vm-increment cols))) (cond ((> cols 70) (setq cols 0) (if Q-encoding nil (vm-insert-char ?= 1 nil work-buffer) (vm-insert-char ?\n 1 nil work-buffer)))) (vm-increment inputpos))) (or (markerp end) (setq end (vm-marker end))) (goto-char start) (insert-buffer-substring work-buffer) (delete-region (point) end) (and (> (- end start) 200) (vm-inform 7 "Encoding quoted-printable... done")) (- end start)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-uuencode-decode-region (start end &optional crlf) (vm-emit-mime-decoding-message "Decoding uuencoded stuff...") (let ((work-buffer nil) (region-buffer (current-buffer)) (case-fold-search nil) (tempfile (vm-make-tempfile-name))) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert-buffer-substring region-buffer start end) (goto-char (point-min)) (or (re-search-forward "^begin [0-7][0-7][0-7] " nil t) (vm-mime-error "no begin line")) (delete-region (point) (progn (forward-line 1) (point))) (insert tempfile "\n") (goto-char (point-max)) (beginning-of-line) ;; Eudora reportedly doesn't terminate uuencoded multipart ;; bodies with a line break. 21 June 1998. ;; Actually it looks like Eudora doesn't understand the ;; multipart newline boundary rule at all and can leave ;; all types of attachments missing a line break. (if (looking-at "^end\\'") (progn (goto-char (point-max)) (insert "\n"))) (if (stringp vm-mime-uuencode-decoder-program) (let* ((binary-process-output t) ; any text already has CRLFs ;; use binary coding system in FSF Emacs/MULE (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (status (apply 'vm-run-command-on-region (point-min) (point-max) nil vm-mime-uuencode-decoder-program vm-mime-uuencode-decoder-switches))) (if (not (eq status t)) (vm-mime-error "%s" (cdr status)))) (vm-mime-error "no uuencode decoder program defined")) (delete-region (point-min) (point-max)) (insert-file-contents-literally tempfile) (and crlf (vm-mime-crlf-to-lf-region (point-min) (point-max))) (set-buffer region-buffer) (or (markerp end) (setq end (vm-marker end))) (goto-char start) (insert-buffer-substring work-buffer) (delete-region (point) end)) (and work-buffer (kill-buffer work-buffer)) (vm-error-free-call 'delete-file tempfile))) (vm-emit-mime-decoding-message "Decoding uuencoded stuff... done")) (defun vm-decode-mime-message-headers (&optional m) (vm-decode-mime-encoded-words ;; the starting point with null m is (point) to match the ;; previous duplicated code here. Not sure whether it's ;; necessary. JCB, 2011-01-03 (if m (vm-headers-of m) (point)) (if m (vm-text-of m) (point-max)))) ;; optional argument rstart and rend delimit the region in ;; which to decode (defun vm-decode-mime-encoded-words (&optional rstart rend) (let ((case-fold-search t) (buffer-read-only nil) charset need-conversion encoding match-start match-end start end previous-end) (save-excursion (goto-char (or rstart (point-min))) (while (re-search-forward vm-mime-encoded-word-regexp rend t) (setq match-start (match-beginning 0) match-end (match-end 0) charset (buffer-substring (match-beginning 1) (match-end 1)) need-conversion nil encoding (buffer-substring (match-beginning 4) (match-end 4)) start (match-beginning 5) end (vm-marker (match-end 5))) ;; don't change anything if we can't display the ;; character set properly. (if (and (not (vm-mime-charset-internally-displayable-p charset)) (not (setq need-conversion (vm-mime-can-convert-charset charset)))) nil ;; suppress whitespace between encoded words. (and previous-end (string-match "\\`[ \t\n]*\\'" (buffer-substring previous-end match-start)) (setq match-start previous-end)) (delete-region end match-end) (condition-case data (cond ((string-match "B" encoding) (vm-mime-base64-decode-region start end)) ((string-match "Q" encoding) (vm-mime-Q-decode-region start end)) (t (vm-mime-error "unknown encoded word encoding, %s" encoding))) (vm-mime-error (apply 'message (cdr data)) (goto-char start) (insert "**invalid encoded word**") (delete-region (point) end))) (and need-conversion (setq charset (vm-mime-charset-convert-region charset start end))) (vm-mime-charset-decode-region charset start end) (goto-char end) (setq previous-end end) (delete-region match-start start)))))) (defun vm-decode-mime-encoded-words-in-string (string) (if (and vm-display-using-mime (let ((case-fold-search t)) (string-match vm-mime-encoded-word-regexp string))) (vm-with-string-as-temp-buffer string 'vm-decode-mime-encoded-words) string )) (defun vm-reencode-mime-encoded-words () "Reencode in mime the words in the current buffer that need encoding. The words that need encoding are expected to have text-properties set with the appropriate characte set. This would have been done if the contents of the buffer are the result of a previous mime decoding." (let ((charset nil) start coding pos q-encoding old-size (case-fold-search t) (done nil)) (save-excursion (setq start (point-min)) (while (not done) (setq charset (get-text-property start 'vm-charset)) (setq pos (next-single-property-change start 'vm-charset)) (or pos (setq pos (point-max) done t)) (if charset (progn (if (setq coding (get-text-property start 'vm-coding)) (progn (setq old-size (buffer-size)) (encode-coding-region start pos coding) (setq pos (+ pos (- (buffer-size) old-size))))) (setq pos (+ start (if (setq q-encoding (string-match "^iso-8859-\\|^us-ascii" charset)) (vm-mime-Q-encode-region start pos) (vm-mime-B-encode-region start pos)))) (goto-char pos) (insert "?=") (setq pos (point)) (goto-char start) (insert "=?" charset "?" (if q-encoding "Q" "B") "?") (setq pos (+ pos (- (point) start))))) (setq start pos))))) (defun vm-reencode-mime-encoded-words-in-string (string) "Reencode in mime the words in STRING that need encoding. The words that need encoding are expected to have text-properties set with the appropriate character set. This would have been done if the contents of the buffer are the result of a previous mime decoding." (if (and vm-display-using-mime (text-property-any 0 (length string) 'vm-string t string)) (vm-with-string-as-temp-buffer string 'vm-reencode-mime-encoded-words) string )) ;;---------------------------------------------------------------------------- ;;; MIME parsing ;;---------------------------------------------------------------------------- (fset 'vm-mime-parse-content-header 'vm-parse-structured-header) (defun vm-mime-get-header-contents (header-name-regexp) (let ((contents nil) regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) (save-excursion (let ((case-fold-search t)) (if (and (re-search-forward regexp nil t) (match-beginning 1) (progn (goto-char (match-beginning 0)) (vm-match-header))) (vm-matched-header-contents) nil ))))) (defun* vm-mime-parse-entity (&optional m &key (default-type nil) (default-encoding nil) (passing-message-only nil)) "Parse a MIME message M and return its mime-layout. Optional arguments: DEFAULT-TYPE is the type to use if no Content-Type is specified. DEFAULT-ENCODING is the default character encoding if none is specified in the message. PASSING-MESSAGE-ONLY is a boolean argument that says that VM is only passing through this message. So, a full analysis is not required. (USR, 2010-01-12)" (catch 'return-value (save-excursion (if (and m (not passing-message-only)) (progn (setq m (vm-real-message-of m)) (set-buffer (vm-buffer-of m)))) (let ((case-fold-search t) version type qtype encoding id description disposition qdisposition boundary boundary-regexp start end multipart-list pos-list c-t c-t-e done p returnval) (save-excursion (save-restriction (if (and m (not passing-message-only)) (progn (setq version (vm-get-header-contents m "MIME-Version:") version (car (vm-parse-structured-header version)) type (vm-get-header-contents m "Content-Type:") version (if (or version vm-mime-require-mime-version-header) version (if type "1.0" nil)) qtype (vm-parse-structured-header type ?\; t) type (vm-parse-structured-header type ?\;) encoding (vm-get-header-contents m "Content-Transfer-Encoding:") version (if (or version vm-mime-require-mime-version-header) version (if encoding "1.0" nil)) encoding (or encoding "7bit") encoding (or (car (vm-parse-structured-header encoding)) "7bit") id (vm-get-header-contents m "Content-ID:") id (car (vm-parse-structured-header id)) description (vm-get-header-contents m "Content-Description:") description (and description (if (string-match "^[ \t\n]*$" description) nil description)) disposition (vm-get-header-contents m "Content-Disposition:") qdisposition (and disposition (vm-parse-structured-header disposition ?\; t)) disposition (and disposition (vm-parse-structured-header disposition ?\;))) (widen) (narrow-to-region (vm-headers-of m) (vm-text-end-of m))) (goto-char (point-min)) (setq type (vm-mime-get-header-contents "Content-Type:") qtype (or (vm-parse-structured-header type ?\; t) default-type) type (or (vm-parse-structured-header type ?\;) default-type) encoding (or (vm-mime-get-header-contents "Content-Transfer-Encoding:") default-encoding) encoding (or (car (vm-parse-structured-header encoding)) default-encoding) id (vm-mime-get-header-contents "Content-ID:") id (car (vm-parse-structured-header id)) description (vm-mime-get-header-contents "Content-Description:") description (and description (if (string-match "^[ \t\n]*$" description) nil description)) disposition (vm-mime-get-header-contents "Content-Disposition:") qdisposition (and disposition (vm-parse-structured-header disposition ?\; t)) disposition (and disposition (vm-parse-structured-header disposition ?\;)))) (cond ((null m) t) (passing-message-only t) ((null version) (throw 'return-value 'none)) ((or vm-mime-ignore-mime-version (string= version "1.0")) t) (t (vm-mime-error "Unsupported MIME version: %s" version))) ;; deal with known losers ;; Content-Type: text (cond ((and type (string-match "^text$" (car type))) (setq type '("text/plain" "charset=us-ascii") qtype '("text/plain" "charset=us-ascii")))) (cond ((and m (not passing-message-only) (null type)) (throw 'return-value (vm-make-layout 'type '("text/plain" "charset=us-ascii") 'qtype '("text/plain" "charset=us-ascii") 'encoding encoding 'id id 'description description 'disposition disposition 'qdisposition qdisposition 'header-start (vm-headers-of m) 'header-end (vm-marker (1- (vm-text-of m))) 'body-start (vm-text-of m) 'body-end (vm-text-end-of m) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) ))) ((null type) (goto-char (point-min)) (or (re-search-forward "^\n\\|\n\\'" nil t) (vm-mime-error "MIME part missing header/body separator line")) (vm-make-layout 'type default-type 'qtype default-type 'encoding encoding 'id id 'description description 'disposition disposition 'qdisposition qdisposition 'header-start (vm-marker (point-min)) 'header-body (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) )) ((null (string-match "[^/ ]+/[^/ ]+" (car type))) (vm-mime-error "Malformed MIME content type: %s" (car type))) ((and (string-match "^multipart/\\|^message/" (car type)) (null (string-match "^\\(7bit\\|8bit\\|binary\\)$" encoding)) (if vm-mime-ignore-composite-type-opaque-transfer-encoding (progn ;; Some mailers declare an opaque ;; encoding on a composite type even ;; though it's only a subobject that ;; uses that encoding. Deal with it ;; by assuming a proper transfer encoding. (setq encoding "binary") ;; return nil so and-clause will fail nil ) t )) (vm-mime-error "Opaque transfer encoding used with multipart or message type: %s, %s" (car type) encoding)) ((and (string-match "^message/partial$" (car type)) (null (string-match "^7bit$" encoding))) (vm-mime-error "Non-7BIT transfer encoding used with message/partial message: %s" encoding)) ((string-match "^multipart/digest" (car type)) (setq c-t '("message/rfc822") c-t-e "7bit")) ((string-match "^multipart/" (car type)) (setq c-t '("text/plain" "charset=us-ascii") c-t-e "7bit")) ; below ((string-match "^message/\\(rfc822\\|news\\|external-body\\)" (car type)) (setq c-t '("text/plain" "charset=us-ascii") c-t-e "7bit") (goto-char (point-min)) (or (re-search-forward "^\n\\|\n\\'" nil t) (vm-mime-error "MIME part missing header/body separator line")) (throw 'return-value (vm-make-layout 'type type 'qtype qtype 'encoding encoding 'id id 'description description 'disposition disposition 'qdisposition qdisposition 'header-start (vm-marker (point-min)) 'header-end (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'parts (list (save-restriction (narrow-to-region (point) (point-max)) (vm-mime-parse-entity-safe m :default-type c-t :default-encoding c-t-e :passing-message-only t))) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) ))) (t (goto-char (point-min)) (or (re-search-forward "^\n\\|\n\\'" nil t) (vm-mime-error "MIME part missing header/body separator line")) (throw 'return-value (vm-make-layout 'type type 'qtype qtype 'encoding encoding 'id id 'description description 'disposition disposition 'qdisposition qdisposition 'header-start (vm-marker (point-min)) 'header-end (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) )))) (setq p (cdr type) boundary nil) (while p (if (string-match "^boundary=" (car p)) (setq boundary (car (vm-parse (car p) "=\\(.+\\)")) p nil) (setq p (cdr p)))) (or boundary (vm-mime-error "Boundary parameter missing in %s type specification" (car type))) ;; the \' in the regexp is to "be liberal" in the ;; face of broken software that does not add a line ;; break after the final boundary of a nested ;; multipart entity. (setq boundary-regexp (concat "^--" (regexp-quote boundary) "\\(--\\)?[ \t]*\\(\n\\|\\'\\)")) (goto-char (point-min)) (setq start nil multipart-list nil done nil) (while (and (not done) (re-search-forward boundary-regexp nil 0)) (if (null start) (setq start (match-end 0)) (and (match-beginning 1) (setq done t)) (setq pos-list (cons start (cons (1- (match-beginning 0)) pos-list)) start (match-end 0)))) (if (and (not done) (not vm-mime-ignore-missing-multipart-boundary)) (vm-mime-error "final %s boundary missing" boundary) (if (and start (not done)) (setq pos-list (cons start (cons (point) pos-list))))) (setq pos-list (nreverse pos-list)) (while pos-list (setq start (car pos-list) end (car (cdr pos-list)) pos-list (cdr (cdr pos-list))) (save-excursion (save-restriction (narrow-to-region start end) (setq multipart-list (cons (vm-mime-parse-entity-safe m :default-type c-t :default-encoding c-t-e :passing-message-only t) multipart-list))))) (goto-char (point-min)) (or (re-search-forward "^\n\\|\n\\'" nil t) (vm-mime-error "MIME part missing header/body separator line")) (vm-make-layout 'type type 'qtype qtype 'encoding encoding 'id id 'description description 'disposition disposition 'qdisposition qdisposition 'header-start (vm-marker (point-min)) 'header-end (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'parts (nreverse multipart-list) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) ))))))) (defun* vm-mime-parse-entity-safe (&optional m &key (default-type nil) (default-encoding nil) (passing-message-only nil)) "Like vm-mime-parse-entity, but recovers from any errors. DEFAULT-TYPE, unless specified, is assumed to be text/plain. DEFAULT-TRANSFER-ENCODING, unless specified, is assumed to be 7bit. (USR, 2010-01-12)" (or default-type (setq default-type '("text/plain" "charset=us-ascii"))) (or default-encoding (setq default-encoding "7bit")) ;; don't let subpart parse errors make the whole parse fail. use default ;; type if the parse fails. (condition-case error-data (vm-mime-parse-entity m :default-type default-type :default-encoding default-encoding :passing-message-only passing-message-only) (vm-mime-error (vm-inform 0 "%s" (car (cdr error-data))) ;; don't sleep, no one cares about MIME syntax errors ;; (sleep-for 2) (let ((header (if (and m (not passing-message-only)) (vm-headers-of m) (vm-marker (point-min)))) (text (if (and m (not passing-message-only)) (vm-text-of m) (save-excursion (re-search-forward "^\n\\|\n\\'" nil 0) (vm-marker (point))))) (text-end (if (and m (not passing-message-only)) (vm-text-end-of m) (vm-marker (point-max))))) (vm-make-layout 'type '("error/error") 'qtype '("error/error") 'encoding (vm-determine-proper-content-transfer-encoding text text-end) ;; cram the error message into the description slot 'description (car (cdr error-data)) ;; mark as an attachment to improve the chance that the user ;; will see the description. 'disposition '("attachment") 'qdisposition '("attachment") 'header-start header 'header-end (vm-marker (1- text)) 'body-start text 'body-end text-end 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol m) ))))) ;;---------------------------------------------------------------------------- ;;; MIME layout operations ;;---------------------------------------------------------------------------- (defun vm-mime-get-xxx-parameter-internal (name param-list) "Return the parameter NAME from PARAM-LIST." (let ((match-end (1+ (length name))) (name-regexp (concat (regexp-quote name) "=")) (case-fold-search t) (done nil)) (while (and param-list (not done)) (if (and (string-match name-regexp (car param-list)) (= (match-end 0) match-end)) (setq done t) (setq param-list (cdr param-list)))) (and (car param-list) (substring (car param-list) match-end)))) (defun vm-mime-get-xxx-parameter (name param-list) "Return the parameter NAME from PARAM-LIST. If parameter value continuations was used, i.e. the parameter was split into shorter pieces, rebuild it from them." (or (vm-mime-get-xxx-parameter-internal name param-list) (let ((n 0) content p) (while (setq p (vm-mime-get-xxx-parameter-internal (format "%s*%d" name n) param-list)) (setq n (1+ n) content (concat content p))) content))) (defun vm-mime-get-parameter (layout param) (let ((string (vm-mime-get-xxx-parameter param (cdr (vm-mm-layout-type layout))))) (if string (vm-decode-mime-encoded-words-in-string string)))) (defun vm-mime-get-disposition-parameter (layout param) (let ((string (vm-mime-get-xxx-parameter param (cdr (vm-mm-layout-disposition layout))))) (if string (vm-decode-mime-encoded-words-in-string string)))) (defun vm-mime-set-xxx-parameter (param value param-list) (let ((match-end (1+ (length param))) (param-regexp (concat (regexp-quote param) "=")) (case-fold-search t) (done nil)) (while (and param-list (not done)) (if (and (string-match param-regexp (car param-list)) (= (match-end 0) match-end)) (setq done t) (setq param-list (cdr param-list)))) (and (car param-list) (setcar param-list (concat param "=" value))))) (defun vm-mime-set-parameter (layout param value) (vm-mime-set-xxx-parameter param value (cdr (vm-mm-layout-type layout)))) (defun vm-mime-set-qparameter (layout param value) (setq value (concat "\"" value "\"")) (vm-mime-set-xxx-parameter param value (cdr (vm-mm-layout-qtype layout)))) ;;---------------------------------------------------------------------------- ;;; Working with MIME layouts ;;---------------------------------------------------------------------------- (defun vm-mime-insert-mime-body (layout) "Insert in the current buffer the body of a mime part given by LAYOUT." (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-body-start layout)) (vm-mm-layout-body-start layout) (vm-mm-layout-body-end layout))) (defun vm-mime-insert-mime-headers (layout) "Insert in the current buffer the headers of a mime part given by LAYOUT." (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-header-start layout)) (vm-mm-layout-header-start layout) (vm-mm-layout-header-end layout))) (defvar buffer-display-table) (defvar standard-display-table) (defvar buffer-file-type) (defun vm-generate-new-presentation-buffer (folder-buffer name) "Generate a new Presentation buffer for FOLDER-BUFFER. NAME is a string denoting the folder name." (let ((pres-buf (vm-generate-new-multibyte-buffer (concat name " Presentation")))) (save-excursion (set-buffer pres-buf) (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (setq mode-name "VM Presentation" major-mode 'vm-presentation-mode vm-message-pointer (list nil) vm-mail-buffer folder-buffer mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) ;; Default to binary file type for DOS/NT. buffer-file-type t ;; Tell XEmacs/MULE not to mess with the text on writes. buffer-read-only t mode-line-format vm-mode-line-format) ;; scroll in place messes with scroll-up and this loses (defvar scroll-in-place) (make-local-variable 'scroll-in-place) (setq scroll-in-place nil) (when (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-binary-coding-system) t)) (vm-fsfemacs-nonmule-display-8bit-chars) (if (and vm-mutable-frame-configuration vm-frame-per-folder (vm-multiple-frames-possible-p)) (vm-set-hooks-for-frame-deletion)) (use-local-map vm-mode-map) (vm-toolbar-install-or-uninstall-toolbar) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) (run-hooks 'vm-presentation-mode-hook)) pres-buf)) (defun vm-make-presentation-copy (m) "Create a copy of the message M in the Presentation Buffer. If the message is external then the copy is made from the external source of the message." (let ((mail-buffer (current-buffer)) pres-buf mm (real-m (vm-real-message-of m)) (modified (buffer-modified-p))) (when (or (null vm-presentation-buffer-handle) (null (buffer-name vm-presentation-buffer-handle))) ;; Create a new Presentation buffer (setq pres-buf (vm-generate-new-presentation-buffer (current-buffer) (buffer-name))) (setq vm-presentation-buffer-handle pres-buf)) (setq pres-buf vm-presentation-buffer-handle) (setq vm-presentation-buffer vm-presentation-buffer-handle) (setq vm-mime-decoded nil) ;; W3 or some other external mode might set some local colors ;; in this buffer; remove them before displaying a different ;; message here. (when (fboundp 'remove-specifier) (remove-specifier (face-foreground 'default) pres-buf) (remove-specifier (face-background 'default) pres-buf)) (save-excursion (set-buffer (vm-buffer-of real-m)) (save-restriction (widen) ;; must reference this now so that headers will be in ;; their final position before the message is copied. ;; otherwise the vheader offset computed below will be ;; wrong. (vm-vheaders-of real-m) (set-buffer pres-buf) ;; do not keep undo information in presentation buffers (setq buffer-undo-list t) (widen) (let ((buffer-read-only nil) (inhibit-read-only t)) ;; We don't care about the buffer-modified-p flag of the ;; Presentation buffer. Only that of the folder matters. ;; (setq modified (buffer-modified-p)) (unwind-protect (progn (erase-buffer) (insert-buffer-substring (vm-buffer-of real-m) (vm-start-of real-m) (vm-end-of real-m))) (vm-reset-buffer-modified-p modified pres-buf))) ;; make a modifiable copy of the message struct (setq mm (copy-sequence m)) ;; also a modifiable copy of the location data ;; other data will be shared with the Folder buffer (vm-set-location-data-of mm (vm-copy (vm-location-data-of m))) (set-marker (vm-start-of mm) (point-min)) (set-marker (vm-headers-of mm) (+ (vm-start-of mm) (- (vm-headers-of real-m) (vm-start-of real-m)))) (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm) (- (vm-vheaders-of real-m) (vm-start-of real-m)))) (set-marker (vm-text-of mm) (+ (vm-start-of mm) (- (vm-text-of real-m) (vm-start-of real-m)))) (set-marker (vm-text-end-of mm) (+ (vm-start-of mm) (- (vm-text-end-of real-m) (vm-start-of real-m)))) (set-marker (vm-end-of mm) (+ (vm-start-of mm) (- (vm-end-of real-m) (vm-start-of real-m)))) ;; fetch the real message now (goto-char (point-min)) (cond ((and (vm-message-access-method-of mm) (vm-body-to-be-retrieved-of mm)) ;; Remember that this does process I/O and ;; accept-process-output, allowing concurrent threads ;; to run!!! USR, 2010-07-11 (condition-case err (vm-fetch-message (list (vm-message-access-method-of mm)) mm) (error (vm-warn 0 0 "Cannot fetch message; %s" (error-message-string err))))) ((re-search-forward "^X-VM-Storage: " (vm-text-of mm) t) (vm-fetch-message (read (current-buffer)) mm))) ;; This might be redundant. Wasn't in revision 717. ;; (vm-reset-buffer-modified-p modified (current-buffer)) ;; fixup the reference to the message (setcar vm-message-pointer mm))))) ;; This experimental code is now discarded. USR, 2011-05-07 ;; (defun vm-make-fetch-copy-if-necessary (m) ;; "Create a copy of the message M in the Fetch Buffer if it is ;; not already present. If it is an external message, the copy ;; is made from the external source of the message." ;; (unless (and vm-fetch-buffer ;; (eq (vm-real-message-sym-of m) ;; (with-current-buffer vm-fetch-buffer ;; (vm-real-message-sym-of (car vm-message-pointer))))) ;; (vm-make-fetch-copy m))) ;; (defun vm-make-fetch-copy (m) ;; "Create a copy of the message M in the Fetch Buffer. If ;; it is an external message, the copy is made from the external ;; source of the message." ;; (let ((mail-buffer (current-buffer)) ;; fetch-buf mm ;; (real-m (vm-real-message-of m)) ;; (modified (buffer-modified-p))) ;; (cond ((or (null vm-fetch-buffer) ;; (null (buffer-name vm-fetch-buffer))) ;; (setq fetch-buf (vm-generate-new-multibyte-buffer ;; (concat (buffer-name) " Fetch"))) ;; (save-excursion ;; (set-buffer fetch-buf) ;; (if (fboundp 'buffer-disable-undo) ;; (buffer-disable-undo (current-buffer)) ;; ;; obfuscation to make the v19 compiler not whine ;; ;; about obsolete functions. ;; (let ((x 'buffer-flush-undo)) ;; (funcall x (current-buffer)))) ;; (setq mode-name "VM Message" ;; major-mode 'vm-message-mode ;; vm-message-pointer (list nil) ;; vm-mail-buffer mail-buffer ;; mode-popup-menu (and vm-use-menus ;; (vm-menu-support-possible-p) ;; (vm-menu-mode-menu)) ;; ;; Default to binary file type for DOS/NT. ;; buffer-file-type t ;; ;; Tell XEmacs/MULE not to mess with the text on writes. ;; buffer-read-only t ;; mode-line-format vm-mode-line-format) ;; ;; scroll in place messes with scroll-up and this loses ;; (defvar scroll-in-place) ;; (make-local-variable 'scroll-in-place) ;; (setq scroll-in-place nil) ;; (if (fboundp 'set-buffer-file-coding-system) ;; (set-buffer-file-coding-system (vm-binary-coding-system) t)) ;; (vm-fsfemacs-nonmule-display-8bit-chars) ;; (if (and vm-mutable-frame-configuration vm-frame-per-folder ;; (vm-multiple-frames-possible-p)) ;; (vm-set-hooks-for-frame-deletion)) ;; (use-local-map vm-mode-map) ;; (vm-toolbar-install-or-uninstall-toolbar) ;; (when (vm-menu-support-possible-p) ;; (vm-menu-install-menus)) ;; (run-hooks 'vm-message-mode-hook)) ;; (setq vm-fetch-buffer fetch-buf))) ;; (setq fetch-buf vm-fetch-buffer) ;; (setq vm-mime-decoded nil) ;; ;; W3 or some other external mode might set some local colors ;; ;; in this buffer; remove them before displaying a different ;; ;; message here. ;; (if (fboundp 'remove-specifier) ;; (progn ;; (remove-specifier (face-foreground 'default) fetch-buf) ;; (remove-specifier (face-background 'default) fetch-buf))) ;; (save-excursion ;; (set-buffer (vm-buffer-of real-m)) ;; (save-restriction ;; (widen) ;; ;; must reference this now so that headers will be in ;; ;; their final position before the message is copied. ;; ;; otherwise the vheader offset computed below will be ;; ;; wrong. ;; (vm-vheaders-of real-m) ;; (set-buffer fetch-buf) ;; ;; do not keep undo information in message buffers ;; (setq buffer-undo-list t) ;; (widen) ;; (let ((buffer-read-only nil) ;; (inhibit-read-only t)) ;; ;; (setq modified (buffer-modified-p)) ; why this? USR, 2011-03-18 ;; (unwind-protect ;; (progn ;; (erase-buffer) ;; (insert-buffer-substring (vm-buffer-of real-m) ;; (vm-start-of real-m) ;; (vm-end-of real-m))) ;; (vm-restore-buffer-modified-p modified fetch-buf))) ;; (setq mm (copy-sequence m)) ;; (vm-set-location-data-of mm (vm-copy (vm-location-data-of m))) ;; (vm-set-softdata-of mm (vm-copy (vm-softdata-of m))) ;; (vm-set-message-id-number-of mm 1) ;; (vm-set-buffer-of mm (current-buffer)) ;; (set-marker (vm-start-of mm) (point-min)) ;; (set-marker (vm-headers-of mm) (+ (vm-start-of mm) ;; (- (vm-headers-of real-m) ;; (vm-start-of real-m)))) ;; (set-marker (vm-vheaders-of mm) (+ (vm-start-of mm) ;; (- (vm-vheaders-of real-m) ;; (vm-start-of real-m)))) ;; (set-marker (vm-text-of mm) (+ (vm-start-of mm) ;; (- (vm-text-of real-m) ;; (vm-start-of real-m)))) ;; (set-marker (vm-text-end-of mm) (+ (vm-start-of mm) ;; (- (vm-text-end-of real-m) ;; (vm-start-of real-m)))) ;; (set-marker (vm-end-of mm) (+ (vm-start-of mm) ;; (- (vm-end-of real-m) ;; (vm-start-of real-m)))) ;; (vm-set-mime-layout-of mm (vm-mime-parse-entity-safe)) ;; ;; fetch the real message now ;; (goto-char (point-min)) ;; (cond ((and (vm-message-access-method-of mm) ;; (vm-body-to-be-retrieved-of mm)) ;; ;; Remember that this does process I/O and ;; ;; accept-process-output, and hence allow concurrent ;; ;; threads to run!!! USR, 2010-07-11 ;; (condition-case err ;; (vm-fetch-message ;; (list (vm-message-access-method-of mm)) mm) ;; (error ;; (vm-warn 0 2 "Cannot fetch; %s" (error-message-string err))))) ;; ((re-search-forward "^X-VM-Storage: " (vm-text-of mm) t) ;; (vm-fetch-message (read (current-buffer)) mm))) ;; (vm-reset-buffer-modified-p modified fetch-buf) ;; ;; fixup the reference to the message ;; (setcar vm-message-pointer mm))))) (defun vm-fetch-message (storage mm) "Fetch the real message based on the \"^X-VM-Storage:\" header. This allows for storing only the headers required for the summary and maybe a small preview of the message, or keywords for search, etc. Only when displaying it the actual message is fetched based on the storage handler. The information about the actual message is stored in the \"^X-VM-Storage:\" header and should be a lisp list of the following format. \(HANDLER ARGS...\) HANDLER should correspond to a `vm-fetch-HANDLER-message' function, e.g., the handler `file' corresponds to the function `vm-fetch-file-message' which gets two arguments, the message descriptor and the filename containing the message, and inserts the message body from the file into the current buffer. For example, 'X-VM-Storage: (file \"message-11\")' will fetch the actual message from the file \"message-11\"." (goto-char (match-end 0)) (save-excursion (set-buffer (marker-buffer (vm-text-of mm))) (let ((buffer-read-only nil) (inhibit-read-only t) (buffer-undo-list t) (fetch-result nil)) (goto-char (vm-text-of mm)) (delete-region (point) (point-max)) ;; Remember that this might do process I/O and accept-process-output, ;; allowing other threads to run!!! USR, 2010-07-11 (vm-inform 6 "Fetching message from external source...") (setq fetch-result (apply (intern (format "vm-fetch-%s-message" (car storage))) mm (cdr storage))) (when fetch-result (vm-inform 6 "Fetching message from external source... done") ;; delete the new headers (delete-region (vm-text-of mm) (or (re-search-forward "\n\n" (point-max) t) (point-max))) ;; fix markers now (set-marker (vm-text-end-of mm) (point-max)) (set-marker (vm-end-of mm) (point-max)) ;; now care for the layout of the message, old layouts are ;; invalid as the presentation buffer may have been used for ;; other messages in the meantime and the marker got invalid ;; by this. (vm-set-mime-layout-of mm (vm-mime-parse-entity-safe)) )))) (defun vm-fetch-file-message (m filename) "Insert the message with message descriptor MM stored in the given FILENAME." (insert-file-contents filename nil nil nil t) t) (fset 'vm-fetch-mode 'vm-mode) (put 'vm-fetch-mode 'mode-class 'special) (fset 'vm-presentation-mode 'vm-mode) (put 'vm-presentation-mode 'mode-class 'special) (defvar buffer-file-coding-system) (defun vm-determine-proper-charset (beg end) "Work out what MIME character set to use for sending a message. Uses `us-ascii' if the message is entirely ASCII compatible. If MULE is not available, and the message contains contains non-ASCII characters, consults the variable `vm-mime-8bit-composition-charset' or uses `iso-8859-1.' if that is nil. Under MULE, `vm-coding-system-priorities' is searched, in order, for a coding system that will encode all the characters in the message. If none is found, consults the variable `vm-mime-8bit-composition-charset' or uses `iso-2022-jp', which will preserve information for all the character sets of which Emacs is aware - at the expense of being incompatible with the recipient's software, if that recipient is outside of East Asia." (save-excursion (save-restriction (narrow-to-region beg end) (if (or vm-xemacs-mule-p (and vm-fsfemacs-mule-p enable-multibyte-characters)) ;; Okay, we're on a MULE build. (if (and vm-fsfemacs-mule-p (fboundp 'check-coding-systems-region)) ;; check-coding-systems-region appeared in GNU Emacs 23. (let* ((preapproved (vm-get-coding-system-priorities)) (ucs-list (vm-get-mime-ucs-list)) (cant-encode (check-coding-systems-region (point-min) (point-max) (cons 'us-ascii preapproved)))) (if (not (assq 'us-ascii cant-encode)) ;; If there are only ASCII chars, we're done. "us-ascii" (while (and preapproved (assq (car preapproved) cant-encode) (not (memq (car preapproved) ucs-list))) (setq preapproved (cdr preapproved))) (if preapproved (cadr (assq (car preapproved) vm-mime-mule-coding-to-charset-alist)) ;; None of the entries in vm-coding-system-priorities ;; can be used. This can only happen if no universal ;; coding system is included. Fall back to utf-8. "utf-8"))) (let ((charsets (delq 'ascii (vm-charsets-in-region (point-min) (point-max))))) (cond ;; No non-ASCII chars? Right, that makes it easy for us. ((null charsets) "us-ascii") ;; Check whether the buffer can be encoded using one of the ;; vm-coding-system-priorities coding systems. ((catch 'done ;; We can't really do this intelligently unless latin-unity ;; is available. (if (featurep 'latin-unity) (let ((csetzero charsets) ;; Check what latin character sets are in the ;; buffer. (csets (latin-unity-representations-feasible-region beg end)) (psets (latin-unity-representations-present-region beg end)) (systems (vm-get-coding-system-priorities))) ;; If one of the character sets is outside of latin ;; unity's remit, check for a universal character ;; set in vm-coding-system-priorities, and pass back ;; the first one. ;; ;; Otherwise, there's no remapping that latin unity ;; can do for us, and we should default to something ;; iso-2022 based. (Since we're not defaulting to ;; Unicode, at the moment.) (while csetzero (if (not (memq (car csetzero) latin-unity-character-sets)) (let ((ucs-list (vm-get-mime-ucs-list)) (preapproved (vm-get-coding-system-priorities))) (while preapproved (if (memq (car preapproved) ucs-list) (throw 'done (car (cdr (assq (car preapproved) vm-mime-mule-coding-to-charset-alist))))) (setq preapproved (cdr preapproved))) ;; Nothing universal in the preapproved list. (throw 'done nil))) (setq csetzero (cdr csetzero))) ;; Okay, we're able to remap using latin-unity. Do so. (while systems (let ((sys (latin-unity-massage-name (car systems) 'buffer-default))) (when (latin-unity-maybe-remap (point-min) (point-max) sys csets psets t) (throw 'done (second (assq sys vm-mime-mule-coding-to-charset-alist))))) (setq systems (cdr systems))) (throw 'done nil)) ;; Right, latin-unity isn't available. If there's only ;; one non-ASCII character set in the region, and the ;; corresponding coding system is on the preapproved ;; list before the first universal character set, pass ;; it back. Otherwise, if a universal character set is ;; on the preapproved list, pass the first one of them ;; back. Otherwise, pass back nil and use the ;; "iso-2022-jp" entry below. (let ((csetzero charsets) (preapproved (vm-get-coding-system-priorities)) (ucs-list (vm-get-mime-ucs-list))) (if (null (cdr csetzero)) (while preapproved ;; If we encounter a universal character set on ;; the preapproved list, pass it back. (if (memq (car preapproved) ucs-list) (throw 'done (second (assq (car preapproved) vm-mime-mule-coding-to-charset-alist)))) ;; The preapproved entry isn't universal. Check if ;; it's related to the single non-ASCII MULE ;; charset in the buffer (that is, if the ;; conceptually unordered MULE list of characters ;; is based on a corresponding ISO character set, ;; and thus the ordered ISO character set can ;; encode all the characters in the MIME charset.) ;; ;; The string equivalence test is used because we ;; don't have another mapping that is useful ;; here. Nnngh. (if (string= (car (cdr (assoc (car csetzero) vm-mime-mule-charset-to-charset-alist))) (car (cdr (assoc (car preapproved) vm-mime-mule-coding-to-charset-alist)))) (throw 'done (car (cdr (assoc (car csetzero) vm-mime-mule-charset-to-charset-alist))))) (setq preapproved (cdr preapproved))) ;; Okay, there's more than one MULE character set in ;; the buffer. Check for a universal entry in the ;; preapproved list; if it exists pass it back, ;; otherwise fall through to the iso-2022-jp below, ;; because nothing on the preapproved list is ;; appropriate. (while preapproved ;; If we encounter a universal character set on ;; the preapproved list, pass it back. (when (memq (car preapproved) ucs-list) (throw 'done (second (assq (car preapproved) vm-mime-mule-coding-to-charset-alist)))) (setq preapproved (cdr preapproved))))) (throw 'done nil)))) ;; Couldn't do any magic with vm-coding-system-priorities. Pass ;; back a Japanese iso-2022 MIME character set. (t "iso-2022-jp") ;; Undo the change made in revisin 493 ;; (t (or vm-mime-8bit-composition-charset "iso-2022-jp")) ;; -- ))) ;; If we're non-MULE and there are eight bit characters, use a ;; sensible default. (goto-char (point-min)) (if (re-search-forward "[^\000-\177]" nil t) (or vm-mime-8bit-composition-charset "iso-8859-1") ;; We're non-MULE and there are purely 7bit characters in the ;; region. Return vm-mime-7bit-c-c. vm-mime-7bit-composition-charset))))) (defun vm-determine-proper-content-transfer-encoding (beg end) (save-excursion (save-restriction (narrow-to-region beg end) (catch 'done (goto-char (point-min)) (and (re-search-forward "[\000\015]" nil t) (throw 'done "binary")) (let ((toolong nil) bol) (goto-char (point-min)) (setq bol (point)) (while (and (not (eobp)) (not toolong)) (forward-line) (setq toolong (> (- (point) bol) 998) bol (point))) (and toolong (throw 'done "binary"))) (goto-char (point-min)) (and (re-search-forward "[^\000-\177]" nil t) (throw 'done "8bit")) "7bit")))) ;;---------------------------------------------------------------------------- ;;; Predicates on MIME types and layouts ;;---------------------------------------------------------------------------- (defun vm-mime-types-match (type type/subtype) (let ((case-fold-search t)) (cond ((null type/subtype) nil) ((string-match "/" type) (if (and (string-match (regexp-quote type) type/subtype) (equal 0 (match-beginning 0)) (equal (length type/subtype) (match-end 0))) t nil )) ((and (string-match (regexp-quote type) type/subtype) (equal 0 (match-beginning 0)) (equal (save-match-data (string-match "/" type/subtype (match-end 0))) (match-end 0))))))) (defvar native-sound-only-on-console) (defun vm-mime-text/html-handler () (if (eq vm-mime-text/html-handler 'auto-select) (setq vm-mime-text/html-handler (cond ((locate-library "w3m") 'emacs-w3m) ((locate-library "w3") 'w3) ((executable-find "w3m") 'w3m) ((executable-find "lynx") 'lynx))) vm-mime-text/html-handler)) (defun vm-mime-can-display-internal (layout &optional deep) (let ((type (car (vm-mm-layout-type layout)))) (cond ((vm-mime-types-match "image/jpeg" type) (and (vm-image-type-available-p 'jpeg) (vm-images-possible-here-p))) ((vm-mime-types-match "image/gif" type) (and (vm-image-type-available-p 'gif) (vm-images-possible-here-p))) ((vm-mime-types-match "image/png" type) (and (vm-image-type-available-p 'png) (vm-images-possible-here-p))) ((vm-mime-types-match "image/tiff" type) (and (vm-image-type-available-p 'tiff) (vm-images-possible-here-p))) ((vm-mime-types-match "image/xpm" type) (and (vm-image-type-available-p 'xpm) (vm-images-possible-here-p))) ((vm-mime-types-match "image/pbm" type) (and (vm-image-type-available-p 'pbm) (vm-images-possible-here-p))) ((vm-mime-types-match "image/xbm" type) (and (vm-image-type-available-p 'xbm) (vm-images-possible-here-p))) ((vm-mime-types-match "audio/basic" type) (and vm-xemacs-p (or (featurep 'native-sound) (featurep 'nas-sound)) (or (device-sound-enabled-p) (and (featurep 'native-sound) (not native-sound-only-on-console) (memq (vm-device-type) '(x gtk)))))) ((vm-mime-types-match "multipart" type) t) ((vm-mime-types-match "message/external-body" type) (or (not deep) (vm-mime-can-display-internal (car (vm-mm-layout-parts layout)) t))) ((vm-mime-types-match "message" type) t) ((vm-mime-types-match "text/html" type) ;; Allow vm-mime-text/html-handler to decide if text/html parts are displayable: (and (vm-mime-text/html-handler) (let ((charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (vm-mime-charset-internally-displayable-p charset)))) ((vm-mime-types-match "text" type) (let ((charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (or (vm-mime-charset-internally-displayable-p charset) (vm-mime-can-convert-charset charset)))) (t nil)))) (defun vm-mime-can-convert (type) "If given mime TYPE is convertible to some other type, return a triple (source-type target-type command). Otherwise, return nil." (or (vm-mime-can-convert-0 type vm-mime-type-converter-alist) (vm-mime-can-convert-0 type vm-mime-image-type-converter-alist))) (defun vm-mime-can-convert-0 (type alist) (let ( ;; fake layout. make it the wrong length so an error will ;; be signaled if vm-mime-can-display-internal ever asks ;; for one of the other fields (fake-layout (make-vector 1 (list nil))) best second-best) (while (and alist (not best)) (cond ((and (vm-mime-types-match (car (car alist)) type) (not (vm-mime-types-match (nth 1 (car alist)) type))) (cond ((and (not best) (progn (setcar (aref fake-layout 0) (nth 1 (car alist))) (vm-mime-can-display-internal fake-layout))) (setq best (car alist))) ((and (not second-best) (vm-mime-find-external-viewer (nth 1 (car alist)))) (setq second-best (car alist)))))) (setq alist (cdr alist))) (or best second-best))) (defun vm-mime-convert-undisplayable-layout (layout) (catch 'done (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout)))) ex work-buffer) (vm-inform 6 "Converting %s to %s..." (car (vm-mm-layout-type layout)) (nth 1 ooo)) (setq work-buffer (vm-make-work-buffer " *mime object*")) (vm-register-message-garbage 'kill-buffer work-buffer) (with-current-buffer work-buffer ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) ;; It is annoying to use cat for conversion of a mime type which ;; is just plain text. Therefore we do not call it ... (setq ex 0) (if (= (length ooo) 2) (if (search-forward-regexp "\n\n" (point-max) t) (delete-region (point-min) (match-beginning 0))) ;; it is arguable that if the type to be converted is text, ;; we should convert from the object's native encoding to ;; the default encoding. However, converting from text is ;; likely to be rare, so we'll have that argument another ;; time. JCB, 2011-02-04 (let ((coding-system-for-write (vm-binary-coding-system)) (coding-system-for-read (vm-binary-coding-system))) (setq ex (call-process-region (point-min) (point-max) shell-file-name t t nil shell-command-switch (nth 2 ooo))))) (unless (eq ex 0) (switch-to-buffer work-buffer) (vm-warn 0 5 "Conversion from %s to %s failed (exit code %s)" (car (vm-mm-layout-type layout)) (nth 1 ooo) ex) (throw 'done nil)) (goto-char (point-min)) ;; if the to-type is text, then we will assume that the conversion ;; process outputs text in the default encoding. ;; Really we ought to look at process-coding-system-alist etc, ;; but I suspect that this is rarely used, and will become even ;; less used as utf-8 becomes universal. JCB, 2011-02-04 ;; But we will let detect-coding-region do as much work as it ;; can. USR, 2011-02-11 (let* ((charset (vm-mime-find-charset-for-binary-buffer))) (insert "Content-Type: " (vm-mime-type-with-params (nth 1 ooo) (and (vm-mime-types-match "text" (nth 1 ooo)) (list (concat "charset=" charset)))) "\n") (insert "Content-Transfer-Encoding: binary\n\n") (set-buffer-modified-p nil) (vm-inform 6 "Converting %s to %s... done" (car (vm-mm-layout-type layout)) (nth 1 ooo)) ;; irritatingly, we need to set the coding system here as well (vm-make-layout 'type (append (list (nth 1 ooo)) (append (cdr (vm-mm-layout-type layout)) (if (vm-mime-types-match "text" (nth 1 ooo)) (list (concat "charset=" charset))))) 'qtype (append (list (nth 1 ooo)) (cdr (vm-mm-layout-type layout))) 'encoding "binary" 'id (vm-mm-layout-id layout) 'description (vm-mm-layout-description layout) 'disposition (vm-mm-layout-disposition layout) 'qdisposition (vm-mm-layout-qdisposition layout) 'header-start (vm-marker (point-min)) 'header-end (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'parts nil 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol (vm-mm-layout-message layout)) 'display-error nil 'layout-is-converted t )))))) (defun vm-mime-find-charset-for-binary-buffer () "Finds an appropriate MIME character set for the current buffer, assuming that it is text." (let ((coding-systems (detect-coding-region (point-min) (point-max))) (coding-system nil) (n nil)) ;; XEmacs returns a single coding-system sometimes (unless (listp coding-systems) (setq coding-systems (list coding-systems))) ;; Skip over the uninformative coding-systems (setq n (vm-find coding-systems (function (lambda (coding) (and coding (not (memq (vm-coding-system-name-no-eol coding) '(raw-text no-conversion)))))))) (when n (setq coding-system (nth n coding-systems))) ;; If no informative coding-system detected then use the default ;; buffer-file-coding-system (when (or (null coding-system) (eq (vm-coding-system-name-no-eol coding-system) 'undecided)) (setq coding-system buffer-file-coding-system)) (or (cadr (assq (vm-coding-system-name-no-eol coding-system) vm-mime-mule-coding-to-charset-alist)) "us-ascii"))) (defun vm-mime-can-convert-charset (charset) (vm-mime-can-convert-charset-0 charset vm-mime-charset-converter-alist)) (defun vm-mime-can-convert-charset-0 (charset alist) (let ((done nil)) (while (and alist (not done)) (cond ((and (vm-string-equal-ignore-case (car (car alist)) charset) (vm-mime-charset-internally-displayable-p (nth 1 (car alist)))) (setq done t)) (t (setq alist (cdr alist))))) (and alist (car alist)))) ;; This function from VM 7.19 is not being used anywhere. However, ;; see vm-mime-charset-convert-region for similar functionality. ;; USR, 2011-02-11 (defun vm-mime-convert-undisplayable-charset (layout) (let ((charset (vm-mime-get-parameter layout "charset")) ooo work-buffer) (setq ooo (vm-mime-can-convert-charset charset)) (vm-inform 6 "Converting charset %s to %s..." charset (nth 1 ooo)) (save-excursion (setq work-buffer (vm-make-work-buffer " *mime object*")) (vm-register-message-garbage 'kill-buffer work-buffer) (set-buffer work-buffer) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (call-process-region (point-min) (point-max) shell-file-name t t nil shell-command-switch (nth 2 ooo)) (setq layout (vm-make-layout 'type (copy-sequence (vm-mm-layout-type layout)) 'qtype (copy-sequence (vm-mm-layout-type layout)) 'encoding "binary" 'id (vm-mm-layout-id layout) 'description (vm-mm-layout-description layout) 'disposition (vm-mm-layout-disposition layout) 'qdisposition (vm-mm-layout-qdisposition layout) 'header-start (vm-marker (point-min)) 'header-body (vm-marker (1- (point))) 'body-start (vm-marker (point)) 'body-end (vm-marker (point-max)) 'cache (vm-mime-make-cache-symbol) 'message-symbol (vm-mime-make-message-symbol (vm-mm-layout-message layout)) 'layout-is-converted t 'onconverted-layout layout )) (vm-mime-set-parameter layout "charset" (nth 1 ooo)) (vm-mime-set-qparameter layout "charset" (nth 1 ooo)) (goto-char (point-min)) (let ((vm-mime-avoid-folding-content-type t)) ; maybe no need (insert-before-markers "Content-Type: " (vm-mime-type-with-params (car (vm-mm-layout-type layout)) (cdr (vm-mm-layout-type layout))) "\n")) (insert-before-markers "Content-Transfer-Encoding: binary\n\n") (set-buffer-modified-p nil) (vm-inform 6 "Converting charset %s to %s... done" charset (nth 1 ooo)) layout))) (defun vm-mime-charset-convert-region (charset b-start b-end) (let ((b (current-buffer)) start end oldsize work-buffer ooo ex) (setq ooo (vm-mime-can-convert-charset charset)) (setq work-buffer (vm-make-work-buffer " *mime object*")) (unwind-protect (with-current-buffer work-buffer (setq oldsize (- b-end b-start)) (set-buffer work-buffer) (insert-buffer-substring b b-start b-end) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (let ((coding-system-for-write (vm-binary-coding-system)) (coding-system-for-read (vm-binary-coding-system))) (setq ex (call-process-region (point-min) (point-max) shell-file-name t t nil shell-command-switch (nth 2 ooo)))) (unless (eq ex 0) (vm-warn 0 1 "Conversion from %s to %s signalled exit code %s" (nth 0 ooo) (nth 1 ooo) ex)) ;; This cannot possibly safe. USR, 2011-02-11 ;; (if vm-fsfemacs-mule-p ;; (set-buffer-multibyte t)) (setq start (point-min) end (point-max)) (with-current-buffer b (save-excursion (goto-char b-start) (insert-buffer-substring work-buffer start end) (delete-region (point) (+ (point) oldsize)))) (nth 1 ooo)) ;; unwind-protection (when work-buffer (kill-buffer work-buffer))))) (defun* vm-mime-should-display-button (layout &key (honor-content-disposition t)) "Checks whether MIME object with LAYOUT should be displayed as a button. Optional keyword argument HONOR-CONTENT-DISPOSITION says whether the Content-Disposition header of the MIME object should be honored (default t). The global setting of `vm-mime-honor-content-disposition' also has this effect." ;; Karnaugh map analysis shows that ;; - attachment disposition objects should be buttons ;; - all auto-displayed objects should not be buttons ;; - inline objects should be displayed if honor = t or ;; honor = internal-only and the object is internal-displayable ;; - all other cases should be buttons (let ((type (car (vm-mm-layout-type layout))) (disposition (car (vm-mm-layout-disposition layout)))) (setq disposition (and disposition (downcase disposition))) (setq honor-content-disposition (and honor-content-disposition vm-mime-honor-content-disposition)) (cond ((vm-mime-types-match "multipart" type) nil) ((equal disposition "attachment") t) ((eq disposition "inline") (cond ((eq honor-content-disposition 'internal-only) (not (or (vm-mime-should-auto-display layout) (vm-mime-should-display-internal layout)))) ((eq honor-content-disposition t) nil) (t (not (vm-mime-should-auto-display layout))))) (t (not (vm-mime-should-auto-display layout)))))) (defun vm-mime-should-auto-display (layout) (let ((type (car (vm-mm-layout-type layout)))) (and (or (eq vm-mime-auto-displayed-content-types t) (vm-find (cons "multipart" vm-mime-auto-displayed-content-types) (lambda (i) (vm-mime-types-match i type)))) (not (vm-find vm-mime-auto-displayed-content-type-exceptions (lambda (i) (vm-mime-types-match i type))))))) (defun vm-mime-should-display-internal (layout) (let ((type (car (vm-mm-layout-type layout)))) (if (or (eq vm-mime-internal-content-types t) (vm-find (cons "multipart" vm-mime-internal-content-types) (lambda (i) (vm-mime-types-match i type)))) (not (vm-find vm-mime-internal-content-type-exceptions (lambda (i) (vm-mime-types-match i type)))) nil))) (defun vm-mime-find-external-viewer (type) (catch 'done (let ((list vm-mime-external-content-type-exceptions) (matched nil)) (while list (if (vm-mime-types-match (car list) type) (throw 'done nil) (setq list (cdr list)))) (setq list vm-mime-external-content-types-alist) (while (and list (not matched)) (if (and (vm-mime-types-match (car (car list)) type) (cdr (car list))) (setq matched (cdr (car list))) (setq list (cdr list)))) matched ))) (fset 'vm-mime-can-display-external 'vm-mime-find-external-viewer) (defun vm-mime-delete-button-maybe (extent) (let ((buffer-read-only)) ;; if displayed MIME object should replace the button ;; remove the button now. (cond ((vm-extent-property extent 'vm-mime-disposable) (delete-region (vm-extent-start-position extent) (vm-extent-end-position extent)) (vm-detach-extent extent))))) ;;------------------------------------------------------------------------------ ;;; MIME decoding ;;------------------------------------------------------------------------------ ;;;###autoload (defun vm-decode-mime-message (&optional state) "Decode the MIME objects in the current message. The first time this command is run on a message, decoding is done. The second time, buttons for all the objects are displayed instead. The third time, the raw, undecoded data is displayed. The optional argument STATE can specify which decode state to display: 'decoded, 'button or 'undecoded. If decoding, the decoded objects might be displayed immediately, or buttons might be displayed that you need to activate to view the object. See the documentation for the variables vm-mime-auto-displayed-content-types vm-mime-auto-displayed-content-type-exceptions vm-mime-internal-content-types vm-mime-internal-content-type-exceptions vm-mime-external-content-types-alist to see how to control whether you see buttons or objects. If the variable vm-mime-display-function is set, then its value is called as a function with no arguments, and none of the actions mentioned in the preceding paragraphs are taken. At the time of the call, the current buffer will be the presentation buffer for the folder and a copy of the current message will be in the buffer. The function is expected to make the message `MIME presentable' to the user in whatever manner it sees fit." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless (or vm-display-using-mime vm-mime-display-function) (error "MIME display disabled, set vm-display-using-mime non-nil to enable.")) (if vm-mime-display-function (progn (vm-make-presentation-copy (car vm-message-pointer)) (set-buffer vm-presentation-buffer) (funcall vm-mime-display-function) ;; We are done here ) (when (null state) (cond ((null vm-mime-decoded) (setq state 'decoded)) ((eq vm-mime-decoded 'decoded) (setq state 'buttons)) ((eq vm-mime-decoded 'buttons) (setq state 'undecoded)))) (if vm-mime-decoded (cond ((eq state 'buttons) (let ((vm-preview-lines nil) (vm-auto-decode-mime-messages t) (vm-mime-honor-content-disposition nil) (vm-mime-auto-displayed-content-types '("multipart")) (vm-mime-auto-displayed-content-type-exceptions nil)) (setq vm-mime-decoded nil) (intern (buffer-name) vm-buffers-needing-display-update) (save-excursion (vm-present-current-message)) (setq vm-mime-decoded 'buttons))) ((eq state 'undecoded) (let ((vm-preview-lines nil) (vm-auto-decode-mime-messages nil)) (intern (buffer-name) vm-buffers-needing-display-update) (vm-present-current-message)))) (let ((layout (vm-mm-layout (car vm-message-pointer))) (m (car vm-message-pointer))) (vm-emit-mime-decoding-message "Decoding MIME message...") (when (stringp layout) (error "Invalid MIME message: %s" layout)) (when (vm-mime-plain-message-p m) (error "Message needs no decoding.")) (if (not vm-presentation-buffer) ;; maybe user killed it - make a new one (progn (vm-make-presentation-copy (car vm-message-pointer)) (vm-expose-hidden-headers)) (set-buffer vm-presentation-buffer)) ;; Are we now in the Presentation buffer? Why? USR, 2010-05-08 (when (and (vm-interactive-p) (eq vm-system-state 'previewing)) (let ((vm-display-using-mime nil)) (vm-show-current-message))) (setq m (car vm-message-pointer)) (vm-save-restriction (widen) (goto-char (vm-text-of m)) (let ((buffer-read-only nil) (modified (buffer-modified-p))) (unwind-protect (save-excursion (unless (eq (vm-mm-encoded-header m) 'none) (vm-decode-mime-message-headers m)) (when (vectorp layout) (vm-decode-mime-layout layout) ;; Delete the original presentation copy (delete-region (point) (point-max))) (vm-energize-urls) (vm-highlight-headers-maybe) (vm-energize-headers-and-xfaces)) (set-buffer-modified-p modified)))) (save-excursion (set-buffer vm-mail-buffer) (setq vm-mime-decoded 'decoded)) (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) (vm-emit-mime-decoding-message "Decoding MIME message... done")))) (vm-display nil nil '(vm-decode-mime-message) '(vm-decode-mime-message reading-message))) (defun vm-mime-get-disposition-filename (layout) (let ((filename nil) (case-fold-search t)) (setq filename (or (vm-mime-get-disposition-parameter layout "filename") (vm-mime-get-disposition-parameter layout "name"))) (when (not filename) (setq filename (or (vm-mime-get-disposition-parameter layout "filename*") (vm-mime-get-disposition-parameter layout "name*"))) ;; decode encoded filenames (when (and filename (string-match "^\\([^']+\\)'\\([^']*\\)'\\(.*%[0-9A-F][0-9A-F].*\\)$" filename)) ;; transform it to something we are already able to decode (let ((charset (match-string 1 filename)) (f (match-string 3 filename))) (setq f (vm-replace-in-string f "%\\([0-9A-F][0-9A-F]\\)" "=\\1")) (setq filename (concat "=?" charset "?Q?" f "?=")) (setq filename (vm-decode-mime-encoded-words-in-string filename))))) filename)) (defun vm-mime-rewrite-with-inferred-type (layout type2) (vm-set-mm-layout-type layout (list type2)) (vm-set-mm-layout-qtype layout (list (concat "\"" type2 "\"")))) (defun vm-decode-mime-layout (layout &optional dont-honor-c-d) "Decode the MIME part in the current buffer using LAYOUT. If DONT-HONOR-C-D non-Nil, then don't honor the Content-Disposition declarations in the attachments and make a decision independently. LAYOUT can be a mime layout vector. It can also be a button extent in the current buffer, in which case the 'vm-mime-layout property of the overlay will be extracted. The button may be deleted. Returns t if the display was successful. Not clear what happens if it is not successful. USR, 2011-03-25" (let ((modified (buffer-modified-p)) handler new-layout file type inf-type type-no-subtype inf-type-no-subtype (extent nil)) (unless (vectorp layout) ;; handle a button extent (setq extent layout layout (vm-extent-property extent 'vm-mime-layout)) (goto-char (vm-extent-start-position extent)) ;; if the button is for external-body, use the external-body (setq type (downcase (car (vm-mm-layout-type layout)))) (when (vm-mime-types-match "message/external-body" type) (setq layout (car (vm-mm-layout-parts layout))))) (unwind-protect (progn (setq type (downcase (car (vm-mm-layout-type layout))) type-no-subtype (car (vm-parse type "\\([^/]+\\)")) file (vm-mime-get-disposition-filename layout) inf-type (when (and vm-infer-mime-types file) (vm-mime-default-type-from-filename file))) (when inf-type (setq inf-type (downcase inf-type) inf-type-no-subtype (car (vm-parse inf-type "\\([^/]+\\)")))) (cond ((and vm-infer-mime-types inf-type (or (and vm-infer-mime-types-for-text (vm-mime-types-match "text/plain" type)) (vm-mime-types-match "application/octet-stream" type)) (not (vm-mime-types-match type inf-type))) (vm-mime-rewrite-with-inferred-type layout inf-type) (setq type (downcase (car (vm-mm-layout-type layout))) type-no-subtype (car (vm-parse type "\\([^/]+\\)"))))) (cond ((and (vm-mime-should-display-button layout :honor-content-disposition (not dont-honor-c-d)) ;; original conditional-cases changed to fboundp ;; checks. USR, 2011-03-25 (or (fboundp (setq handler (vm-mime-handler "display-button" type))) (fboundp (setq handler (vm-mime-handler "display-button" type-no-subtype))) (setq handler 'vm-mime-display-button-application)) (funcall handler layout)) ;; if the handler returns t, we are done ) ((and vm-infer-mime-types inf-type (vm-mime-should-display-button layout :honor-content-disposition (not dont-honor-c-d)) (or (fboundp (setq handler (vm-mime-handler "display-button" inf-type))) (fboundp (setq handler (vm-mime-handler "display-button" inf-type-no-subtype)))) (funcall handler layout)) ;; if the handler returns t, overwrite the layout type (vm-mime-rewrite-with-inferred-type layout inf-type)) ((and (vm-mime-should-display-internal layout) (or (fboundp (setq handler (vm-mime-handler "display-internal" type))) (fboundp (setq handler (vm-mime-handler "display-internal" type-no-subtype)))) (funcall handler layout)) ;; if the handler returns t, we are done ) ((and vm-infer-mime-types inf-type (vm-mime-should-display-internal layout) (or (fboundp (setq handler (vm-mime-handler "display-internal" inf-type))) (fboundp (setq handler (vm-mime-handler "display-internal" inf-type-no-subtype)))) (funcall handler layout)) ;; if the handler returns t, overwrite the layout type (vm-mime-rewrite-with-inferred-type layout inf-type)) ((vm-mime-types-match "multipart" type) (if (fboundp (setq handler (vm-mime-handler "display-internal" type))) (funcall handler layout) (vm-mime-display-internal-multipart/mixed layout)) ) ((and (vm-mime-find-external-viewer type) (vm-mime-display-external-generic layout)) ;; external viewer worked. the button should go away. (when extent (vm-set-extent-property extent 'vm-mime-disposable nil)) ) ((and (not (vm-mm-layout-is-converted layout)) (vm-mime-can-convert type) (setq new-layout (vm-mime-convert-undisplayable-layout layout))) ;; conversion worked. the button should go away. (when extent (vm-set-extent-property extent 'vm-mime-disposable t)) (vm-decode-mime-layout new-layout) ) (t (when extent (vm-mime-rewrite-failed-button extent (or (vm-mm-layout-display-error layout) "no external viewer defined for type"))) (cond ((vm-mime-types-match "message/external-body" type) (if (null extent) (vm-mime-display-button-xxxx layout t) (setq extent nil))) ((vm-mime-types-match "application/octet-stream" type) (vm-mime-display-internal-application/octet-stream (or extent layout))) ;; if everything else fails, just display a button (t (vm-set-mm-layout-display-error layout "Unknown MIME type") (vm-mime-display-button-application layout)) ) )) (when extent (vm-mime-delete-button-maybe extent))) ;; unwind-protection (set-buffer-modified-p modified))) t ) (defun vm-mime-display-button-text (layout) (vm-mime-display-button-xxxx layout t)) (defun vm-mime-display-internal-text (layout) (vm-mime-display-internal-text/plain layout)) (defun vm-mime-cid-retrieve (url message) "Insert a content pointed by URL if it has the cid: scheme." (if (string-match "\\`cid:" url) (setq url (concat "<" (substring url (match-end 0)) ">")) (error "%S is not a cid url" url)) (let ((part-list (vm-mm-layout-parts (vm-mm-layout message))) part) (while part-list (setq part (car part-list)) (if (vm-mime-composite-type-p (car (vm-mm-layout-type part))) (setq part-list (nconc (copy-sequence (vm-mm-layout-parts part)) (cdr part-list)))) (setq part-list (cdr part-list)) (if (not (equal url (vm-mm-layout-id part))) (setq part nil) (vm-mime-insert-mime-body part) (setq part-list nil))) (unless part (vm-inform 5 "No data for cid %S" url)) part)) (defun vm-mime-display-internal-w3m-text/html (start end layout) (let ((charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (shell-command-on-region start (1- end) (format "w3m -dump -T text/html -I %s -O %s" charset charset) nil t))) (defun vm-mime-display-internal-lynx-text/html (start end layout) (shell-command-on-region start (1- end) ;; "lynx -force_html /dev/stdin" "lynx -force_html -dump -pseudo_inlines -stdin" nil t)) (defun vm-mime-display-internal-text/html (layout) "Dispatch handling of html to the actual html handler." ;; If the user has set the vm-mime-text/html-handler _variable_ to ;; 'auto-select, and it is left set that way in this function, we will get a ;; failure because there is no function called ;; "vm-mime-display-internal-auto-select-text/html". But, the ;; vm-mime-text/html-handler _function_ sets the corresponding _variable_ ;; based upon a heuristic about available packages, so call it for its ;; side-effect now. -- Brent Goodrick, 2008-12-08 (vm-mime-text/html-handler) (if vm-mime-text/html-handler (condition-case error-data (let ((buffer-read-only nil) (start (point)) (charset (or (vm-mime-get-parameter layout "charset") "us-ascii")) end buffer-size) (vm-emit-mime-decoding-message "Inlining text/html by %s..." vm-mime-text/html-handler) (vm-mime-insert-mime-body layout) (unless (bolp) (insert "\n")) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (vm-mime-charset-decode-region charset start end) ;; block remote images by prefixing the link (goto-char start) (let ((case-fold-search t)) (while (re-search-forward vm-mime-text/html-blocker end t) (goto-char (match-end 0)) (if (or t (and vm-mime-text/html-blocker-exceptions (looking-at vm-mime-text/html-blocker-exceptions)) (looking-at "cid:")) (progn ;; TODO: write the image to a file and replace the link ) (insert "blocked:")))) ;; w3-region apparently deletes all the text in the ;; region and then insert new text. This makes the ;; end == start. The fix is to move the end marker ;; forward with a placeholder character so that when ;; w3-region delete all the text, end will still be ;; ahead of the insertion point and so will be moved ;; forward when the new text is inserted. We'll ;; delete the placeholder afterward. (goto-char end) (insert-before-markers "z") ;; the view port (scrollbar) is sometimes messed up, try to avoid it (save-window-excursion ;; dispatch to actual handler (funcall (intern (format "vm-mime-display-internal-%s-text/html" vm-mime-text/html-handler)) start end layout)) ;; do clean up (goto-char end) (delete-char -1) (vm-inform 6 "Inlining text/html by %s... done." vm-mime-text/html-handler) t) (error (vm-set-mm-layout-display-error layout (format "Inline text/html by %s display failed: %s" vm-mime-text/html-handler (error-message-string error-data))) (vm-warn 0 2 "%s" (vm-mm-layout-display-error layout)) nil)) ;; no handler (vm-warn 0 2 "No handler available for internal display of text/html") nil)) (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) "Display a text/plain mime part given by LAYOUT, carrying out any necessary MIME-decoding, CRLF-conversion, charset-conversion and word-wrapping/filling. The original text is replaced by the converted content. Unless NO-HIGHLIGHTING is non-nil, the URL's in the text are highlighted and energized." (let ((start (point)) end need-conversion (buffer-read-only nil) (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (if (and (not (vm-mime-charset-internally-displayable-p charset)) (not (setq need-conversion (vm-mime-can-convert-charset charset)))) (progn (vm-set-mm-layout-display-error layout (concat "Undisplayable charset: " charset)) (vm-warn 0 2 "%s" (vm-mm-layout-display-error layout)) nil) (vm-mime-insert-mime-body layout) (unless (bolp) (insert "\n")) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (when need-conversion (setq charset (vm-mime-charset-convert-region charset start end))) (vm-mime-charset-decode-region charset start end) (unless no-highlighting (vm-energize-urls-in-message-region start end)) (when (and (or vm-word-wrap-paragraphs vm-fill-paragraphs-containing-long-lines) (not no-highlighting)) (vm-fill-paragraphs-containing-long-lines vm-fill-paragraphs-containing-long-lines start end)) (goto-char end) t ))) (defun vm-mime-display-internal-text/enriched (layout) (require 'enriched) (let ((start (point)) end (buffer-read-only nil) (enriched-verbose t) (charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (vm-emit-mime-decoding-message "Decoding text/enriched...") (vm-mime-insert-mime-body layout) (unless (bolp) (insert "\n")) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (vm-mime-charset-decode-region charset start end) ;; enriched-decode expects a couple of headers at the top of ;; the region and will remove anything that looks like a ;; header. Put a header section here for it to eat so it ;; won't eat message text instead. (goto-char start) (insert "Comment: You should not see this header\n\n") (condition-case errdata (enriched-decode start end) (error (vm-set-mm-layout-display-error layout (format "enriched-decode signaled %s" errdata)) (vm-warn 0 2 "%s" (vm-mm-layout-display-error layout)) nil )) (vm-energize-urls-in-message-region start end) (goto-char end) (vm-emit-mime-decoding-message "Decoding text/enriched... done") t )) (defun vm-mime-display-external-generic (layout) "Display mime object with LAYOUT in an external viewer, as determined by `vm-mime-external-content-types-alist'." ;; Optional argument FILE indicates that the content should be ;; taken from it. (let ((program-list (copy-sequence (vm-mime-find-external-viewer (car (vm-mm-layout-type layout))))) (buffer-read-only nil) start (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (append-file t) process tempfile cache end suffix basename) (setq cache (get (vm-mm-layout-cache layout) 'vm-mime-display-external-generic) process (nth 0 cache) tempfile (nth 1 cache)) (if (and (processp process) (eq (process-status process) 'run)) t (cond ((or (null tempfile) (null (file-exists-p tempfile))) (setq suffix (vm-mime-extract-filename-suffix layout) suffix (or suffix (vm-mime-find-filename-suffix-for-type layout))) (setq basename (vm-mime-get-disposition-filename layout)) (setq tempfile (vm-make-tempfile suffix basename)) (vm-register-message-garbage-files (list tempfile)) (vm-mime-send-body-to-file layout nil tempfile t))) (if (symbolp (car program-list)) ;; use internal function if provided (apply (car program-list) (append (cdr program-list) (list tempfile))) ;; quote file name for shell command only (or (cdr program-list) (setq tempfile (shell-quote-argument tempfile))) ;; expand % specs (let ((p program-list) (vm-mf-attachment-file tempfile)) (while p (if (string-match "\\([^%]\\|^\\)%f" (car p)) (setq append-file nil)) (setcar p (vm-mime-sprintf (car p) layout)) (setq p (cdr p)))) (vm-inform 6 "Launching %s..." (mapconcat 'identity program-list " ")) (setq process (if (cdr program-list) (apply 'start-process (format "view %25s" (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)) nil (if append-file (append program-list (list tempfile)) program-list)) (apply 'start-process (format "view %25s" (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout)) nil (or shell-file-name "sh") shell-command-switch (if append-file (list (concat (car program-list) " " tempfile)) program-list)))) (vm-process-kill-without-query process t) (vm-inform 6 "Launching %s... done" (mapconcat 'identity program-list " ")) (if vm-mime-delete-viewer-processes (vm-register-message-garbage 'delete-process process)) (put (vm-mm-layout-cache layout) 'vm-mime-display-external-generic (list process tempfile))))) t ) (defun vm-mime-display-internal-application/octet-stream (layout) "Display a button for the MIME LAYOUT. If a button extent is given as the argument instead, then nothing is done. USR, 2011-03-25" (if (vectorp layout) (let ((buffer-read-only nil) (vm-mf-default-action "save")) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action (function (lambda (layout) (save-excursion (vm-mime-save-application/octet-stream layout)))) :layout layout))) t) (defun vm-mime-save-application/octet-stream (layout) "Save an application/octet-stream object with LAYOUT to the stated filename. A button extent with a layout can also be given as the argument. USR, 2011-03-25" (unless (vectorp layout) (goto-char (vm-extent-start-position layout)) (setq layout (vm-extent-property layout 'vm-mime-layout))) ;; support old "name" paramater for application/octet-stream ;; but don't override the "filename" parameter extracted from ;; Content-Disposition, if any. (let ((default-filename (vm-mime-get-disposition-filename layout)) (file nil)) (setq file (vm-mime-send-body-to-file layout default-filename)) (when (and file vm-mime-delete-after-saving) (let ((vm-mime-confirm-delete nil)) ;; we don't care if the delete fails (condition-case nil (vm-delete-mime-object (expand-file-name file)) (error nil))))) t ) (fset 'vm-mime-display-button-application/octet-stream 'vm-mime-display-internal-application/octet-stream) (defun vm-mime-display-button-application (layout) "Display button for an application type object described by LAYOUT." (vm-mime-display-button-xxxx layout nil)) (defun vm-mime-display-button-audio (layout) (vm-mime-display-button-xxxx layout nil)) (defun vm-mime-display-button-video (layout) (vm-mime-display-button-xxxx layout t)) (defun vm-mime-display-button-message (layout) (vm-mime-display-button-xxxx layout t)) (defun vm-mime-display-button-multipart (layout) (vm-mime-display-button-xxxx layout t)) (defun vm-mime-display-internal-multipart/mixed (layout) (let ((part-list (vm-mm-layout-parts layout))) (while part-list (let ((part (car part-list))) (vm-decode-mime-layout part) (setq part-list (cdr part-list)) ;; we always put separator because it is cleaner, and buttons ;; may get expanded to documents in any case. USR, 2011-02-09 (when part-list (insert vm-mime-parts-display-separator)))) t)) (defun vm-mime-display-internal-multipart/alternative (layout) (if (eq vm-mime-alternative-show-method 'all) (vm-mime-display-internal-multipart/mixed layout) (vm-mime-display-internal-show-multipart/alternative layout))) (defun vm-mime-display-internal-show-multipart/alternative (layout) (let (best-layout) (cond ((eq vm-mime-alternative-show-method 'best) (let ((done nil) (best nil) part-list type) (setq part-list (vm-mm-layout-parts layout) part-list (nreverse (copy-sequence part-list))) (while (and part-list (not done)) (setq type (car (vm-mm-layout-type (car part-list)))) (if (or (vm-mime-can-display-internal (car part-list) t) (vm-mime-find-external-viewer type)) (setq best (car part-list) done t) (setq part-list (cdr part-list)))) (setq best-layout (or best (car (vm-mm-layout-parts layout)))))) ((eq vm-mime-alternative-show-method 'best-internal) (let ((done nil) (best nil) (second-best nil) part-list type) (setq part-list (vm-mm-layout-parts layout) part-list (nreverse (copy-sequence part-list))) (while (and part-list (not done)) (setq type (car (vm-mm-layout-type (car part-list)))) (cond ((and (vm-mime-can-display-internal (car part-list) t) (vm-mime-should-display-internal (car part-list))) (setq best (car part-list) done t)) ((and (null second-best) (vm-mime-find-external-viewer type)) (setq second-best (car part-list)))) (setq part-list (cdr part-list))) (setq best-layout (or best second-best (car (vm-mm-layout-parts layout)))))) ((and (consp vm-mime-alternative-show-method) (eq (car vm-mime-alternative-show-method) 'favorite-internal)) (let ((done nil) (best nil) (saved-part-list (nreverse (copy-sequence (vm-mm-layout-parts layout)))) (favs (cdr vm-mime-alternative-show-method)) (second-best nil) part-list type) (while (and favs (not done)) (setq part-list saved-part-list) (while (and part-list (not done)) (setq type (car (vm-mm-layout-type (car part-list)))) (cond ((or (vm-mime-can-display-internal (car part-list) t) (vm-mime-find-external-viewer type)) (if (vm-mime-types-match (car favs) type) (setq best (car part-list) done t) (or second-best (setq second-best (car part-list)))))) (setq part-list (cdr part-list))) (setq favs (cdr favs))) (setq best-layout (or best second-best (car (vm-mm-layout-parts layout)))))) ((and (consp vm-mime-alternative-show-method) (eq (car vm-mime-alternative-show-method) 'favorite)) (let ((done nil) (best nil) (saved-part-list (nreverse (copy-sequence (vm-mm-layout-parts layout)))) (favs (cdr vm-mime-alternative-show-method)) (second-best nil) part-list type) (while (and favs (not done)) (setq part-list saved-part-list) (while (and part-list (not done)) (setq type (car (vm-mm-layout-type (car part-list)))) (cond ((and (vm-mime-can-display-internal (car part-list) t) (vm-mime-should-display-internal (car part-list))) (if (vm-mime-types-match (car favs) type) (setq best (car part-list) done t) (or second-best (setq second-best (car part-list)))))) (setq part-list (cdr part-list))) (setq favs (cdr favs))) (setq best-layout (or best second-best (car (vm-mm-layout-parts layout))))))) (when best-layout (vm-decode-mime-layout best-layout)))) (defun vm-mime-display-internal-multipart/related (layout) "Decode multipart/related body parts. This function decodes the ``start'' part (see RFC2387) only. The other parts will be decoded by the other VM functions through emacs-w3m." (let* ((part-list (vm-mm-layout-parts layout)) (start-part (car part-list)) (start-id (vm-mime-get-parameter layout "start")) layout) ;; Look for the start part. (if start-id (while part-list (setq layout (car part-list)) (if (equal start-id (vm-mm-layout-id layout)) (setq start-part layout part-list nil) (setq part-list (cdr part-list))))) (if start-part (vm-decode-mime-layout start-part)))) (defun vm-mime-display-button-multipart/parallel (layout) (vm-mime-insert-button :caption (concat ;; display the file name or disposition (let ((file (vm-mime-get-disposition-filename layout))) (if file (format " %s " file) "")) (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) ) :action (function (lambda (layout) (save-excursion (let ((vm-mime-auto-displayed-content-types t) (vm-mime-auto-displayed-content-type-exceptions nil)) (vm-decode-mime-layout layout t))))) :layout layout :disposable t)) (fset 'vm-mime-display-internal-multipart/parallel 'vm-mime-display-internal-multipart/mixed) (defun vm-mime-display-internal-multipart/digest (layout) (if (vectorp layout) (let ((buffer-read-only nil)) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action (function (lambda (layout) (save-excursion (vm-mime-display-internal-multipart/digest layout)))) :layout layout)) (goto-char (vm-extent-start-position layout)) (setq layout (vm-extent-property layout 'vm-mime-layout)) (set-buffer (generate-new-buffer (format "digest from %s/%s" (buffer-name vm-mail-buffer) (vm-number-of (car vm-message-pointer))))) (setq vm-folder-type vm-default-folder-type) (let ((ident-header nil)) (if vm-digest-identifier-header-format (setq ident-header (vm-summary-sprintf vm-digest-identifier-header-format (vm-mm-layout-message layout)))) (vm-mime-burst-layout layout ident-header)) (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode) (if (vm-should-generate-summary) (progn (vm-goto-new-summary-frame-maybe) (vm-summarize)))) ;; temp buffer, don't offer to save it. (setq buffer-offer-save nil) (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup))) t ) (fset 'vm-mime-display-button-multipart/digest 'vm-mime-display-internal-multipart/digest) (defun vm-mime-display-button-message/rfc822 (layout) (let ((buffer-read-only nil)) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action (function (lambda (layout) (save-excursion (vm-mime-display-internal-message/rfc822 layout)))) :layout layout))) (fset 'vm-mime-display-button-message/news 'vm-mime-display-button-message/rfc822) (defun vm-mime-display-internal-message/rfc822 (layout) (if (vectorp layout) (let ((start (point)) (buffer-read-only nil)) (vm-mime-insert-mime-headers (car (vm-mm-layout-parts layout))) (insert ?\n) (save-excursion (goto-char start) (vm-reorder-message-headers nil :keep-list vm-visible-headers :discard-regexp vm-invisible-header-regexp)) (save-restriction (narrow-to-region start (point)) (vm-decode-mime-encoded-words)) (vm-mime-display-internal-multipart/mixed layout)) (goto-char (vm-extent-start-position layout)) (setq layout (vm-extent-property layout 'vm-mime-layout)) (set-buffer (vm-generate-new-unibyte-buffer (format "message from %s/%s" (buffer-name vm-mail-buffer) (vm-number-of (car vm-message-pointer))))) (setq vm-folder-type vm-default-folder-type) (vm-mime-burst-layout layout nil) (set-buffer-modified-p nil) (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode) (if (vm-should-generate-summary) (progn (vm-goto-new-summary-frame-maybe) (vm-summarize)))) ;; temp buffer, don't offer to save it. (setq buffer-offer-save nil) (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup))) t ) (fset 'vm-mime-display-internal-message/news 'vm-mime-display-internal-message/rfc822) (defun vm-mime-display-internal-message/delivery-status (layout) (vm-mime-display-internal-text/plain layout t)) (defun vm-mime-retrieve-external-body (layout) "Fetch an external body into the current buffer. LAYOUT is the MIME layout struct for the message/external-body object." (let ((access-method (downcase (vm-mime-get-parameter layout "access-type"))) (work-buffer (current-buffer))) (cond ((string= access-method "local-file") (let ((name (vm-mime-get-parameter layout "name"))) (if (null name) (vm-mime-error "%s access type missing `name' parameter" access-method)) (if (not (file-exists-p name)) (vm-mime-error "file %s does not exist" name)) (condition-case data (insert-file-contents-literally name) (error (signal 'vm-mime-error (cdr data)))))) ((and (string= access-method "url") vm-url-retrieval-methods) (defvar w3-configuration-directory) ; for bytecompiler (let ((url (vm-mime-get-parameter layout "url")) ;; needed or url-retrieve will bitch (w3-configuration-directory (if (boundp 'w3-configuration-directory) w3-configuration-directory "~"))) (if (null url) (vm-mime-error "%s access type missing `url' parameter" access-method)) (setq url (vm-with-string-as-temp-buffer url (function (lambda () (goto-char (point-min)) (while (re-search-forward "[ \t\n]" nil t) (delete-char -1)))))) (vm-mime-fetch-url-with-programs url work-buffer))) ((and (or (string= access-method "ftp") (string= access-method "anon-ftp")) (or (fboundp 'efs-file-handler-function) (fboundp 'ange-ftp-hook-function))) (let ((name (vm-mime-get-parameter layout "name")) (directory (vm-mime-get-parameter layout "directory")) (site (vm-mime-get-parameter layout "site")) user) (if (null name) (vm-mime-error "%s access type missing `name' parameter" access-method)) (if (null site) (vm-mime-error "%s access type missing `site' parameter" access-method)) (cond ((string= access-method "ftp") (setq user (read-string (format "User name to access %s: " site) (user-login-name)))) (t (setq user "anonymous"))) (if (and (string= access-method "ftp") vm-url-retrieval-methods (vm-mime-fetch-url-with-programs (if directory (concat "ftp:////" site "/" directory "/" name) (concat "ftp:////" site "/" name)) work-buffer)) t (cond (directory (setq directory (concat "/" user "@" site ":" directory)) (setq name (expand-file-name name directory))) (t (setq name (concat "/" user "@" site ":" name)))) (condition-case data (insert-file-contents-literally name) (error (signal 'vm-mime-error (format "%s" (cdr data))))))))))) (defun vm-mime-fetch-message/external-body (layout) "Fetch the external-body content described by LAYOUT and store it in an internal buffer. Update the LAYOUT so that it refers to the fetched content." (let ((child-layout (car (vm-mm-layout-parts layout))) (access-method (downcase (vm-mime-get-parameter layout "access-type"))) ob (work-buffer nil)) (unwind-protect (cond ((and (string= access-method "mail-server") (vm-mm-layout-id child-layout) (setq ob (vm-mime-find-leaf-content-id-in-layout-folder layout (vm-mm-layout-id child-layout)))) (setq child-layout ob)) ((eq (marker-buffer (vm-mm-layout-header-start child-layout)) (marker-buffer (vm-mm-layout-body-start child-layout))) ;; if the "body" is in the same buffer, that means that the ;; external-body has not been retrieved yet (setq work-buffer (vm-make-multibyte-work-buffer (format "*%s mime object*" (car (vm-mm-layout-type child-layout))))) (condition-case data (with-current-buffer work-buffer (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-binary-coding-system) t)) (cond ((or (string= access-method "ftp") (string= access-method "anon-ftp") (string= access-method "local-file") (string= access-method "url")) (vm-mime-retrieve-external-body layout)) ((string= access-method "mail-server") (let ((server (vm-mime-get-parameter layout "server")) (subject (vm-mime-get-parameter layout "subject"))) (if (null server) (vm-mime-error "%s access type missing `server' parameter" access-method)) (if (not (y-or-n-p (format "Send message to %s to retrieve external body? " server))) (error "Aborted")) (vm-mail-internal :buffer-name (format "mail to MIME mail server %s" server) :to server :subject subject) (mail-text) (vm-mime-insert-mime-body child-layout) (let ((vm-confirm-mail-send nil)) (vm-mail-send)) (vm-warn 0 2 (concat "Retrieval message sent. " "Retry viewing this object after " "the response arrives.")))) (t (vm-mime-error "unsupported access method: %s" access-method)) ) (when child-layout (vm-set-mm-layout-body-end child-layout (vm-marker (point-max))) (vm-set-mm-layout-body-start child-layout (vm-marker (point-min))))) (vm-mime-error ; handler ;; (vm-warn 0 2 (format "Error in retrieving: %s" (cdr data))) (vm-set-mm-layout-display-error layout (cdr data)) (setq child-layout nil))))) ;; unwind-protections (when work-buffer (if child-layout ; refers to work-buffer (vm-register-folder-garbage 'kill-buffer work-buffer) (kill-buffer work-buffer)))))) (defun vm-mime-display-external-message/external-body (layout) "Display the external-body content described by LAYOUT." (vm-mime-fetch-message/external-body layout) (let ((child-layout (car (vm-mm-layout-parts layout)))) (when child-layout (vm-mime-display-external-generic child-layout)))) (defun vm-mime-display-internal-message/external-body (layout &optional extent) "Display the external-body content described by LAYOUT. The optional argument EXTENT, if present, gives the extent of the MIME button that this LAYOUT comes from." (vm-mime-fetch-message/external-body layout) (let ((child-layout (car (vm-mm-layout-parts layout)))) (when child-layout (vm-decode-mime-layout (or extent child-layout))))) (defun vm-mime-display-button-message/external-body (layout) "Return a button usable for viewing message/external-body MIME parts." (let ((buffer-read-only nil) (tmplayout (copy-tree (car (vm-mm-layout-parts layout)) t)) (filename "external: ") format) (when (vm-mime-get-parameter layout "name") (setq filename (concat filename (file-name-nondirectory (vm-mime-get-parameter layout "name"))))) (vm-mime-set-parameter tmplayout "name" filename) (vm-mime-set-xxx-parameter "filename" filename (vm-mm-layout-disposition tmplayout)) (setq format (vm-mime-find-format-for-layout tmplayout)) (vm-mime-insert-button :caption (vm-replace-in-string (vm-mime-sprintf format tmplayout) "save\\]" "display]") :action (function (lambda (extent) ;; reuse the internal display code, but make sure that no new ;; buttons should be created for the external-body content. (let ((layout (if vm-xemacs-p (vm-extent-property extent 'vm-mime-layout) (overlay-get extent 'vm-mime-layout))) (vm-mime-auto-displayed-content-types t) (vm-mime-auto-displayed-content-type-exceptions nil)) (vm-mime-display-internal-message/external-body layout extent)))) :layout layout))) (defun vm-mime-fetch-url-with-programs (url buffer) (when (eq t (cond ((if (and (memq 'wget vm-url-retrieval-methods) (condition-case data (vm-run-command-on-region (point) (point) buffer vm-wget-program "-q" "-O" "-" url) (error nil))) t (save-excursion (set-buffer buffer) (erase-buffer) nil ))) ((if (and (memq 'w3m vm-url-retrieval-methods) (condition-case data (vm-run-command-on-region (point) (point) buffer vm-w3m-program "-dump_source" url) (error nil))) t (save-excursion (set-buffer buffer) (erase-buffer) nil ))) ((if (and (memq 'fetch vm-url-retrieval-methods) (condition-case data (vm-run-command-on-region (point) (point) buffer vm-fetch-program "-o" "-" url) (error nil))) t (save-excursion (set-buffer buffer) (erase-buffer) nil ))) ((if (and (memq 'curl vm-url-retrieval-methods) (condition-case data (vm-run-command-on-region (point) (point) buffer vm-curl-program url) (error nil))) t (save-excursion (set-buffer buffer) (erase-buffer) nil ))) ((if (and (memq 'lynx vm-url-retrieval-methods) (condition-case data (vm-run-command-on-region (point) (point) buffer vm-lynx-program "-source" url) (error nil))) t (save-excursion (set-buffer buffer) (erase-buffer) nil ))))) (save-excursion (set-buffer buffer) (not (zerop (buffer-size)))))) (defun vm-mime-internalize-local-external-bodies (layout) "Given a LAYOUT representing a message/external-body object, convert it to an internal object by retrieving the body. USR, 2011-03-28" (cond ((vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (when (string= (downcase (vm-mime-get-parameter layout "access-type")) "local-file") (let* ((child-layout (car (vm-mm-layout-parts layout))) (work-buffer (vm-make-multibyte-work-buffer (format "*%s mime object*" (car (vm-mm-layout-type child-layout)))))) (unwind-protect (let (oldsize) (with-current-buffer work-buffer (vm-mime-retrieve-external-body layout)) (goto-char (vm-mm-layout-body-start child-layout)) (setq oldsize (buffer-size)) (condition-case data (insert-buffer-substring work-buffer) (error (signal 'vm-mime-error (cdr data)))) ;; This is redundant because insertion moves point ;; (goto-char (+ (point) (- (buffer-size) oldsize))) (if (< (point) (vm-mm-layout-body-end child-layout)) (delete-region (point) (vm-mm-layout-body-end child-layout)) (vm-set-mm-layout-body-end child-layout (point-marker))) (delete-region (vm-mm-layout-header-start layout) (vm-mm-layout-body-start layout)) (vm-mime-copy-layout child-layout layout))) (when work-buffer (kill-buffer work-buffer))))) ((vm-mime-composite-type-p (car (vm-mm-layout-type layout))) (let ((p (vm-mm-layout-parts layout))) (while p (vm-mime-internalize-local-external-bodies (car p)) (setq p (cdr p))))) (t nil))) (defun vm-mime-display-internal-message/partial (layout) (if (vectorp layout) (let ((buffer-read-only nil)) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action (function (lambda (layout) (save-excursion (vm-mime-display-internal-message/partial layout)))) :layout layout)) (vm-inform 6 "Assembling message...") (let ((parts nil) (missing nil) (work-buffer nil) extent id o number total m i prev part-header-pos p-id p-number p-total p-list) (setq extent layout layout (vm-extent-property extent 'vm-mime-layout) id (vm-mime-get-parameter layout "id")) (if (null id) (vm-mime-error "message/partial message missing id parameter")) (save-excursion (set-buffer (marker-buffer (vm-mm-layout-body-start layout))) (save-excursion (save-restriction (widen) (goto-char (point-min)) (while (and (search-forward id nil t) (setq m (vm-message-at-point))) (setq o (vm-mm-layout m)) (if (not (vectorp o)) nil (setq p-list (vm-mime-find-message/partials o id)) (while p-list (setq p-id (vm-mime-get-parameter (car p-list) "id")) (setq p-total (vm-mime-get-parameter (car p-list) "total")) (if (null p-total) nil (setq p-total (string-to-number p-total)) (when (< p-total 1) (vm-mime-error "message/partial specified part total < 1, %d" p-total)) (if total (unless (= total p-total) (vm-mime-error (concat "message/partial specified total differs " "between parts, (%d != %d)") p-total total)) (setq total p-total))) (setq p-number (vm-mime-get-parameter (car p-list) "number")) (when (null p-number) (vm-mime-error "message/partial message missing number parameter")) (setq p-number (string-to-number p-number)) (when (< p-number 1) (vm-mime-error "message/partial part number < 1, %d" p-number)) (when (and total (> p-number total)) (vm-mime-error (concat "message/partial part number greater than " " expected number of parts, (%d > %d)") p-number total)) (setq parts (cons (list p-number (car p-list)) parts)) (setq p-list (cdr p-list)))) (goto-char (vm-mm-layout-body-end o)))))) (when (null total) (vm-mime-error "total number of parts not specified in any message/partial part")) (setq parts (sort parts (function (lambda (p q) (< (car p) (car q)))))) (setq i 0) (setq p-list parts) (while p-list (cond ((< i (car (car p-list))) (vm-increment i) (cond ((not (= i (car (car p-list)))) (setq missing (cons i missing))) (t (setq prev p-list p-list (cdr p-list))))) (t ;; remove duplicate part (setcdr prev (cdr p-list)) (setq p-list (cdr p-list))))) (while (< i total) (vm-increment i) (setq missing (cons i missing))) (if missing (vm-mime-error "part%s %s%s missing" (if (cdr missing) "s" "") (mapconcat (function identity) (nreverse (mapcar 'int-to-string (or (cdr missing) missing))) ", ") (if (cdr missing) (concat " and " (car missing)) ""))) (set-buffer (vm-generate-new-unibyte-buffer "assembled message")) (setq vm-folder-type vm-default-folder-type) (vm-mime-insert-mime-headers (car (cdr (car parts)))) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(Encrypted\\|Content-\\|MIME-Version\\|Message-ID\\|Subject\\|X-VM-\\|Status\\)") (goto-char (point-max)) (setq part-header-pos (point)) (while parts (vm-mime-insert-mime-body (car (cdr (car parts)))) (setq parts (cdr parts))) (goto-char part-header-pos) (vm-reorder-message-headers nil :keep-list '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") :discard-regexp nil) (vm-munge-message-separators vm-folder-type (point-min) (point-max)) (goto-char (point-min)) (insert (vm-leading-message-separator)) (goto-char (point-max)) (insert (vm-trailing-message-separator)) (set-buffer-modified-p nil) (vm-inform 6 "Assembling message... done") (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode) (if (vm-should-generate-summary) (progn (vm-goto-new-summary-frame-maybe) (vm-summarize)))) ;; temp buffer, don't offer to save it. (setq buffer-offer-save nil) (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup))) t )) (fset 'vm-mime-display-button-message/partial 'vm-mime-display-internal-message/partial) (defun vm-mime-display-internal-image-xxxx (layout image-type name) "Display the image object described by LAYOUT internally. IMAGE-TYPE is its image type (png, jpeg etc.). NAME is a string describing the image type. USR, 2011-03-25" (cond (vm-xemacs-p (vm-mime-display-internal-image-xemacs-xxxx layout image-type name)) ((and vm-fsfemacs-p (fboundp 'image-type-available-p)) (vm-mime-display-internal-image-fsfemacs-xxxx layout image-type name)) (t (vm-inform 0 "Unsupported Emacs version")) )) (defun vm-mime-display-internal-image-xemacs-xxxx (layout image-type name) (if (and (vm-images-possible-here-p) (vm-image-type-available-p image-type)) (let ((start (point-marker)) end tempfile g e (selective-display nil) (incremental vm-mime-display-image-strips-incrementally) do-strips (keymap (make-sparse-keymap)) (buffer-read-only nil)) (if (and (setq tempfile (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) (file-readable-p tempfile)) nil (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile)) (vm-register-folder-garbage-files (list tempfile)) ;; coding system for presentation buffer is binary so ;; we don't need to set it here. (write-region start end tempfile nil 0) (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx tempfile) (delete-region start end)) (if (not (bolp)) (insert "\n")) (setq do-strips (and (stringp vm-imagemagick-convert-program) vm-mime-use-image-strips)) (cond (do-strips (condition-case error-data (let ((strips (vm-make-image-strips tempfile (* 2 (font-height (face-font 'default))) image-type t incremental)) process image-list extent-list start (first t)) (define-key keymap 'button3 'vm-menu-popup-image-menu) (setq process (car strips) strips (cdr strips) image-list strips) (vm-register-message-garbage-files strips) (setq start (point)) (while strips (setq g (make-glyph (list (cons nil (vector 'string ':data (if (or first (null (cdr strips))) (progn (setq first nil) "+-----+") "|image|")))))) (insert " \n") (setq e (vm-make-extent (- (point) 2) (1- (point)))) (vm-set-extent-property e 'begin-glyph g) (vm-set-extent-property e 'start-open t) (vm-set-extent-property e 'keymap keymap) (setq extent-list (cons e extent-list)) (setq strips (cdr strips))) (setq e (vm-make-extent start (point))) (vm-set-extent-property e 'start-open t) (vm-set-extent-property e 'vm-mime-layout layout) (vm-set-extent-property e 'vm-mime-disposable t) (vm-set-extent-property e 'keymap keymap) (save-excursion (set-buffer (process-buffer process)) (set (make-local-variable 'vm-image-list) image-list) (set (make-local-variable 'vm-image-type) image-type) (set (make-local-variable 'vm-image-type-name) name) (set (make-local-variable 'vm-extent-list) (nreverse extent-list))) (if incremental (set-process-filter process 'vm-process-filter-display-some-image-strips)) (set-process-sentinel process 'vm-process-sentinel-display-image-strips)) (vm-image-too-small (setq do-strips nil)) (error (vm-warn 0 0 "Failed making image strips: %s" error-data) ;; fallback to the non-strips way (setq do-strips nil))))) (cond ((not do-strips) (vm-inform 6 "Creating %s glyph..." name) (setq g (make-glyph (list (cons (list 'win) (vector image-type ':file tempfile)) (cons (list 'win) (vector 'string ':data (format "[Unknown/Bad %s image encoding]" name))) (cons nil (vector 'string ':data (format "[%s image]\n" name)))))) (vm-inform 6 "") ;; XEmacs 21.2 can pixel scroll images (sort of) ;; if the entire image is above the baseline. (set-glyph-baseline g 100) (if (memq image-type '(xbm)) (set-glyph-face g 'vm-monochrome-image)) (insert " \n") (define-key keymap 'button3 'vm-menu-popup-image-menu) (setq e (vm-make-extent (- (point) 2) (1- (point)))) (vm-set-extent-property e 'keymap keymap) (vm-set-extent-property e 'begin-glyph g) (vm-set-extent-property e 'vm-mime-layout layout) (vm-set-extent-property e 'vm-mime-disposable t) (vm-set-extent-property e 'start-open t))) t ))) (defvar vm-menu-fsfemacs-image-menu) (defun vm-mime-display-internal-image-fsfemacs-xxxx (layout image-type name) "Display the image object described by LAYOUT internally. IMAGE-TYPE is its image type (png, jpeg etc.). NAME is a string describing the image type. USR, 2011-03-25" (if (and (vm-images-possible-here-p) (vm-image-type-available-p image-type)) (let (start end tempfile image work-buffer (selective-display nil) (incremental vm-mime-display-image-strips-incrementally) do-strips (buffer-read-only nil)) (if (and (setq tempfile (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) (file-readable-p tempfile)) nil (unwind-protect (progn (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (setq start (point)) (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile)) (let ((coding-system-for-write (vm-binary-coding-system))) (write-region start end tempfile nil 0)) (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx tempfile)) (vm-register-folder-garbage-files (list tempfile))) (and work-buffer (kill-buffer work-buffer)))) (if (not (bolp)) (insert-char ?\n 1)) (setq do-strips (and (stringp vm-imagemagick-convert-program) vm-mime-use-image-strips)) (cond (do-strips (condition-case error-data (let ((strips (vm-make-image-strips tempfile (* 2 (frame-char-height)) image-type t incremental)) (first t) start o process image-list overlay-list) (setq process (car strips) strips (cdr strips) image-list strips) (if (null (process-buffer process)) (error "ImageMagick conversion failed")) (vm-register-message-garbage-files strips) (setq start (point)) (while strips (if (or first (null (cdr strips))) (progn (setq first nil) (insert "+-----+")) (insert "|image|")) (setq o (make-overlay (- (point) 7) (point))) (overlay-put o 'evaporate t) (setq overlay-list (cons o overlay-list)) (insert "\n") (setq strips (cdr strips))) (setq o (make-overlay start (point) nil t nil)) (overlay-put o 'vm-mime-layout layout) (overlay-put o 'vm-mime-disposable t) (if vm-use-menus (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu)) (save-excursion (set-buffer (process-buffer process)) (set (make-local-variable 'vm-image-list) image-list) (set (make-local-variable 'vm-image-type) image-type) (set (make-local-variable 'vm-image-type-name) name) (set (make-local-variable 'vm-overlay-list) (nreverse overlay-list))) (if incremental (set-process-filter process 'vm-process-filter-display-some-image-strips)) (set-process-sentinel process 'vm-process-sentinel-display-image-strips)) (vm-image-too-small (setq do-strips nil)) (error (vm-warn 0 0 "Failed making image strips: %s" error-data) ;; fallback to the non-strips way (setq do-strips nil))))) (cond ((not do-strips) (setq image (list 'image ':type image-type ':file tempfile)) ;; insert one char so we can attach the image to it. (insert "z") (put-text-property (1- (point)) (point) 'display image) (clear-image-cache t) (let (o) (setq o (make-overlay (- (point) 1) (point) nil t nil)) (overlay-put o 'evaporate t) (overlay-put o 'vm-mime-layout layout) (overlay-put o 'vm-mime-disposable t) (if vm-use-menus (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu))))) t ) ;; otherwise, image-type not available here nil )) ;; FSF Emacs 19 is not supported any more. USR, 2011-02-23 ;; (defun vm-mime-display-internal-image-fsfemacs-19-xxxx (layout image-type name) ;; (if (and (vm-images-possible-here-p) ;; (vm-image-type-available-p image-type)) ;; (catch 'done ;; (let ((selective-display nil) ;; start end origfile workfile image work-buffer ;; (hroll (if vm-fsfemacs-mule-p ;; (+ (cdr (assq 'internal-border-width ;; (frame-parameters))) ;; (if (memq (cdr (assq 'vertical-scroll-bars ;; (frame-parameters))) ;; '(t left)) ;; (vm-fsfemacs-scroll-bar-width) ;; 0)) ;; (cdr (assq 'internal-border-width ;; (frame-parameters))))) ;; (vroll (cdr (assq 'internal-border-width (frame-parameters)))) ;; (reverse (eq (cdr (assq 'background-mode (frame-parameters))) ;; 'dark)) ;; blob strips ;; dims width height char-width char-height ;; horiz-pad vert-pad trash-list ;; (buffer-read-only nil)) ;; (if (and (setq blob (get (vm-mm-layout-cache layout) ;; 'vm-mime-display-internal-image-xxxx)) ;; (file-exists-p (car blob)) ;; (progn ;; (setq origfile (car blob) ;; workfile (nth 1 blob) ;; width (nth 2 blob) ;; height (nth 3 blob) ;; char-width (nth 4 blob) ;; char-height (nth 5 blob)) ;; (and (= char-width (frame-char-width)) ;; (= char-height (frame-char-height))))) ;; (setq strips (nth 6 blob)) ;; (unwind-protect ;; (progn ;; (save-excursion ;; (setq work-buffer (vm-make-work-buffer)) ;; (set-buffer work-buffer) ;; (if (and origfile (file-exists-p origfile)) ;; (progn ;; (insert-file-contents origfile) ;; (setq start (point-min) ;; end (vm-marker (point-max)))) ;; (setq start (point)) ;; (vm-mime-insert-mime-body layout) ;; (setq end (point-marker)) ;; (vm-mime-transfer-decode-region layout start end) ;; (setq origfile (vm-make-tempfile)) ;; (setq trash-list (cons origfile trash-list)) ;; (let ((coding-system-for-write (vm-binary-coding-system))) ;; (write-region start end origfile nil 0))) ;; (setq dims (condition-case error-data ;; (vm-get-image-dimensions origfile) ;; (error ;; (vm-warn 0 0 "Failed getting image dimensions: %s" ;; error-data) ;; (throw 'done nil))) ;; width (nth 0 dims) ;; height (nth 1 dims) ;; char-width (frame-char-width) ;; char-height (frame-char-height) ;; horiz-pad (if (< width char-width) ;; (- char-width width) ;; (% width char-width)) ;; horiz-pad (if (zerop horiz-pad) ;; horiz-pad ;; (- char-width horiz-pad)) ;; vert-pad (if (< height char-height) ;; (- char-height height) ;; (% height char-height)) ;; vert-pad (if (zerop vert-pad) ;; vert-pad ;; (- char-height vert-pad))) ;; ;; crop one line from the bottom of the image ;; ;; if vertical padding needed is odd so that ;; ;; the image height plus the padding will be an ;; ;; exact multiple of the char height. ;; (if (not (zerop (% vert-pad 2))) ;; (setq height (1- height) ;; vert-pad (1+ vert-pad))) ;; (call-process-region start end ;; vm-imagemagick-convert-program ;; t t nil ;; (if reverse "-negate" "-matte") ;; "-crop" ;; (format "%dx%d+0+0" width height) ;; "-page" ;; (format "%dx%d+0+0" width height) ;; "-mattecolor" "white" ;; "-frame" ;; (format "%dx%d+0+0" ;; (/ (1+ horiz-pad) 2) ;; (/ vert-pad 2)) ;; "-" ;; "-") ;; (setq width (+ width (* 2 (/ (1+ horiz-pad) 2))) ;; height (+ height (* 2 (/ vert-pad 2)))) ;; (if (null workfile) ;; (setq workfile (vm-make-tempfile) ;; trash-list (cons workfile trash-list))) ;; (let ((coding-system-for-write (vm-binary-coding-system))) ;; (write-region (point-min) (point-max) workfile nil 0)) ;; (put (vm-mm-layout-cache layout) ;; 'vm-mime-display-internal-image-xxxx ;; (list origfile workfile width height ;; char-width char-height))) ;; (when trash-list ;; (vm-register-folder-garbage-files trash-list))) ;; (and work-buffer (kill-buffer work-buffer)))) ;; (if (not (bolp)) ;; (insert-char ?\n 1)) ;; (condition-case error-data ;; (let (o i-start start process image-list overlay-list) ;; (if (and strips (file-exists-p (car strips))) ;; (setq image-list strips) ;; (setq strips (vm-make-image-strips workfile char-height ;; image-type t nil ;; hroll vroll) ;; process (car strips) ;; strips (cdr strips) ;; image-list strips) ;; (put (vm-mm-layout-cache layout) ;; 'vm-mime-display-internal-image-xxxx ;; (list origfile workfile width height ;; char-width char-height ;; strips)) ;; (vm-register-message-garbage-files strips)) ;; (setq i-start (point)) ;; (while strips ;; (setq start (point)) ;; (insert-char ?\ (/ width char-width)) ;; (put-text-property start (point) 'face 'vm-image-placeholder) ;; (setq o (make-overlay start (point) nil t)) ;; (overlay-put o 'evaporate t) ;; (setq overlay-list (cons o overlay-list)) ;; (insert "\n") ;; (setq strips (cdr strips))) ;; (setq o (make-overlay i-start (point) nil t nil)) ;; (overlay-put o 'vm-mime-layout layout) ;; (overlay-put o 'vm-mime-disposable t) ;; (if vm-use-menus ;; (overlay-put o 'vm-image vm-menu-fsfemacs-image-menu)) ;; (if process ;; (save-excursion ;; (set-buffer (process-buffer process)) ;; (set (make-local-variable 'vm-image-list) image-list) ;; (set (make-local-variable 'vm-image-type) image-type) ;; (set (make-local-variable 'vm-image-type-name) ;; name) ;; (set (make-local-variable 'vm-overlay-list) ;; (nreverse overlay-list)) ;; ;; incremental strip display intentionally ;; ;; omitted because it makes the Emacs 19 ;; ;; display completely repaint for each new ;; ;; strip. ;; (set-process-sentinel ;; process ;; 'vm-process-sentinel-display-image-strips)) ;; (vm-display-image-strips-on-overlay-regions image-list ;; (nreverse ;; overlay-list) ;; image-type))) ;; (error ;; (vm-warn 0 0 "Failed making image strips: %s" error-data))) ;; t )) ;; nil )) (defun vm-get-image-dimensions (file) (let (work-buffer width height) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (call-process vm-imagemagick-identify-program nil t nil file) (goto-char (point-min)) (or (search-forward " " nil t) (error "no spaces in 'identify' output: %s" (buffer-string))) (if (not (re-search-forward "\\b\\([0-9]+\\)x\\([0-9]+\\)\\b" nil t)) (error "file dimensions missing from 'identify' output: %s" (buffer-string))) (setq width (string-to-number (match-string 1)) height (string-to-number (match-string 2)))) (and work-buffer (kill-buffer work-buffer))) (list width height))) (defun vm-imagemagick-type-indicator-for (image-type) (cond ((eq image-type 'jpeg) "jpeg:") ((eq image-type 'gif) "gif:") ((eq image-type 'png) "png:") ((eq image-type 'tiff) "tiff:") ((eq image-type 'xpm) "xpm:") ((eq image-type 'pbm) "pbm:") ((eq image-type 'xbm) "xbm:") (t ""))) (defun vm-make-image-strips (file min-height image-type async incremental &optional hroll vroll) (or hroll (setq hroll 0)) (or vroll (setq vroll 0)) (let ((process-connection-type nil) (i 0) (output-type (vm-imagemagick-type-indicator-for image-type)) image-list dimensions width height starty newfile work-buffer quotient remainder adjustment process) (setq dimensions (vm-get-image-dimensions file) width (car dimensions) height (car (cdr dimensions))) (if (< height min-height) (signal 'vm-image-too-small nil)) (setq quotient (/ height min-height) remainder (% height min-height) adjustment (/ remainder quotient) remainder (% remainder quotient) starty 0) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (goto-char (point-min)) (while (< starty height) (setq newfile (vm-make-tempfile)) (if async (progn ;; Problem - we have no way of knowing whether these ;; calls succeed or not. USR, 2011-02-23 (insert vm-imagemagick-convert-program " -crop" (format " %dx%d+0+%d" width (+ min-height adjustment (if (zerop remainder) 0 1)) starty) " -page" (format " %dx%d+0+0" width (+ min-height adjustment (if (zerop remainder) 0 1))) (format " -roll +%d+%d" hroll vroll) " \"" file "\" \"" output-type newfile "\"\n") (when incremental (insert "echo XZXX" (int-to-string i) "XZXX\n")) (setq i (1+ i))) (call-process vm-imagemagick-convert-program nil nil nil "-crop" (format "%dx%d+0+%d" width (+ min-height adjustment (if (zerop remainder) 0 1)) starty) "-page" (format "%dx%d+0+0" width (+ min-height adjustment (if (zerop remainder) 0 1))) "-roll" (format "+%d+%d" hroll vroll) file (concat output-type newfile))) (setq image-list (cons newfile image-list) starty (+ starty min-height adjustment (if (zerop remainder) 0 1)) remainder (if (= 0 remainder) 0 (1- remainder)))) (when async (goto-char (point-max)) (insert "exit\n") (setq process (start-process (format "image strip maker for %s" file) (current-buffer) shell-file-name)) (process-send-string process (buffer-string)) (setq work-buffer nil)) (if async (cons process (nreverse image-list)) (nreverse image-list))) (and work-buffer (kill-buffer work-buffer))))) (defun vm-process-sentinel-display-image-strips (process what-happened) (save-excursion (set-buffer (process-buffer process)) (cond ((and (boundp 'vm-extent-list) (boundp 'vm-image-list)) (let ((strips vm-image-list) (extents vm-extent-list) (image-type vm-image-type) (type-name vm-image-type-name)) (vm-display-image-strips-on-extents strips extents image-type type-name))) ((and (boundp 'vm-overlay-list) (overlay-buffer (car vm-overlay-list)) (boundp 'vm-image-list)) (let ((strips vm-image-list) (overlays vm-overlay-list) (image-type vm-image-type)) (vm-display-image-strips-on-overlay-regions strips overlays image-type)))) (kill-buffer (current-buffer)))) (defun vm-display-image-strips-on-extents (strips extents image-type type-name) (let (g) (while (and strips (file-exists-p (car strips)) (extent-live-p (car extents)) (vm-extent-object (car extents))) (setq g (make-glyph (list (cons (list 'win) (vector image-type ':file (car strips))) (cons (list 'win) (vector 'string ':data (format "[Unknown/Bad %s image encoding]" type-name))) (cons nil (vector 'string ':data (format "[%s image]\n" type-name)))))) (set-glyph-baseline g 50) (if (memq image-type '(xbm)) (set-glyph-face g 'vm-monochrome-image)) (set-extent-begin-glyph (car extents) g) (setq strips (cdr strips) extents (cdr extents))))) (defun vm-display-image-strips-on-overlay-regions (strips overlays image-type) (let (prop value omodified) (save-excursion (set-buffer (overlay-buffer (car vm-overlay-list))) (setq omodified (buffer-modified-p)) (save-restriction (widen) (unwind-protect (let ((buffer-read-only nil)) (if (fboundp 'image-type-available-p) (setq prop 'display) (setq prop 'face)) (while (and strips (file-exists-p (car strips)) (overlay-end (car overlays))) (if (fboundp 'image-type-available-p) (setq value (list 'image ':type image-type ':file (car strips) ':ascent 50)) (setq value (make-face (make-symbol ""))) (set-face-stipple value (car strips))) (put-text-property (overlay-start (car overlays)) (overlay-end (car overlays)) prop value) (setq strips (cdr strips) overlays (cdr overlays)))) (set-buffer-modified-p omodified)))))) (defun vm-process-filter-display-some-image-strips (process output) (let (which-strips (i 0)) (while (string-match "XZXX\\([0-9]+\\)XZXX" output i) (setq which-strips (cons (string-to-number (match-string 1 output)) which-strips) i (match-end 0))) (save-excursion (set-buffer (process-buffer process)) (cond ((and (boundp 'vm-extent-list) (boundp 'vm-image-list)) (let ((strips vm-image-list) (extents vm-extent-list) (image-type vm-image-type) (type-name vm-image-type-name)) (vm-display-some-image-strips-on-extents strips extents image-type type-name which-strips))) ((and (boundp 'vm-overlay-list) (overlay-buffer (car vm-overlay-list)) (boundp 'vm-image-list)) (let ((strips vm-image-list) (overlays vm-overlay-list) (image-type vm-image-type)) (vm-display-some-image-strips-on-overlay-regions strips overlays image-type which-strips))))))) (defun vm-display-some-image-strips-on-extents (strips extents image-type type-name which-strips) (let (g sss eee) (while which-strips (setq sss (nthcdr (car which-strips) strips) eee (nthcdr (car which-strips) extents)) (cond ((and sss (file-exists-p (car sss)) (extent-live-p (car eee)) (vm-extent-object (car eee))) (setq g (make-glyph (list (cons (list 'win) (vector image-type ':file (car sss))) (cons (list 'win) (vector 'string ':data (format "[Unknown/Bad %s image encoding]" type-name))) (cons nil (vector 'string ':data (format "[%s image]\n" type-name)))))) (set-glyph-baseline g 50) (if (memq image-type '(xbm)) (set-glyph-face g 'vm-monochrome-image)) (set-extent-begin-glyph (car eee) g))) (setq which-strips (cdr which-strips))))) (defun vm-display-some-image-strips-on-overlay-regions (strips overlays image-type which-strips) (let (sss ooo prop value omodified) (save-excursion (set-buffer (overlay-buffer (car vm-overlay-list))) (setq omodified (buffer-modified-p)) (save-restriction (widen) (unwind-protect (let ((buffer-read-only nil)) (if (fboundp 'image-type-available-p) (setq prop 'display) (setq prop 'face)) (while which-strips (setq sss (nthcdr (car which-strips) strips) ooo (nthcdr (car which-strips) overlays)) (cond ((and sss (file-exists-p (car sss)) (overlay-end (car ooo))) (if (fboundp 'image-type-available-p) (setq value (list 'image ':type image-type ':file (car sss) ':ascent 50)) (setq value (make-face (make-symbol ""))) (set-face-stipple value (car sss))) (put-text-property (overlay-start (car ooo)) (overlay-end (car ooo)) prop value))) (setq which-strips (cdr which-strips)))) (set-buffer-modified-p omodified)))))) (defun vm-mime-display-internal-image/gif (layout) (vm-mime-display-internal-image-xxxx layout 'gif "GIF")) (defun vm-mime-display-internal-image/jpeg (layout) (vm-mime-display-internal-image-xxxx layout 'jpeg "JPEG")) (defun vm-mime-display-internal-image/png (layout) (vm-mime-display-internal-image-xxxx layout 'png "PNG")) (defun vm-mime-display-internal-image/tiff (layout) (vm-mime-display-internal-image-xxxx layout 'tiff "TIFF")) (defun vm-mime-display-internal-image/xpm (layout) (vm-mime-display-internal-image-xxxx layout 'xpm "XPM")) (defun vm-mime-display-internal-image/pbm (layout) (vm-mime-display-internal-image-xxxx layout 'pbm "PBM")) (defun vm-mime-display-internal-image/xbm (layout) (vm-mime-display-internal-image-xxxx layout 'xbm "XBM")) (defun vm-mime-frob-image-xxxx (extent &rest convert-args) "Create and display a thumbnail (a PNG image) for the MIME object described by EXTENT. The thumbnail is stored in a file whose identity is saved in the MIME layout cache of the object. The remaining arguments CONVERT-ARGS are passed to the ImageMagick convert program during the creation of the thumbnail image. The return value does not seem to be meaningful. USR, 2011-03-25" (let* ((layout (vm-extent-property extent 'vm-mime-layout)) (blob (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) (saved-type (vm-mm-layout-type layout)) success tempfile (work-buffer nil)) ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+. ;; The cache blob is a list in that case. (if (consp blob) (setq tempfile (car blob)) (setq tempfile blob)) (setq work-buffer (vm-make-work-buffer)) (unwind-protect (with-current-buffer work-buffer (set-buffer-file-coding-system (vm-binary-coding-system)) ;; convert just the first page "[0]" and enforce PNG output by "png:" (let ((coding-system-for-read (vm-binary-coding-system))) (setq success (eq 0 (apply 'call-process vm-imagemagick-convert-program tempfile t nil (append convert-args (list "-[0]" "png:-")))))) (when success (write-region (point-min) (point-max) tempfile nil 0) (when (consp blob) (setcar (nthcdr 5 blob) 0)) (put (vm-mm-layout-cache layout) 'vm-image-modified t))) ;; unwind-protection (when work-buffer (kill-buffer work-buffer))) (unwind-protect (when success ;; the output is always PNG now, so fix it for displaying, but restore ;; it for the layout afterwards (vm-set-mm-layout-type layout '("image/png")) (vm-set-mm-layout-disposition layout '("inline")) (vm-mark-image-tempfile-as-message-garbage-once layout tempfile) (vm-mime-display-internal-generic extent)) (vm-set-mm-layout-type layout saved-type)))) (defun vm-mark-image-tempfile-as-message-garbage-once (layout tempfile) (if (get (vm-mm-layout-cache layout) 'vm-message-garbage) nil (vm-register-message-garbage-files (list tempfile)) (put (vm-mm-layout-cache layout) 'vm-message-garbage t))) (defun vm-mime-rotate-image-left (extent) (vm-mime-frob-image-xxxx extent "-rotate" "-90")) (defun vm-mime-rotate-image-right (extent) (vm-mime-frob-image-xxxx extent "-rotate" "90")) (defun vm-mime-mirror-image (extent) (vm-mime-frob-image-xxxx extent "-flop")) (defun vm-mime-brighten-image (extent) (vm-mime-frob-image-xxxx extent "-modulate" "115")) (defun vm-mime-dim-image (extent) (vm-mime-frob-image-xxxx extent "-modulate" "85")) (defun vm-mime-monochrome-image (extent) (vm-mime-frob-image-xxxx extent "-monochrome")) (defun vm-mime-revert-image (extent) (let* ((layout (vm-extent-property extent 'vm-mime-layout)) (blob (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) tempfile) ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+. ;; The cache blob is a list in that case. (if (consp blob) (setq tempfile (car blob)) (setq tempfile blob)) (and (stringp tempfile) (vm-error-free-call 'delete-file tempfile)) (put (vm-mm-layout-cache layout) 'vm-image-modified nil) (vm-mime-display-generic extent))) (defun vm-mime-larger-image (extent) (let* ((layout (vm-extent-property extent 'vm-mime-layout)) (blob (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) dims tempfile) ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+. ;; The cache blob is a list in that case. (if (consp blob) (setq tempfile (car blob)) (setq tempfile blob)) (setq dims (vm-get-image-dimensions tempfile)) (vm-mime-frob-image-xxxx extent "-scale" (concat (int-to-string (* 2 (car dims))) "x" (int-to-string (* 2 (nth 1 dims))))))) (defun vm-mime-smaller-image (extent) (let* ((layout (vm-extent-property extent 'vm-mime-layout)) (blob (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) dims tempfile) ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+. ;; The cache blob is a list in that case. (if (consp blob) (setq tempfile (car blob)) (setq tempfile blob)) (setq dims (vm-get-image-dimensions tempfile)) (vm-mime-frob-image-xxxx extent "-scale" (concat (int-to-string (/ (car dims) 2)) "x" (int-to-string (/ (nth 1 dims) 2)))))) (defcustom vm-mime-thumbnail-max-geometry "80x80" "If thumbnails should be displayed as part of MIME buttons, then set this variable to a string describing the geometry, e.g., \"80x80\". Otherwise, set it to nil. USR, 2011-03-25" :group 'vm-mime :type '(choice string (const :tag "Disable thumbnails." nil))) (defun vm-mime-display-button-image (layout) "Displays a button for the MIME LAYOUT and includes a thumbnail image when possible." (if (and vm-imagemagick-convert-program vm-mime-thumbnail-max-geometry (vm-images-possible-here-p)) ;; create a thumbnail and display it (let (tempfile start end thumb-extent glyph) ;; fake an extent to display the image as thumb (setq start (point)) (insert " ") (setq thumb-extent (vm-make-extent start (point))) (vm-set-extent-property thumb-extent 'vm-mime-layout layout) (vm-set-extent-property thumb-extent 'vm-mime-disposable nil) (vm-set-extent-property thumb-extent 'start-open t) ;; write out the image data (with-current-buffer (vm-make-work-buffer) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (setq tempfile (vm-make-tempfile)) (let ((coding-system-for-write (vm-binary-coding-system))) (write-region (point-min) (point-max) tempfile nil 0)) (kill-buffer (current-buffer))) ;; store the temp filename (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx tempfile) (vm-register-folder-garbage-files (list tempfile)) ;; display a thumbnail over the fake extent (let ((vm-mime-internal-content-types '("image")) (vm-mime-internal-content-type-exceptions nil) (vm-mime-auto-displayed-content-types '("image")) (vm-mime-auto-displayed-content-type-exceptions nil) (vm-mime-use-image-strips nil)) (vm-mime-frob-image-xxxx thumb-extent "-thumbnail" vm-mime-thumbnail-max-geometry)) ;; extract image data, don't need the image itself! ;; if the display was not successful, glyph will be nil (setq glyph (if vm-xemacs-p (let ((e1 (vm-extent-at start)) (e2 (vm-extent-at (1+ start)))) (or (and e1 (extent-begin-glyph e1)) (and e2 (extent-begin-glyph e2)))) (get-text-property start 'display))) (delete-region start (point)) ;; insert the button and replace the image (setq start (point)) (vm-mime-display-button-xxxx layout t) (when glyph (if vm-xemacs-p (set-extent-begin-glyph (vm-extent-at start) glyph) (put-text-property start (1+ start) 'display glyph))) ;; remove the cached thumb so that full sized image will be shown (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx nil) t) ;; just display the normal button (vm-mime-display-button-xxxx layout t))) (defun vm-mime-display-button-application/pdf (layout) (vm-mime-display-button-image layout)) (defun vm-mime-display-internal-audio/basic (layout) (if (and vm-xemacs-p (or (featurep 'native-sound) (featurep 'nas-sound)) (or (device-sound-enabled-p) (and (featurep 'native-sound) (not native-sound-only-on-console) (memq (vm-device-type) '(x gtk))))) (let ((start (point-marker)) end tempfile (selective-display nil) (buffer-read-only nil)) (if (setq tempfile (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-audio/basic)) nil (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (setq tempfile (vm-make-tempfile)) (vm-register-folder-garbage-files (list tempfile)) ;; coding system for presentation buffer is binary, so ;; we don't need to set it here. (write-region start end tempfile nil 0) (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-audio/basic tempfile) (delete-region start end)) (start-itimer "audioplayer" (list 'lambda nil (list 'play-sound-file tempfile)) 1) t ) nil )) (defun vm-mime-display-generic (layout) "Display the mime object described by LAYOUT, irrespective of whether it is meant to be to be displayed automatically." (save-excursion (let ((vm-mime-auto-displayed-content-types t) (vm-mime-auto-displayed-content-type-exceptions nil)) (vm-decode-mime-layout layout t)))) (defun vm-mime-display-internal-generic (layout) "Display the mime object described by LAYOUT internally, irrespective of whether it is meant to be to be displayed automatically. No external viewers are tried. USR, 2011-03-25" (save-excursion (let ((vm-mime-auto-displayed-content-types t) (vm-mime-auto-displayed-content-type-exceptions nil) (vm-mime-external-content-types-alist nil)) (vm-decode-mime-layout layout t)))) (defun vm-mime-display-button-xxxx (layout disposable) "Display a button for the mime object described by LAYOUT. If DISPOSABLE is true, then the button will be removed when it is expanded to display the mime object." (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action (function vm-mime-display-generic) :layout layout :disposable disposable)) ;;---------------------------------------------------------------------------- ;;; MIME buttons ;; ;; vm-find-layout-extent-at-point: () -> extent ;; vm-mime-run-display-funciton-at-point: (layout -> 'a) -> 'a ;; vm-mime-reader-map-save-file: () -> file ;; vm-mime-reader-map-save-message: () -> file ;; vm-mime-reader-map-pipe-to-command: () -> void ;; vm-mime-reader-map-pipe-to-command-discard-output: () -> void ;; vm-mime-reader-map-pipe-to-printer: () -> void ;; vm-mime-reader-map-display-using-external-viewer: () -> void ;; vm-mime-reader-map-display-using-default: () -> void ;; vm-mime-reader-map-display-object-as-type: () -> void ;; vm-mime-reader-map-attach-to-composition: () -> void ;;---------------------------------------------------------------------------- (defun vm-find-layout-extent-at-point () "Return the MIME layout of the MIME button at point." (vm-extent-at (point) 'vm-mime-layout)) ;;;###autoload (defun vm-mime-run-display-function-at-point (&optional function) "Run the 'vm-mime-function for the MIME button at point. If optional argument FUNCTION is given, run it instead. USR, 2011-03-07" (interactive) (if (and (memq major-mode '(vm-mode vm-virtual-mode)) (vm-body-to-be-retrieved-of (car vm-message-pointer))) (error "Message must be loaded to view attachments" )) ;; save excursion to keep point from moving. its motion would ;; drag window point along, to a place arbitrarily far from ;; where it was when the user triggered the button. (save-excursion (let ((extent (vm-find-layout-extent-at-point)) retval ) (and extent (funcall (or function (vm-extent-property extent 'vm-mime-function)) extent))))) ;;;###autoload (defun vm-mime-reader-map-save-file () "Write the MIME object at point to a file." (interactive) ;; make sure point doesn't move, we need it to stay on the tag ;; if the user wants to delete after saving. (let (file) (save-excursion (setq file (vm-mime-run-display-function-at-point 'vm-mime-send-body-to-file))) (when (and file vm-mime-delete-after-saving) (let ((extent (vm-find-layout-extent-at-point))) (vm-mime-delete-body-after-saving extent file))) file )) ;;;###autoload (defun vm-mime-reader-map-save-message () "Save the MIME object at point to a folder." (interactive) ;; make sure point doesn't move, we need it to stay on the tag ;; if the user wants to delete after saving. (let (folder) (save-excursion (setq folder (vm-mime-run-display-function-at-point 'vm-mime-send-body-to-folder))) (when (and folder vm-mime-delete-after-saving) (let ((extent (vm-find-layout-extent-at-point))) (vm-mime-delete-body-after-saving extent folder))) folder )) ;;;###autoload (defun vm-mime-reader-map-pipe-to-command () "Pipe the MIME object at point to a shell command." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-pipe-body-to-queried-command)) ;;;###autoload (defun vm-mime-reader-map-pipe-to-command-discard-output () "Pipe the MIME object at point to a shell command." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-pipe-body-to-queried-command-discard-output)) ;;;###autoload (defun vm-mime-reader-map-pipe-to-printer () "Print the MIME object at point." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-send-body-to-printer)) ;;;###autoload (defun vm-mime-reader-map-display-using-external-viewer () "Display the MIME object at point with an external viewer." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-display-body-using-external-viewer)) ;;;###autoload (defun vm-mime-reader-map-display-using-default () "Display the MIME object at point using the `default' face." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-display-body-as-text)) ;;;###autoload (defun vm-mime-reader-map-display-object-as-type () "Display the MIME object at point as some other type." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-display-object-as-type)) ;;;###autoload (defun vm-mime-reader-map-convert-then-display () "Convert the MIME object at point to text and display it." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-convert-body-then-display)) ;;;###autoload (defun vm-mime-reader-map-attach-to-composition () "Attach the MIME object at point to a message being composed. The buffer for message composition is queried from the minibufer." (interactive) (vm-mime-run-display-function-at-point 'vm-mime-attach-body-to-composition)) ;;---------------------------------------------------------------------------- ;;; MIME-related commands ;; ;; vm-mime-action-on-all-attachments : ;; (int, ((message, layout, type, filename) -> void), ;; &optional type list, type list, message list, bool) ;; -> void ;; This function is replaced by the following, but interface retained ;; for backward-compatibility. ;; ;; vm-mime-operate-on-attachments : ;; (int, :action ((message, layout, type, filename) -> void), ;; :included type list, :excluded type list, ;; :messages message list, :name string) ;; -> void ;;---------------------------------------------------------------------------- ;;;###autoload (defun* vm-mime-operate-on-attachments (count &key ((:name action-name)) ((:action action)) ((:included types)) ((:excluded exceptions)) ((:messages mlist))) "On the next COUNT messages or marked messages, call the function ACTION on all \"attachments\". For the purpose of this function, an \"attachment\" is a mime part part which has \"attachment\" as its disposition, or simply has an associated filename, or has a type that matches a regexp in TYPES but doesn't match one in EXCEPTIONS. ACTION-NAME should be a human-readable string describing the action in minibuffer messages. Or it can be nil to suppress messages. ACTION will get called with four arguments: MSG LAYOUT TYPE FILENAME." (unless mlist (unless count (setq count 1)) (vm-check-for-killed-folder) (vm-select-folder-buffer-and-validate 1 nil)) (let ((mlist (or mlist (vm-select-operable-messages count (vm-interactive-p) "Action on")))) (vm-retrieve-operable-messages count mlist) (save-excursion (while mlist (let (m parts layout filename type disposition o) (setq o (vm-mm-layout (car mlist))) (when (stringp o) (setq o 'none) (backtrace) (vm-inform 0 "There is a bug, please report it with *backtrace*")) (unless (eq o 'none) (setq type (car (vm-mm-layout-type o))) (cond ((or (vm-mime-types-match "multipart/alternative" type) (vm-mime-types-match "multipart/mixed" type) (vm-mime-types-match "multipart/report" type) (vm-mime-types-match "message/rfc822" type) ) (setq parts (copy-sequence (vm-mm-layout-parts o)))) (t (setq parts (list o)))) (while parts (while (vm-mime-composite-type-p (car (vm-mm-layout-type (car parts)))) (setq parts (nconc (copy-sequence (vm-mm-layout-parts (car parts))) (cdr parts)))) (setq layout (car parts) type (car (vm-mm-layout-type layout)) disposition (car (vm-mm-layout-disposition layout)) filename (vm-mime-get-disposition-filename layout) ) (cond ((or filename (and disposition (string= disposition "attachment")) (and (not (vm-mime-types-match "message/external-body" type)) types (vm-mime-is-type-valid type types exceptions))) (when action-name (vm-inform 10 "%s part type=%s filename=%s disposition=%s" action-name type filename disposition)) (funcall action (car mlist) layout type filename)) (action-name (vm-inform 10 "No %s on part type=%s filename=%s disposition=%s" action-name type filename disposition))) (setq parts (cdr parts))))) (setq mlist (cdr mlist)))))) ;;;###autoload (defun vm-mime-action-on-all-attachments (count action &optional types exceptions mlist quiet) "On the next COUNT messages or marked messages, call the function ACTION on all \"attachments\". For the purpose of this function, an \"attachment\" is a mime part part which has \"attachment\" as its disposition, or simply has an associated filename, or has a type that matches a regexp in TYPES but doesn't match one in EXCEPTIONS. If QUIET is true no messages are generated. ACTION will get called with four arguments: MSG LAYOUT TYPE FILENAME." (vm-mime-operate-on-attachments count :action action :included types :excluded exceptions :messages mlist :name (if quiet nil "action on"))) (defun vm-mime-is-type-valid (type types-alist type-exceptions) (catch 'done (let ((list type-exceptions) (matched nil)) (while list (if (vm-mime-types-match (car list) type) (throw 'done nil) (setq list (cdr list)))) (setq list types-alist) (while (and list (not matched)) (if (vm-mime-types-match (car list) type) (setq matched t) (setq list (cdr list)))) matched ))) ;;;###autoload (defun vm-delete-all-attachments (&optional count) "Delete all attachments from the next COUNT messages or marked messages. For the purpose of this function, an \"attachment\" is a mime part part which has \"attachment\" as its disposition or simply has an associated filename. Any mime types that match `vm-mime-deleteable-types' but not `vm-mime-deleteable-type-exceptions' are also included." (interactive "p") (vm-check-for-killed-summary) (if (vm-interactive-p) (vm-follow-summary-cursor)) (let ((successes 0)) (vm-mime-operate-on-attachments count :name "deleting" :action (lambda (msg layout type file) (vm-inform 7 "Deleting `%s%s" type (if file (format " (%s)" file) "")) (vm-mime-discard-layout-contents layout) (setq successes (+ 1 successes))) :included vm-mime-deleteable-types :excluded vm-mime-deleteable-type-exceptions) (when (vm-interactive-p) (vm-discard-cached-data count) (let ((vm-preview-lines nil)) (vm-present-current-message))) (if (> successes 0) (vm-inform 5 "%d attachment%s deleted" successes (if (= successes 1) "" "s")) (vm-inform 5 "No attachments deleted"))) (vm-update-summary-and-mode-line)) ;; (define-obsolete-function-alias 'vm-mime-delete-all-attachments ;; 'vm-delete-all-attachments "8.2.0") (defalias 'vm-mime-delete-all-attachments 'vm-delete-all-attachments) (make-obsolete 'vm-mime-delete-all-attachments 'vm-delete-all-attachments "8.2.0") ;;;###autoload (defun vm-save-all-attachments (&optional count directory no-delete-after-saving) "Save all attachments in the next COUNT messages or marked messages. For the purpose of this function, an \"attachment\" is a mime part part which has \"attachment\" as its disposition or simply has an associated filename. Any mime types that match `vm-mime-saveable-types' but not `vm-mime-saveable-type-exceptions' are also included. The attachments are saved to the specified DIRECTORY. The variables `vm-all-attachments-directory' or `vm-mime-attachment-save-directory' can be used to set the default location. When directory does not exist it will be created." (interactive (list current-prefix-arg (vm-read-file-name "Attachment directory: " (or vm-mime-all-attachments-directory vm-mime-attachment-save-directory default-directory) (or vm-mime-all-attachments-directory vm-mime-attachment-save-directory default-directory) nil nil vm-mime-save-all-attachments-history))) (vm-check-for-killed-summary) (if (vm-interactive-p) (vm-follow-summary-cursor)) (let ((successes 0) (failures 0) (result nil)) (vm-mime-operate-on-attachments count :name "saving" :included vm-mime-saveable-types :excluded vm-mime-saveable-type-exceptions :action (lambda (msg layout type file) (let ((directory (if (functionp directory) (funcall directory msg) directory))) (setq file (if file (expand-file-name (file-name-nondirectory file) directory) (vm-read-file-name (format "Save %s to file: " type) (or directory vm-mime-all-attachments-directory vm-mime-attachment-save-directory) (or directory vm-mime-all-attachments-directory vm-mime-attachment-save-directory) nil nil vm-mime-save-all-attachments-history) )) (if (and file (file-exists-p file)) (if (y-or-n-p (format "Overwrite `%s'? " file)) (delete-file file) (setq file nil))) (if (null file) (setq failures (+ 1 failures)) (vm-inform 5 "Saving %s" (if file (format " (%s)" file) "")) (make-directory (file-name-directory file) t) (setq result (vm-mime-send-body-to-file layout file file)) (when result (when vm-mime-delete-after-saving (let ((vm-mime-confirm-delete nil)) (vm-mime-discard-layout-contents layout (expand-file-name file)))) (setq successes (+ 1 successes)))))) ) (when (vm-interactive-p) (vm-discard-cached-data count) (let ((vm-preview-lines nil)) (vm-present-current-message))) (if (> failures 0) (if (> successes 0) (vm-inform 5 "%d attachment%s saved; %s failed" successes (if (= successes 1) "" "s") failures) (vm-inform 5 "No attachments saved; %s failed" failures)) (if (> successes 0) (vm-inform 5 "%d attachment%s saved" successes (if (= successes 1) "" "s")) (vm-inform 5 "No attachments saved"))))) ;; (define-obsolete-function-alias 'vm-mime-save-all-attachments ;; 'vm-save-all-attachments "8.2.0") (defalias 'vm-mime-save-all-attachments 'vm-save-all-attachments) (make-obsolete 'vm-mime-save-all-attachments 'vm-save-all-attachments "8.2.0") (defun vm-save-attachments (&optional count no-delete-after-saving) "Save all attachments in the next COUNT messages or marked messages. For the purpose of this function, an \"attachment\" is a mime part part which has \"attachment\" as its disposition or simply has an associated filename. Any mime types that match `vm-mime-saveable-types' but not `vm-mime-saveable-type-exceptions' are also included. The attachments are saved in file names input from the minibuffer. (This is the main difference from `vm-save-all-attachments'.) The variables `vm-all-attachments-directory' or `vm-mime-attachment-save-directory' can be used to set the default location. When directory does not exist it will be confirmed before creating a new directory." (interactive "p") (vm-check-for-killed-summary) (if (vm-interactive-p) (vm-follow-summary-cursor)) (let ((successes 0) (failures 0) (directory nil)) (vm-mime-operate-on-attachments count :included vm-mime-saveable-types :excluded vm-mime-saveable-type-exceptions :name "saving" :action (lambda (msg layout type file-name) (let ((file (vm-read-file-name (if file-name ; prompt (format "Save (default %s): " file-name) (format "Save %s: " type)) (file-name-as-directory ; directory (or directory vm-mime-attachment-save-directory vm-mime-all-attachments-directory)) (and file-name ; default-filename (concat (file-name-as-directory (or directory vm-mime-attachment-save-directory vm-mime-all-attachments-directory)) (or file-name ""))) nil nil ; mustmatch initial vm-mime-save-all-attachments-history ; predicate ))) (setq directory (file-name-directory file)) (when (file-exists-p file) (if (y-or-n-p (format "Overwrite `%s'? " file)) nil ; (delete-file file) (setq file nil))) (unless (file-exists-p directory) (if (y-or-n-p (format "Directory %s does not exist; create it?" directory)) (make-directory directory t) (setq file nil))) (if (null file) (setq failures (+ 1 failures)) (vm-inform 5 "Saving %s" (if file (format " (%s)" file) "")) (vm-mime-send-body-to-file layout file file) (if vm-mime-delete-after-saving (let ((vm-mime-confirm-delete nil)) (vm-mime-discard-layout-contents layout (expand-file-name file)))) (setq successes (+ 1 successes))))) ) (when (vm-interactive-p) (vm-discard-cached-data count) (vm-present-current-message)) (if (> failures 0) (if (> successes 0) (vm-inform 5 "%d attachment%s saved; %s failed" successes (if (= successes 1) "" "s") failures) (vm-inform 5 "No attachments saved; %s failed" failures)) (if (> successes 0) (vm-inform 5 "%d attachment%s saved" successes (if (= successes 1) "" "s")) (vm-inform 5 "No attachments saved"))))) ;; for the karking compiler (defvar vm-menu-mime-dispose-menu) (defun vm-mime-set-image-stamp-for-type (e type) "Set an image stamp for MIME button extent E as appropriate for TYPE. USR, 2011-03-25" (cond (vm-xemacs-p (vm-mime-xemacs-set-image-stamp-for-type e type)) (vm-fsfemacs-p (vm-mime-fsfemacs-set-image-stamp-for-type e type)))) (defconst vm-mime-type-images '(("text" "text.xpm") ("image" "image.xpm") ("audio" "audio.xpm") ("video" "video.xpm") ("message" "message.xpm") ("application" "application.xpm") ("multipart" "multipart.xpm"))) (defun vm-mime-xemacs-set-image-stamp-for-type (e type) "Set an image stamp for MIME button extent E as appropriate for TYPE. USR, 2011-03-25" (if (and (vm-images-possible-here-p) (vm-image-type-available-p 'xpm) (> (device-bitplanes) 7)) (let ((dir (vm-image-directory)) (tuples vm-mime-type-images) glyph file sym p) (setq file (catch 'done (while tuples (if (vm-mime-types-match (car (car tuples)) type) (throw 'done (car tuples)) (setq tuples (cdr tuples)))) nil) file (and file (nth 1 file)) sym (and file (intern file vm-image-obarray)) glyph (and sym (boundp sym) (symbol-value sym)) glyph (or glyph (and file (make-glyph (list (vector 'xpm ':file (expand-file-name file dir)) [nothing]))))) (and sym (not (boundp sym)) (set sym glyph)) (and glyph (set-extent-begin-glyph e glyph))))) (defun vm-mime-fsfemacs-set-image-stamp-for-type (e type) "Set an image stamp for MIME button extent E as appropriate for TYPE. This is done by extending the extent with one character position at the front and placing the image there as the display text property. USR, 2011-03-25" (if (and (vm-images-possible-here-p) (vm-image-type-available-p 'xpm)) (let ((dir (vm-image-directory)) (tuples vm-mime-type-images) file) (setq file (catch 'done (while tuples (if (vm-mime-types-match (car (car tuples)) type) (throw 'done (car tuples)) (setq tuples (cdr tuples)))) nil) file (and file (nth 1 file)) file (and file (expand-file-name file dir))) (if file (save-excursion (let ((buffer-read-only nil)) (set-buffer (overlay-buffer e)) (goto-char (overlay-start e)) (insert "x") (move-overlay e (1- (point)) (overlay-end e)) (put-text-property (1- (point)) (point) 'display (list 'image ':ascent 80 ':color-symbols (list (cons "background" (cdr (assq 'background-color (frame-parameters))))) ':type 'xpm ':file file)))))))) (defun* vm-mime-insert-button (&key caption action layout (disposable nil)) "Display a button for a mime object, using CAPTION as the label (a string) and ACTION as the default action (a function). The mime object is described by LAYOUT. If DISPOSABLE is true, then the button will be removed when it is expanded to display the mime object." (let ((start (point)) e (keymap vm-mime-reader-map) (buffer-read-only nil)) (if (fboundp 'set-keymap-parents) (if (current-local-map) (set-keymap-parents keymap (list (current-local-map)))) (setq keymap (append keymap (current-local-map)))) (if (not (bolp)) (insert "\n")) (insert caption "\n") ;; we must use the same interface that the vm-extent functions ;; use. if they use overlays, then we call make-overlay. (if vm-fsfemacs-p ;; we MUST have the five arg make-overlay. overlays must ;; advance when text is inserted at their start position or ;; inline text and graphics will seep into the button ;; overlay and then be removed when the button is removed. (setq e (vm-make-extent start (point) nil t nil)) (setq e (vm-make-extent start (point))) (vm-set-extent-property e 'start-open t) (vm-set-extent-property e 'end-open t)) (vm-mime-set-image-stamp-for-type e (car (vm-mm-layout-type layout))) (when vm-fsfemacs-p (vm-set-extent-property e 'local-map keymap)) (when vm-xemacs-p (vm-set-extent-property e 'highlight t) (vm-set-extent-property e 'keymap keymap) (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help)) ;; for all (vm-set-extent-property e 'vm-button t) (vm-set-extent-property e 'vm-mime-disposable disposable) (vm-set-extent-property e 'face vm-mime-button-face) (vm-set-extent-property e 'mouse-face vm-mime-button-mouse-face) (vm-set-extent-property e 'vm-mime-layout layout) (vm-set-extent-property e 'vm-mime-function action) ;; for vm-continue-postponed-message (when vm-xemacs-p (vm-set-extent-property e 'duplicable t)) (when vm-fsfemacs-p (put-text-property (overlay-start e) (overlay-end e) 'vm-mime-layout layout)) ;; return t as decoding worked t)) (defun vm-mime-rewrite-failed-button (button error-string) (let* ((buffer-read-only nil) (start (point))) (goto-char (vm-extent-start-position button)) (insert (format "DISPLAY FAILED -- %s\n" error-string)) (vm-set-extent-endpoints button start (vm-extent-end-position button)) (delete-region (point) (vm-extent-end-position button)))) ;;--------------------------------------------------------------------------- ;;; MIME button operations ;; ;; vm-mime-send-body-to-file: (extent-or-layout ;; &optional filename filepath bool) -> filename ;; vm-mime-send-body-to-folder: (extent-or-layout ;; &optional filename) -> filename ;; vm-mime-delete-body-after-saving: (extent) -> void ;; vm-mime-pipe-body-to-queried-command: (extent &optional bool) -> bool ;; vm-mime-pipe-body-to-queried-command-discard-output: (extent) -> bool ;; vm-mime-send-body-to-printer: (extent) -> bool ;; vm-mime-display-body-as-text: (extent) -> ? ;; vm-mime-display-object-as-type: (extent) -> ? ;; vm-mime-display-body-using-external-viewer: (extent) -> ? ;; vm-mime-convert-body-then-display: (extent) -> ? ;; vm-mime-attach-body-to-composition: (extent) -> ? ;;--------------------------------------------------------------------------- ;; From: Eric E. Dors ;; Date: 1999/04/01 ;; Newsgroups: gnu.emacs.vm.info ;; example filter-alist variable (defvar vm-mime-write-file-filter-alist '(("application/mac-binhex40" . "hexbin -s ")) "*A list of filter used when writing attachements to files." ) ;; function to parse vm-mime-write-file-filter-alist (defun vm-mime-find-write-filter (type) (let ((e-alist vm-mime-write-file-filter-alist) (matched nil)) (while (and e-alist (not matched)) (if (and (vm-mime-types-match (car (car e-alist)) type) (cdr (car e-alist))) (setq matched (cdr (car e-alist))) (setq e-alist (cdr e-alist)))) matched)) (defun vm-mime-delete-body-after-saving (layout file) (unless (vectorp layout) (setq layout (vm-extent-property layout 'vm-mime-layout))) (unless (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (let ((vm-mime-confirm-delete nil)) ;; we don't care if the delete fails (condition-case nil (vm-delete-mime-object (expand-file-name file)) (error nil))))) (defun vm-mime-send-body-to-file (layout &optional default-filename file overwrite) "Writes the body of MIME object given by LAYOUT to FILE. Returns boolean value indicating success or failure. The optional argument DEFAULT-FILENAME gives the default filename to be used if FILE is not specified. OVERWRITE says whether any existing file with the name should be overwritten." (unless (vectorp layout) (setq layout (vm-extent-property layout 'vm-mime-layout))) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (setq layout (car (vm-mm-layout-parts layout)))) (unless default-filename (setq default-filename (vm-mime-get-disposition-filename layout))) (when default-filename (setq default-filename (file-name-nondirectory default-filename))) (let (;; evade the XEmacs dialog box, yeccch. (use-dialog-box nil) (dir vm-mime-attachment-save-directory) (done nil)) (unless file (while (not done) (setq file (read-file-name (if default-filename (format "Write MIME body to file (default %s): " default-filename) "Write MIME body to file: ") dir default-filename) file (expand-file-name file dir)) (if (not (file-directory-p file)) (setq done t) (unless default-filename (error "%s is a directory" file)) (setq file (expand-file-name default-filename file) done t)))) (let ((work-buffer (vm-make-work-buffer)) (coding-system-for-read (vm-binary-coding-system))) (unwind-protect (condition-case err (with-current-buffer work-buffer (setq selective-display nil) ;; Tell DOS/Windows NT whether the file is binary (setq buffer-file-type (not (vm-mime-text-type-layout-p layout))) ;; Tell XEmacs/MULE not to mess with the bits unless ;; this is a text type. (if (fboundp 'set-buffer-file-coding-system) (if (vm-mime-text-type-layout-p layout) (set-buffer-file-coding-system (vm-line-ending-coding-system) nil) (set-buffer-file-coding-system (vm-binary-coding-system) t))) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (unless (or overwrite (not (file-exists-p file))) (or (y-or-n-p "File exists, overwrite? ") (error "Aborted"))) ;; Bind the jka-compr-compression-info-list to nil so ;; that jka-compr won't compress already compressed ;; data. This is a crock, but as usual I'm getting ;; the bug reports for somebody else's bad code. (let ((jka-compr-compression-info-list nil) (command (vm-mime-find-write-filter (car (vm-mm-layout-type layout))))) (if command (shell-command-on-region (point-min) (point-max) (concat command " > " file)) (write-region (point-min) (point-max) file nil nil))) file ) (error (vm-warn 1 2 "Error in writing %s: %s" file err) nil)) (when work-buffer (kill-buffer work-buffer)))))) (defun vm-mime-send-body-to-folder (layout &optional default-filename) (unless (vectorp layout) (setq layout (vm-extent-property layout 'vm-mime-layout))) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (setq layout (car (vm-mm-layout-parts layout)))) (let ((type (car (vm-mm-layout-type layout))) file) (if (not (or (vm-mime-types-match type "message/rfc822") (vm-mime-types-match type "message/news"))) (vm-mime-send-body-to-file layout default-filename) (let ((work-buffer (vm-make-work-buffer)) (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system))) (unwind-protect (with-current-buffer work-buffer (setq selective-display nil) ;; Tell DOS/Windows NT whether the file is binary (setq buffer-file-type t) ;; Tell XEmacs/MULE not to mess with the bits unless ;; this is a text type. (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-line-ending-coding-system) nil)) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (goto-char (point-min)) (insert (vm-leading-message-separator 'mmdf)) (goto-char (point-max)) (insert (vm-trailing-message-separator 'mmdf)) (set-buffer-modified-p nil) (vm-mode t) (let ((vm-check-folder-types t) (vm-convert-folder-types t)) (setq file (call-interactively 'vm-save-message))) (vm-quit-no-change) file ) (when work-buffer (kill-buffer work-buffer))))))) (defun vm-mime-pipe-body-to-command (command layout &optional discard-output) (unless (vectorp layout) (setq layout (vm-extent-property layout 'vm-mime-layout))) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (setq layout (car (vm-mm-layout-parts layout)))) (let ((output-buffer (if discard-output 0 (get-buffer-create "*Shell Command Output*")))) (when (bufferp output-buffer) (with-current-buffer output-buffer (erase-buffer))) (let ((work-buffer (vm-make-work-buffer))) (unwind-protect (with-current-buffer work-buffer ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) (process-coding-system-alist (if (vm-mime-text-type-layout-p layout) nil (list (cons "." (vm-binary-coding-system))))) ;; Tell DOS/Windows NT whether the input is binary (binary-process-input (not (vm-mime-text-type-layout-p layout)))) (call-process-region (point-min) (point-max) (or shell-file-name "sh") nil output-buffer nil shell-command-switch command))) (when work-buffer (kill-buffer work-buffer)))) (when (bufferp output-buffer) (if (not (zerop (with-current-buffer output-buffer (buffer-size)))) (vm-display output-buffer t (list this-command) '(vm-pipe-message-to-command)) (vm-display nil nil (list this-command) '(vm-pipe-message-to-command)))) t )) (defun vm-mime-pipe-body-to-queried-command (button &optional discard-output) (let ((command (read-string "Pipe object to command: "))) (vm-mime-pipe-body-to-command command button discard-output))) (defun vm-mime-pipe-body-to-queried-command-discard-output (button) (vm-mime-pipe-body-to-queried-command button t)) (defun vm-mime-send-body-to-printer (button) (vm-mime-pipe-body-to-command (mapconcat (function identity) (nconc (list vm-print-command) vm-print-command-switches) " ") button)) (defun vm-mime-display-body-as-text (button) (let ((vm-mime-auto-displayed-content-types '("text/plain")) (vm-mime-auto-displayed-content-type-exceptions nil) (layout (copy-sequence (vm-extent-property button 'vm-mime-layout)))) (vm-set-extent-property button 'vm-mime-disposable t) (vm-set-extent-property button 'vm-mime-layout layout) ;; not universally correct, but close enough. (vm-set-mm-layout-type layout '("text/plain" "charset=us-ascii")) (goto-char (vm-extent-start-position button)) (vm-decode-mime-layout button t))) (defun vm-mime-display-object-as-type (button) (let ((vm-mime-auto-displayed-content-types t) (vm-mime-auto-displayed-content-type-exceptions nil) (old-layout (vm-extent-property button 'vm-mime-layout)) layout (type (read-string "View as MIME type: "))) (setq layout (copy-sequence old-layout)) (vm-set-extent-property button 'vm-mime-layout layout) ;; not universally correct, but close enough. (setcar (vm-mm-layout-type layout) type) (goto-char (vm-extent-start-position button)) (vm-decode-mime-layout button t))) (defun vm-mime-display-body-using-external-viewer (button) (let ((layout (vm-extent-property button 'vm-mime-layout)) (vm-mime-external-content-type-exceptions nil)) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (if (vm-mm-layout-display-error layout) (apply 'error (vm-mm-layout-display-error layout))) ;; Use the child layout for external viewer (setq layout (car (vm-mm-layout-parts layout)))) (if (vm-mime-find-external-viewer (car (vm-mm-layout-type layout))) (vm-mime-display-external-generic layout) (error "No viewer defined for type %s" (car (vm-mm-layout-type layout)))))) (defun vm-mime-convert-body-then-display (button) (let ((layout (vm-extent-property button 'vm-mime-layout))) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (if (vm-mm-layout-display-error layout) (apply 'error (vm-mm-layout-display-error layout))) (setq layout (car (vm-mm-layout-parts layout)))) (setq layout (vm-mime-convert-undisplayable-layout layout)) (if (vm-mm-layout-display-error layout) (apply 'error (vm-mm-layout-display-error layout))) (if (null layout) nil (vm-set-extent-property button 'vm-mime-disposable t) (vm-set-extent-property button 'vm-mime-layout layout) (goto-char (vm-extent-start-position button)) (vm-decode-mime-layout button t)))) (defun vm-mime-attach-body-to-composition (button) (let ((layout (vm-extent-property button 'vm-mime-layout)) (vm-mime-external-content-type-exceptions nil)) (goto-char (vm-extent-start-position button)) (when (vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (vm-mime-fetch-message/external-body layout) (setq layout (car (vm-mm-layout-parts layout)))) (vm-attach-object-to-composition layout))) (defun vm-mime-get-button-layout () "Return the MIME layout of the MIME button at point. USR, 2011-03-07" (vm-mime-run-display-function-at-point (function (lambda (extent) (vm-extent-property extent 'vm-mime-layout))))) (defun vm-mime-scrub-description (string) (let ((work-buffer nil)) (save-excursion (unwind-protect (progn (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert string) (while (re-search-forward "[ \t\n]+" nil t) (replace-match " ")) (buffer-string)) (and work-buffer (kill-buffer work-buffer)))))) ;; unused ;;(defun vm-mime-layout-description (layout) ;; (let ((type (car (vm-mm-layout-type layout))) ;; description name) ;; (setq description ;; (if (vm-mm-layout-description layout) ;; (vm-mime-scrub-description (vm-mm-layout-description layout)))) ;; (concat ;; (if description description "") ;; (if description ", " "") ;; (cond ((vm-mime-types-match "multipart/digest" type) ;; (let ((n (length (vm-mm-layout-parts layout)))) ;; (format "digest (%d message%s)" n (if (= n 1) "" "s")))) ;; ((vm-mime-types-match "multipart/alternative" type) ;; "multipart alternative") ;; ((vm-mime-types-match "multipart" type) ;; (let ((n (length (vm-mm-layout-parts layout)))) ;; (format "multipart message (%d part%s)" n (if (= n 1) "" "s")))) ;; ((vm-mime-types-match "text/plain" type) ;; (format "plain text%s" ;; (let ((charset (vm-mime-get-parameter layout "charset"))) ;; (if charset ;; (concat ", " charset) ;; "")))) ;; ((vm-mime-types-match "text/enriched" type) ;; "enriched text") ;; ((vm-mime-types-match "text/html" type) ;; "HTML") ;; ((vm-mime-types-match "image/gif" type) ;; "GIF image") ;; ((vm-mime-types-match "image/jpeg" type) ;; "JPEG image") ;; ((and (vm-mime-types-match "application/octet-stream" type) ;; (setq name (vm-mime-get-parameter layout "name")) ;; (save-match-data (not (string-match "^[ \t]*$" name)))) ;; name) ;; (t type))))) (defun vm-mime-layout-contains-type (layout type) (if (vm-mime-types-match type (car (vm-mm-layout-type layout))) layout (let ((p (vm-mm-layout-parts layout)) (result nil) (done nil)) (while (and p (not done)) (if (setq result (vm-mime-layout-contains-type (car p) type)) (setq done t) (setq p (cdr p)))) result ))) ;; breadth first traversal (defun vm-mime-find-digests-in-layout (layout) (let ((layout-list (list layout)) layout-type (result nil)) (while layout-list (setq layout-type (car (vm-mm-layout-type (car layout-list)))) (cond ((string-match "^multipart/digest\\|message/\\(rfc822\\|news\\)" layout-type) (setq result (nconc result (list (car layout-list))))) ((vm-mime-composite-type-p layout-type) (setq layout-list (nconc layout-list (copy-sequence (vm-mm-layout-parts (car layout-list))))))) (setq layout-list (cdr layout-list))) result )) (defun vm-mime-plain-message-p (m) "A message M is considered plain if - it does not have encoded headers, and - - it does not have a MIME layout, or - - it has a text/plain component as its first element with ASCII - - character set and unibyte encoding (7bit, 8bit or binary). Returns non-NIL value M is a plain message." (save-match-data (let ((o (vm-mm-layout m)) (case-fold-search t)) (and (eq (vm-mm-encoded-header m) 'none) (or (not (vectorp o)) (and (vm-mime-types-match "text/plain" (car (vm-mm-layout-type o))) (string-match "^us-ascii$" (or (vm-mime-get-parameter o "charset") "us-ascii")) (string-match "^\\(7bit\\|8bit\\|binary\\)$" (vm-mm-layout-encoding o)))))))) (defun vm-mime-text-type-p (type) (let ((case-fold-search t)) (or (string-match "^text/" type) (string-match "^message/" type)))) (defun vm-mime-text-type-layout-p (layout) (or (vm-mime-types-match "text" (car (vm-mm-layout-type layout))) (vm-mime-types-match "message" (car (vm-mm-layout-type layout))))) (defun vm-mime-tty-can-display-mime-charset (name) "Can the current TTY correctly display the given MIME character set?" (and (fboundp 'console-tty-output-coding-system) ;; Is this check too paranoid? (vm-coding-system-p (console-tty-output-coding-system)) (fboundp 'coding-system-get) (let ;; Nnngh, latin-unity-base-name isn't doing the right thing for ;; me with MULE-UCS and UTF-8 as the terminal coding system. Of ;; course, it's not evident that it _can_ do the right thing. ;; ;; The intention is that ourtermcs is the version of the ;; coding-system without line-ending information attached to its ;; end. ((ourtermcs (vm-coding-system-name (or (car (coding-system-get (console-tty-output-coding-system) 'alias-coding-systems)) (coding-system-base (console-tty-output-coding-system)))))) (or (eq ourtermcs (vm-mime-charset-to-coding name)) ;; The vm-mime-mule-charset-to-coding-alist check is to make ;; sure it does the right thing with a nonsense MIME character ;; set name. (and (memq ourtermcs (vm-get-mime-ucs-list)) (vm-mime-charset-to-coding name) t) (vm-mime-default-face-charset-p name))))) (defun vm-mime-charset-internally-displayable-p (name) "Can the given MIME charset be displayed within emacs by VM?" (cond ((and vm-xemacs-mule-p (memq (vm-device-type) '(x gtk mswindows))) (or (vm-mime-charset-to-coding name) (vm-mime-default-face-charset-p name))) ;; vm-mime-tty-can-display-mime-charset (called below) fails ;; for GNU Emacs. So keep things simple, since there's no harm ;; if replacement characters are displayed. (vm-fsfemacs-mule-p) ((vm-multiple-fonts-possible-p) (or (vm-mime-default-face-charset-p name) (vm-string-assoc name vm-mime-charset-font-alist))) ;; If the terminal-coding-system variable is set to something that ;; can encode all the characters of the given MIME character set, ;; then we can display any message in the given MIME character set ;; internally. ((vm-mime-tty-can-display-mime-charset name)) (t (vm-mime-default-face-charset-p name)))) (defun vm-mime-default-face-charset-p (charset) (and (or (eq vm-mime-default-face-charsets t) (and (consp vm-mime-default-face-charsets) (vm-string-member charset vm-mime-default-face-charsets))) (not (vm-string-member charset vm-mime-default-face-charset-exceptions)))) (defun vm-mime-find-message/partials (layout id) (let ((list nil) (type (vm-mm-layout-type layout))) (cond ((vm-mime-composite-type-p (car (vm-mm-layout-type layout))) (let ((parts (vm-mm-layout-parts layout)) o) (while parts (setq o (vm-mime-find-message/partials (car parts) id)) (if o (setq list (nconc o list))) (setq parts (cdr parts))))) ((vm-mime-types-match "message/partial" (car type)) (if (equal (vm-mime-get-parameter layout "id") id) (setq list (cons layout list))))) list )) (defun vm-mime-find-leaf-content-id-in-layout-folder (layout id) (save-excursion (save-restriction (let (m (o nil)) (set-buffer (vm-buffer-of (vm-real-message-of (vm-mm-layout-message layout)))) (widen) (goto-char (point-min)) (while (and (search-forward id nil t) (setq m (vm-message-at-point))) (setq o (vm-mm-layout m)) (if (not (vectorp o)) nil (setq o (vm-mime-find-leaf-content-id o id)) (if (null o) nil ;; if we found it, end the search loop (goto-char (point-max))))) o )))) (defun vm-mime-find-leaf-content-id (layout id) (let ((list nil) (type (vm-mm-layout-type layout))) (catch 'done (cond ((vm-mime-composite-type-p (car (vm-mm-layout-type layout))) (let ((parts (vm-mm-layout-parts layout)) o) (while parts (setq o (vm-mime-find-leaf-content-id (car parts) id)) (if o (throw 'done o)) (setq parts (cdr parts))))) (t (if (equal (vm-mm-layout-id layout) id) (throw 'done layout))))))) (defun vm-message-at-point () (let ((mp vm-message-list) (point (point)) (done nil)) (while (and mp (not done)) (if (and (>= point (vm-start-of (car mp))) (<= point (vm-end-of (car mp)))) (setq done t) (setq mp (cdr mp)))) (car mp))) (defun vm-mime-make-multipart-boundary () (let ((boundary (make-string 10 ?a)) (i 0)) (random t) (while (< i (length boundary)) (aset boundary i (aref vm-mime-base64-alphabet (% (vm-abs (lsh (random) -8)) (length vm-mime-base64-alphabet)))) (vm-increment i)) boundary )) (defun vm-mime-extract-filename-suffix (layout) (let ((filename (vm-mime-get-disposition-filename layout)) (suffix nil) i) (if (and filename (string-match "\\.[^.]+$" filename)) (setq suffix (substring filename (match-beginning 0) (match-end 0)))) suffix )) (defun vm-mime-find-filename-suffix-for-type (layout) (let ((type (car (vm-mm-layout-type layout))) suffix (alist vm-mime-attachment-auto-suffix-alist)) (while alist (if (vm-mime-types-match (car (car alist)) type) (setq suffix (cdr (car alist)) alist nil) (setq alist (cdr alist)))) suffix )) ;;;###autoload (defun vm-attach-file (file type &optional charset description no-suggested-filename) "Attach a file to a VM composition buffer to be sent along with the message. The file is not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the attachment is placed in the composition buffer. You can move the attachment around or remove it entirely with normal text editing commands. If you remove the attachment tag, the attachment will not be sent. First argument, FILE, is the name of the file to attach. Second argument, TYPE, is the MIME Content-Type of the file. Optional third argument CHARSET is the character set of the attached document. This argument is only used for text types, and it is ignored for other types. Optional fourth argument DESCRIPTION should be a one line description of the file. Nil means include no description. Optional fifth argument NO-SUGGESTED-FILENAME non-nil means that VM should not add a filename to the Content-Disposition header created for the object. When called interactively all arguments are read from the minibuffer. This command is for attaching files that do not have a MIME header section at the top. For files with MIME headers, you should use `vm-attach-mime-file' to attach such a file. VM will extract the content type information from the headers in this case and not prompt you for it in the minibuffer." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command) (completion-ignored-extensions nil) (charset nil) description file default-type type) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (setq file (vm-read-file-name "Attach file: " vm-mime-attachment-source-directory nil t) default-type (or (vm-mime-default-type-from-filename file) "application/octet-stream") type (completing-read (format "Content type (default %s): " default-type) vm-mime-type-completion-alist) type (if (> (length type) 0) type default-type)) (when (vm-mime-types-match "text" type) (setq charset (completing-read "Character set (default US-ASCII): " vm-mime-charset-completion-alist) charset (if (> (length charset) 0) charset))) (setq description (read-string "One line description: ")) (when (string-match "^[ \t]*$" description) (setq description nil)) (list file type charset description nil))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when (file-directory-p file) (error "%s is a directory, cannot attach" file)) (unless (file-exists-p file) (error "No such file: %s" file)) (unless (file-readable-p file) (error "You don't have permission to read %s" file)) (when charset (setq charset (list (concat "charset=" charset)))) (when description (setq description (vm-mime-scrub-description description))) (vm-attach-object file :type type :params charset :description description :mimed nil)) (defalias 'vm-mime-attach-file 'vm-attach-file) ;;;###autoload (defun vm-attach-mime-file (file type) "Attach a MIME encoded file to a VM composition buffer to be sent along with the message. The file is not inserted into the buffer until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the attachment is placed in the composition buffer. You can move the attachment around or remove it entirely with normal text editing commands. If you remove the attachment tag, the attachment will not be sent. The first argument, FILE, is the name of the file to attach. When called interactively the FILE argument is read from the minibuffer. The second argument, TYPE, is the MIME Content-Type of the object. This command is for attaching files that have a MIME header section at the top. For files without MIME headers, you should use `vm-attach-file' to attach the file." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command) file type default-type) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (setq file (vm-read-file-name "Attach file: " vm-mime-attachment-source-directory nil t) default-type (or (vm-mime-default-type-from-filename file) "application/octet-stream") type (completing-read (format "Content type (default %s): " default-type) vm-mime-type-completion-alist) type (if (> (length type) 0) type default-type)) (list file type))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when (file-directory-p file) (error "%s is a directory, cannot attach" file)) (unless (file-exists-p file) (error "No such file: %s" file)) (unless (file-readable-p file) (error "You don't have permission to read %s" file)) (vm-attach-object file :type type :params nil :description nil :mimed t)) (defalias 'vm-mime-attach-mime-file 'vm-attach-mime-file) ;;;###autoload (defun vm-attach-buffer (buffer type &optional charset description) "Attach a buffer to a VM composition buffer to be sent along with the message. The buffer contents are not inserted into the composition buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the attachment is placed in the composition buffer. You can move the attachment around or remove it entirely with normal text editing commands. If you remove the attachment tag, the attachment will not be sent. First argument, BUFFER, is the buffer or name of the buffer to attach. Second argument, TYPE, is the MIME Content-Type of the file. Optional third argument CHARSET is the character set of the attached document. This argument is only used for text types, and it is ignored for other types. Optional fourth argument DESCRIPTION should be a one line description of the file. Nil means include no description. When called interactively all arguments are read from the minibuffer. This command is for attaching files that do not have a MIME header section at the top. For files with MIME headers, you should use `vm-attach-mime-file' to attach such a file. VM will extract the content type information from the headers in this case and not prompt you for it in the minibuffer." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command) (charset nil) description file default-type type buffer buffer-name) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (setq buffer-name (read-buffer "Attach buffer: " nil t) default-type (or (vm-mime-default-type-from-filename buffer-name) "application/octet-stream") type (completing-read (format "Content type (default %s): " default-type) vm-mime-type-completion-alist) type (if (> (length type) 0) type default-type)) (when (vm-mime-types-match "text" type) (setq charset (completing-read "Character set (default US-ASCII): " vm-mime-charset-completion-alist) charset (if (> (length charset) 0) charset))) (setq description (read-string "One line description: ")) (when (string-match "^[ \t]*$" description) (setq description nil)) (list buffer-name type charset description))) (unless (setq buffer (get-buffer buffer)) (error "Buffer %s does not exist." buffer)) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when charset (setq charset (list (concat "charset=" charset)))) (when description (setq description (vm-mime-scrub-description description))) (vm-attach-object buffer :type type :params charset :description description :mimed nil)) (defalias 'vm-mime-attach-buffer 'vm-attach-buffer) ;;;###autoload (defun vm-attach-message (message &optional description) "Attach a message from a VM folder to the current VM composition. The message is not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the attachment is placed in the composition buffer. You can move the attachment around or remove it entirely with normal text editing commands. If you remove the attachment tag, the attachment will not be sent. First argument, MESSAGE, is either a VM message struct or a list of message structs. When called interactively a message number is read from the minibuffer. The message will come from the parent folder of this composition. If the composition has no parent, the name of a folder will be read from the minibuffer before the message number is read. If this command is invoked with a prefix argument, the name of a folder is read and that folder is used instead of the parent folder of the composition. If this command is invoked on marked message (via `vm-next-command-uses-marks') the marked messages in the selected folder will be attached as a MIME message digest. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are attached. Optional second argument DESCRIPTION is a one-line description of the message being attached. This is also read from the minibuffer if the command is run interactively." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command) (result 0) mlist mp default prompt description folder) (unless (eq major-mode 'mail-mode) (error "Command must be used in a VM Mail mode buffer.")) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when current-prefix-arg (setq vm-mail-buffer (vm-read-folder-name) vm-mail-buffer (if (string= vm-mail-buffer "") nil (setq current-prefix-arg nil) (get-buffer vm-mail-buffer)))) (cond ((or current-prefix-arg (null vm-mail-buffer) (not (buffer-live-p vm-mail-buffer))) (let ((dir (if vm-folder-directory (expand-file-name vm-folder-directory) default-directory)) file) (let ((last-command last-command) (this-command this-command)) (setq file (read-file-name "Attach message from folder: " dir nil t))) (let ((coding-system-for-read (vm-binary-coding-system))) (setq folder (find-file-noselect file))) (with-current-buffer folder (vm-mode) (setq mlist (vm-select-operable-messages 1 t "Attach"))))) (t (setq folder vm-mail-buffer) (with-current-buffer folder (setq mlist (vm-select-operable-messages 1 t "Attach"))))) (when (null mlist) (with-current-buffer folder (setq default (and vm-message-pointer (vm-number-of (car vm-message-pointer))) prompt (if default (format "Attach message number: (default %s) " default) "Attach message number: ")) (while (zerop result) (setq result (read-string prompt)) (and (string= result "") default (setq result default)) (setq result (string-to-number result))) (when (null (setq mp (nthcdr (1- result) vm-message-list))) (error "No such message.")))) (setq description (read-string "Description: ")) (when (string-match "^[ \t]*$" description) (setq description nil)) (list (or mlist (car mp)) description))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (cond ((not (consp message)) (vm-attach-message-internal message description)) ((null (cdr message)) (vm-attach-message-internal (car message) description)) (t (vm-attach-message-digest-internal message description)))) (defalias 'vm-mime-attach-message 'vm-attach-message) (defun vm-attach-message-internal (message description) "Attach MESSAGE as a mime object to the current composition. Use DESCRIPTION." (let* ((work-buffer (vm-generate-new-unibyte-buffer "*attached message*")) (m (vm-real-message-of message)) (folder (vm-buffer-of m))) (with-current-buffer work-buffer (vm-insert-region-from-buffer folder (vm-headers-of m) (vm-text-end-of m)) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp vm-internal-unforwarded-header-regexp)) (when description (setq description (vm-mime-scrub-description description))) (vm-attach-object work-buffer :type "message/rfc822" :params nil :disposition '("inline") :description description) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list (list message)) ;; move window point forward so that if this command ;; is used consecutively, the insertions will be in ;; the correct order in the composition buffer. (let ((w (vm-get-buffer-window (current-buffer)))) (when w (set-window-point w (point)))) (add-hook 'kill-buffer-hook `(lambda () (if (eq (current-buffer) ,(current-buffer)) (kill-buffer ,work-buffer)))))) (defun vm-attach-message-digest-internal (mlist description) "Attach MLIST as a mail digest object to the current composition. Use DESCRIPTION." (let ((work-buffer (vm-generate-new-unibyte-buffer "*attached messages*")) boundary) (with-current-buffer work-buffer (setq boundary (vm-mime-encapsulate-messages mlist :keep-list vm-mime-digest-headers :discard-regexp vm-mime-digest-discard-header-regexp :always-use-digest t)) (goto-char (point-min)) (insert "MIME-Version: 1.0\n") (insert "Content-Type: " (vm-mime-type-with-params "multipart/digest" (list (concat "boundary=\"" boundary "\""))) "\n") (insert "Content-Transfer-Encoding: " (vm-determine-proper-content-transfer-encoding (point) (point-max)) "\n\n")) (when description (setq description (vm-mime-scrub-description description))) (vm-attach-object work-buffer :type "multipart/digest" :params (list (concat "boundary=\"" boundary "\"")) :disposition '("inline") :description description :mimed t) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list (copy-sequence mlist)) ;; move window point forward so that if this command ;; is used consecutively, the insertions will be in ;; the correct order in the composition buffer. (let ((w (vm-get-buffer-window (current-buffer)))) (when w (set-window-point w (point)))) (add-hook 'kill-buffer-hook `(lambda () (if (eq (current-buffer) ,(current-buffer)) (kill-buffer ,work-buffer)))))) ;;;###autoload (defun vm-attach-message-to-composition (composition &optional description) "Attach the current message from the current VM folder to a VM composition. The message is not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the attachment is placed in the composition buffer. You can move the attachment around or remove it entirely with normal text editing commands. If you remove the attachment tag, the attachment will not be sent. First argument COMPOSITION is the buffer into which the object will be inserted. When this function is called interactively COMPOSITION's name will be read from the minibuffer. If this command is invoked on marked message (via `vm-next-command-uses-marks') the marked messages in the selected folder will be attached as a MIME message digest. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are attached. Optional second argument DESCRIPTION is a one-line description of the message being attached. This is also read from the minibuffer if the command is run interactively." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command) description) (save-current-buffer (vm-select-folder-buffer-and-validate 1 t) (unless (memq major-mode '(vm-mode vm-virtual-mode)) (error "Command must be used in a VM buffer.")) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (list (read-buffer "Attach object to buffer: " (vm-find-composition-buffer) t) (progn (setq description (read-string "Description: ")) (when (string-match "^[ \t]*$" description) (setq description nil)) description))))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-follow-summary-cursor) (let ((mlist (vm-select-operable-messages 1 t "Attach"))) (when (null mlist) (setq mlist (list (vm-current-message)))) (with-current-buffer composition (if (null (cdr mlist)) ; single message (vm-attach-message-internal (car mlist) description) (vm-attach-message-digest-internal mlist description))))) (defalias 'vm-mime-attach-message-to-composition 'vm-attach-message-to-composition) ;;;###autoload (defun vm-attach-object-to-composition (layout &optional composition) "Attach the mime object described by LAYOUT to a VM composition buffer. The object is not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the object is placed in the composition buffer. You can move the object around or remove it entirely with normal text editing commands. If you remove the object tag, the object will not be sent. The optional argument COMPOSITION is the buffer into which the object will be inserted. When this function is called interactively COMPOSITION's name will be read from the minibuffer." (unless composition (setq composition (read-buffer "Attach object to buffer: " (vm-find-composition-buffer) t))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((work-buffer (vm-make-work-buffer)) buf start w) (unwind-protect (with-current-buffer work-buffer (vm-mime-insert-mime-headers layout) (insert "\n") (setq start (point)) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout start (point-max)) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "Content-Transfer-Encoding:") (insert "Content-Transfer-Encoding: binary\n") (set-buffer composition) ;; FIXME need to copy the disposition from the original (vm-attach-object work-buffer :type (car (vm-mm-layout-type layout)) :params (cdr (vm-mm-layout-type layout)) :description (vm-mm-layout-description layout) :mimed t) ;; move window point forward so that if this command ;; is used consecutively, the insertions will be in ;; the correct order in the composition buffer. (setq w (vm-get-buffer-window composition)) (and w (set-window-point w (point))) (setq buf work-buffer work-buffer nil) ; schedule to be killed later (add-hook 'kill-buffer-hook `(lambda () (if (eq (current-buffer) ,(current-buffer)) (kill-buffer ,buf)))) ) ;; unwind-protection (when work-buffer (kill-buffer work-buffer))))) (defalias 'vm-mime-attach-object-to-composition 'vm-attach-object-to-composition) (defalias 'vm-mime-attach-object-from-message 'vm-attach-object-to-composition) (make-obsolete 'vm-mime-attach-object-from-message 'vm-attach-object-to-composition "8.2.0") (defun* vm-attach-object (object &key type params description (mimed nil) (disposition '("unspecified")) (no-suggested-filename nil)) "Attach a MIME OBJECT to the mail composition in the current buffer. The OBJECT could be: - the full path name of a file - a buffer, or - a list with the elements: buffer, start position, end position, disposition and optional file name. TYPE, PARAMS and DESCRIPTION and DISPOSITION are the standard MIME properties. MIMED says whether the OBJECT already has MIME headers. Optional argument NO-SUGGESTED-FILENAME is a boolean indicating that there is no file name for this object. USR, 2011-03-07" (unless (eq major-mode 'mail-mode) (error "VM internal error: vm-attach-object not in Mail mode buffer.")) (when (vm-mail-mode-get-header-contents "MIME-Version") (error "Can't attach MIME object to already encoded MIME buffer.")) (let (start end e tag-string file-name (fb (list vm-mime-forward-local-external-bodies))) (cond ((and (stringp object) (not mimed)) (if (or (vm-mime-types-match "application" type) (vm-mime-types-match "model" type)) (setq disposition (list "attachment")) (setq disposition (list "inline"))) (unless no-suggested-filename (setq file-name (file-name-nondirectory object)) ;; why fuse things together? USR, 2011-03-17 ;; (setq type ;; (concat type "; name=\"" file-name "\"")) (setq params (list (concat "name=\"" file-name "\""))) (setq disposition (nconc disposition (list (concat "filename=\"" file-name "\"")))))) ((listp object) (setq file-name (nth 4 object)) (setq disposition (nth 3 object))) (t (setq file-name (or (vm-mime-get-xxx-parameter "name" params) (vm-mime-get-xxx-parameter "filename" params))))) (when (< (point) (save-excursion (mail-text) (point))) (mail-text)) (setq start (point)) (setq tag-string (format "[ATTACHMENT %s, %s]" (or file-name description "") (or type "MIME file"))) ;; (if (listp object) ;; (setq tag-string (format "[ATTACHMENT %s, %s]" ;; (or (nth 4 object) "") type)) ;; (setq tag-string (format "[ATTACHMENT %s, %s]" object ;; (or type "MIME file")))) (insert tag-string "\n") (setq end (1- (point))) (cond (vm-fsfemacs-p (put-text-property start end 'front-sticky nil) (put-text-property start end 'rear-nonsticky t) ;; can't be intangible because menu clicking at a position ;; needs to set point inside the tag so that a command can ;; access the text properties there. ;; (put-text-property start end 'intangible object) (put-text-property start end 'face vm-attachment-button-face) (put-text-property start end 'font-lock-face vm-attachment-button-face) (put-text-property start end 'mouse-face vm-attachment-button-mouse-face) (put-text-property start end 'vm-mime-forward-local-refs fb) (put-text-property start end 'vm-mime-type type) (put-text-property start end 'vm-mime-object object) (put-text-property start end 'vm-mime-parameters params) (put-text-property start end 'vm-mime-description description) (put-text-property start end 'vm-mime-disposition disposition) (put-text-property start end 'vm-mime-encoding nil) (put-text-property start end 'vm-mime-encoded mimed) ;; (put-text-property start end 'duplicable t) ) (vm-xemacs-p (setq e (vm-make-extent start end)) (vm-mime-set-image-stamp-for-type e (or type "text/plain")) (vm-set-extent-property e 'start-open t) (vm-set-extent-property e 'face vm-mime-button-face) (vm-set-extent-property e 'mouse-face vm-mime-button-mouse-face) (vm-set-extent-property e 'duplicable t) (let ((keymap (make-sparse-keymap))) (when vm-popup-menu-on-mouse-3 (define-key keymap 'button3 'vm-menu-popup-attachment-menu)) (define-key keymap [return] 'vm-mime-change-content-disposition) (vm-set-extent-property e 'keymap keymap) (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help)) (vm-set-extent-property e 'vm-mime-forward-local-refs fb) (vm-set-extent-property e 'vm-mime-type type) (vm-set-extent-property e 'vm-mime-object object) (vm-set-extent-property e 'vm-mime-parameters params) (vm-set-extent-property e 'vm-mime-description description) (vm-set-extent-property e 'vm-mime-disposition disposition) (vm-set-extent-property e 'vm-mime-encoding nil) (vm-set-extent-property e 'vm-mime-encoded mimed))))) (defalias 'vm-mime-attach-object 'vm-attach-object) (defun vm-mime-attachment-forward-local-refs-at-point () (cond (vm-fsfemacs-p (let ((fb (get-text-property (point) 'vm-mime-forward-local-refs))) (car fb) )) (vm-xemacs-p (let* ((e (vm-extent-at (point) 'vm-mime-type)) (fb (vm-extent-property e 'vm-mime-forward-local-refs))) (car fb) )))) (defun vm-mime-set-attachment-forward-local-refs-at-point (val) (cond (vm-fsfemacs-p (let ((fb (get-text-property (point) 'vm-mime-forward-local-refs))) (setcar fb val) )) (vm-xemacs-p (let* ((e (vm-extent-at (point) 'vm-mime-type)) (fb (vm-extent-property e 'vm-mime-forward-local-refs))) (setcar fb val) )))) (defun vm-mime-delete-attachment-button () (cond (vm-fsfemacs-p ;; TODO ) (vm-xemacs-p (let ((e (vm-extent-at (point) 'vm-mime-type))) (delete-region (vm-extent-start-position e) (vm-extent-end-position e)))))) (defun vm-mime-delete-attachment-button-keep-infos () (cond (vm-fsfemacs-p ;; TODO ) (vm-xemacs-p (let ((e (vm-extent-at (point) 'vm-mime-type))) (save-excursion (goto-char (1+ (vm-extent-start-position e))) (insert " --- DELETED ") (goto-char (vm-extent-end-position e)) (insert " ---") (vm-delete-extent e)))))) ;;;###autoload (defun vm-mime-change-content-disposition () (interactive) (vm-mime-set-attachment-disposition-at-point (intern (completing-read "Disposition-type: " '(("unspecified") ("inline") ("attachment")) nil t)))) (defun vm-mime-attachment-disposition-at-point () (cond (vm-fsfemacs-p (let ((disp (get-text-property (point) 'vm-mime-disposition))) (intern (car disp)))) (vm-xemacs-p (let* ((e (vm-extent-at (point) 'vm-mime-disposition)) (disp (vm-extent-property e 'vm-mime-disposition))) (intern (car disp)))))) (defun vm-mime-set-attachment-disposition-at-point (sym) (cond (vm-fsfemacs-p (let ((disp (get-text-property (point) 'vm-mime-disposition))) (setcar disp (symbol-name sym)))) (vm-xemacs-p (let* ((e (vm-extent-at (point) 'vm-mime-disposition)) (disp (vm-extent-property e 'vm-mime-disposition))) (setcar disp (symbol-name sym)))))) (defun vm-mime-attachment-encoding-at-point () (cond (vm-fsfemacs-p (get-text-property (point) 'vm-mime-encoding)) (vm-xemacs-p (let ((e (vm-extent-at (point) 'vm-mime-encoding))) (if e (vm-extent-property e 'vm-mime-encoding)))))) (defun vm-mime-set-attachment-encoding-at-point (sym) (cond (vm-fsfemacs-p ;; (set-text-property (point) 'vm-mime-encoding sym) (put-text-property (point) (point) 'vm-mime-encoding sym) ) (vm-xemacs-p (let ((e (vm-extent-at (point) 'vm-mime-disposition))) (vm-set-extent-property e 'vm-mime-encoding sym))))) (defun vm-disallow-overlay-endpoint-insertion (overlay after start end &optional old-size) "Hook function called before and after text is inserted at the endpoint of an OVERLAY. AFTER is true if the call is being made after insertion. Otherwise, it is being made before insertion. START and END denote the range of the text inserted. Optional argument OLD-SIZE is ignored. This hook does nothing when called before insertion. When it is called after insertion, it moves the overlay so that the inserted is excluded from the overlay." (when after (cond ((= start (overlay-start overlay)) (move-overlay overlay end (overlay-end overlay))) ((= start (overlay-end overlay)) (move-overlay overlay (overlay-start overlay) start))))) (defun vm-mime-attachment-button-extents (start end &optional prop) "Return the extents of all attachment buttons in the region. Optional argument PROP can specify an extent property, in which case only those extents that have the property are returned. In GNU Emacs version of this function, attachment buttons are expected to be denoted by text-properties rather than extents. \"Fake\" extents are created for the purpose of this function. USR, 2011-03-27" (let ((e-list (if vm-xemacs-p (vm-extent-list start end prop) (vm-mime-fake-attachment-overlays start end prop)))) (sort e-list (function (lambda (e1 e2) (< (vm-extent-end-position e1) (vm-extent-end-position e2))))))) (defun vm-mime-fake-attachment-overlays (start end &optional prop) "For all attachment buttons in the region, i.e., pieces of text with the given text property PROP, create \"fake\" attachment overlays with the 'vm-mime-object property. The list of these overlays is returned. This function is only used with GNU Emacs, not XEmacs. USR, 2011-02-19" ;; This round about method is being used because in GNU Emacs, ;; only text properties are preserved under killing and yanking. ;; So, text properties are normally used for attachment buttons and ;; converted to overlays just before MIME encoding. USR, 2011-02-19 (when (null prop) (setq prop 'vm-mime-object)) (let ((o-list nil) (done nil) (pos start) object props o) (save-excursion (save-restriction (narrow-to-region start end) (while (not done) (setq object (get-text-property pos prop)) (setq pos (next-single-property-change pos prop)) (unless pos (setq pos (point-max) done t)) (when object (setq o (make-overlay start pos nil t nil)) ;; (overlay-put o 'insert-in-front-hooks ;; '(vm-disallow-overlay-endpoint-insertion)) ;; (overlay-put o 'insert-behind-hooks ;; '(vm-disallow-overlay-endpoint-insertion)) (setq props (text-properties-at start)) (unless (eq prop 'vm-mime-object) (setq props (append (list 'vm-mime-object t) props))) (while props (overlay-put o (car props) (cadr props)) (setq props (cddr props))) (setq o-list (cons o o-list))) (setq start pos)) o-list )))) (defun vm-mime-default-type-from-filename (file) (let ((alist vm-mime-attachment-auto-type-alist) (case-fold-search t) (done nil)) (while (and alist (not done)) (if (string-match (car (car alist)) file) (setq done t) (setq alist (cdr alist)))) (and alist (cdr (car alist))))) (defun vm-remove-mail-mode-header-separator () (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" mail-header-separator "$") nil t) (progn (delete-region (match-beginning 0) (match-end 0)) t ) nil ))) (defun vm-add-mail-mode-header-separator () (save-excursion (goto-char (point-min)) (if (re-search-forward "^$" nil t) (replace-match mail-header-separator t t)))) (defun vm-mime-transfer-encode-region (encoding beg end crlf) "Encode region between BEG and END using transfer ENCODING (base64, quoted-printable or binary). CRLF says whether carriage returns should be included (?) USR, 2011-03-27" (let ((case-fold-search t) (armor-from (and vm-mime-composition-armor-from-lines (let ((case-fold-search nil)) (save-excursion (goto-char beg) (re-search-forward "^From " nil t))))) (armor-dot (let ((case-fold-search nil)) (save-excursion (goto-char beg) (re-search-forward "^\\.\n" nil t))))) (cond ((string-match "^binary$" encoding) (vm-mime-base64-encode-region beg end crlf) (setq encoding "base64")) ((and (not armor-from) (not armor-dot) (string-match "^7bit$" encoding)) t) ((string-match "^base64$" encoding) t) ((string-match "^quoted-printable$" encoding) t) ((eq vm-mime-8bit-text-transfer-encoding 'quoted-printable) (vm-mime-qp-encode-region beg end nil armor-from) (setq encoding "quoted-printable")) ((eq vm-mime-8bit-text-transfer-encoding 'base64) (vm-mime-base64-encode-region beg end crlf) (setq encoding "base64")) ((or armor-from armor-dot) (vm-mime-qp-encode-region beg end nil armor-from) (setq encoding "quoted-printable"))) (downcase encoding) )) (defun vm-mime-transfer-encode-layout (layout) "Encode a MIME object described by LAYOUT in transfer encoding (base64, quoted-printable or binary). USR, 2011-03-27" (let ((list (vm-mm-layout-parts layout)) (type (car (vm-mm-layout-type layout))) (encoding "7bit") (vm-mime-8bit-text-transfer-encoding vm-mime-8bit-text-transfer-encoding)) (cond ((vm-mime-composite-type-p type) ;; MIME messages of type "message" and ;; "multipart" are required to have a non-opaque ;; content transfer encoding. This means that ;; if the user only wants to send out 7bit data, ;; then any subpart that contains 8bit data must ;; have an opaque (qp or base64) 8->7bit ;; conversion performed on it so that the ;; enclosing entity can use a non-opaque ;; encoding. ;; ;; message/partial requires a "7bit" encoding so ;; force 8->7 conversion in that case. (cond ((memq vm-mime-8bit-text-transfer-encoding '(quoted-printable base64)) t) ((vm-mime-types-match "message/partial" type) (setq vm-mime-8bit-text-transfer-encoding 'quoted-printable))) (while list (if (equal (vm-mime-transfer-encode-layout (car list)) "8bit") (setq encoding "8bit")) (setq list (cdr list)))) (t (when (and (vm-mime-types-match "message/partial" type) (not (memq vm-mime-8bit-text-transfer-encoding '(quoted-printable base64)))) (setq vm-mime-8bit-text-transfer-encoding 'quoted-printable)) (setq encoding (vm-mime-transfer-encode-region (vm-mm-layout-encoding layout) (vm-mm-layout-body-start layout) (vm-mm-layout-body-end layout) (vm-mime-text-type-layout-p layout))))) ;; seems redundant because an encoding can never be equal to a type. ;; but it wasn't meant to be encoding becuase it woundn't be a list. ;; who knows that is supposed to be? USR, 2011-03-27 (unless (equal encoding (downcase (car (vm-mm-layout-type layout)))) (save-excursion (save-restriction (goto-char (vm-mm-layout-header-start layout)) (narrow-to-region (point) (vm-mm-layout-header-end layout)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "Content-Transfer-Encoding:") (if (not (equal encoding "7bit")) (insert "CONTENT-TRANSFER-ENCODING: " encoding "\n")) encoding ))))) (defun vm-mime-text-description (start end) (save-excursion (goto-char start) (if (looking-at "[ \t\n]*-- \n") ".signature" (if (re-search-forward "^-- \n" nil t) "message body and .signature" "message body text")))) ;; tried this but random text in the object tag does't look right. ;; (skip-chars-forward " \t\n") ;; (let ((description (buffer-substring (point) (min (+ (point) 20) end))) ;; (ellipsis (< (+ (point) 20) end)) ;; (i nil)) ;; (while (setq i (string-match "[\t\r\n]" description i)) ;; (aset description i " ")) ;; (cond ((= 0 (length description)) nil) ;; (ellipsis (concat description "...")) ;; (t description)))))) ;;;###autoload (defun vm-delete-mime-object (&optional saved-file) "Delete the contents of the MIME object at point. The MIME object is replaced by a text/plain object that briefly describes what was deleted." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (when (and (vm-virtual-message-p (car vm-message-pointer)) (null (vm-virtual-messages-of (car vm-message-pointer)))) (error "Can't edit unmirrored virtual messages.")) (when vm-presentation-buffer (set-buffer vm-presentation-buffer)) (let (layout label) (let ((e (vm-extent-at (point) 'vm-mime-layout))) (if (null e) (error "No MIME button found at point.") (setq layout (vm-extent-property e 'vm-mime-layout)) (when (and (vm-mm-layout-message layout) (eq layout (vm-mime-layout-of (vm-mm-layout-message layout)))) (error (concat "Can't delete the only MIME object; " "use vm-delete-message instead."))) (when vm-mime-confirm-delete (unless (y-or-n-p (vm-mime-sprintf "Delete %t? " layout)) (error "Aborted"))) (let ((inhibit-read-only t) opos (buffer-read-only nil)) (save-excursion (vm-save-restriction (goto-char (vm-extent-start-position e)) (setq opos (point)) (setq label (vm-mime-sprintf vm-mime-deleted-object-label layout)) (insert label) (delete-region (point) (vm-extent-end-position e)) (vm-set-extent-endpoints e opos (point))))) (vm-mime-discard-layout-contents layout saved-file))) (when (vm-interactive-p) ;; make the change visible and place the cursor behind the removed object (vm-discard-cached-data) (when vm-presentation-buffer (set-buffer vm-presentation-buffer) (re-search-forward (regexp-quote label) (point-max) t))))) (defun vm-mime-discard-layout-contents (layout &optional file) (save-excursion (let ((inhibit-read-only t) (buffer-read-only nil) (m (vm-mm-layout-message layout)) newid new-layout) (if (null m) (error "Message body not loaded")) (set-buffer (vm-buffer-of m)) (vm-save-restriction (widen) (if (vm-mm-layout-is-converted layout) (setq layout (vm-mm-layout-unconverted-layout layout))) (goto-char (vm-mm-layout-header-start layout)) (cond ((null file) (insert "Content-Type: text/plain; charset=us-ascii\n\n") (vm-set-mm-layout-body-start layout (point-marker)) (insert (vm-mime-sprintf vm-mime-deleted-object-label layout))) (t (insert "Content-Type: message/external-body; access-type=local-file; name=\"" file "\"\n") (insert "Content-Transfer-Encoding: 7bit\n\n") (insert "Content-Type: " (vm-mime-type-with-params (car (vm-mm-layout-qtype layout)) (cdr (vm-mm-layout-qtype layout))) "\n") (if (vm-mm-layout-qdisposition layout) (let ((p (vm-mm-layout-qdisposition layout))) (insert "Content-Disposition: " (mapconcat 'identity p "; ") "\n"))) (if (vm-mm-layout-id layout) (insert "Content-ID: " (vm-mm-layout-id layout) "\n") (setq newid (vm-make-message-id)) (insert "Content-ID: " newid "\n")) (insert "Content-Transfer-Encoding: binary\n\n") (insert "[Deleted " (vm-mime-sprintf "%d]\n" layout)) (insert "[Saved to " file " on " (system-name) "]\n"))) (delete-region (point) (vm-mm-layout-body-end layout)) (vm-set-edited-flag-of m t) (vm-set-byte-count-of m nil) (vm-set-line-count-of m nil) (vm-set-stuff-flag-of m t) ;; For the dreaded From_-with-Content-Length folders recompute ;; the message length and make a new Content-Length header. (if (eq (vm-message-type-of m) 'From_-with-Content-Length) (let (length) (goto-char (vm-headers-of m)) ;; first delete all copies of Content-Length (while (and (re-search-forward vm-content-length-search-regexp (vm-text-of m) t) (null (match-beginning 1)) (progn (goto-char (match-beginning 0)) (vm-match-header vm-content-length-header))) (delete-region (vm-matched-header-start) (vm-matched-header-end))) ;; now compute the message body length (setq length (- (vm-end-of m) (vm-text-of m))) ;; insert the header (goto-char (vm-headers-of m)) (insert vm-content-length-header " " (int-to-string length) "\n"))) ;; make sure we get the summary updated. The 'edited' ;; flag might already be set and therefore trying to set ;; it again might not have triggered an update. We need ;; the update because the message size has changed. (vm-mark-for-summary-update (vm-mm-layout-message layout)) (cond (file (save-restriction (narrow-to-region (vm-mm-layout-header-start layout) (vm-mm-layout-body-end layout)) (setq new-layout (vm-mime-parse-entity-safe)) (vm-set-mm-layout-message-symbol new-layout (vm-mm-layout-message-symbol layout)) (vm-mime-copy-layout new-layout layout))) (t (vm-set-mm-layout-type layout '("text/plain")) (vm-set-mm-layout-qtype layout '("text/plain")) (vm-set-mm-layout-encoding layout "7bit") (vm-set-mm-layout-id layout nil) (vm-set-mm-layout-description layout (vm-mime-sprintf "Deleted %d" layout)) (vm-set-mm-layout-disposition layout nil) (vm-set-mm-layout-qdisposition layout nil) (vm-set-mm-layout-parts layout nil) (vm-set-mm-layout-display-error layout nil))))))) (defun vm-mime-encode-words (&optional encoding) (goto-char (point-min)) ;; find right encoding (setq encoding (or encoding vm-mime-encode-headers-type)) (save-excursion (when (stringp encoding) (setq encoding (if (re-search-forward encoding (point-max) t) 'B 'Q)))) ;; now encode the words (let ((case-fold-search nil) start end charset coding) (while (re-search-forward vm-mime-encode-headers-words-regexp (point-max) t) (setq start (match-beginning 1) end (vm-marker (match-end 0)) charset (or (vm-determine-proper-charset start end) vm-mime-8bit-composition-charset) coding (vm-mime-charset-to-coding charset)) ;; encode coding system body (when (and coding (not (eq coding 'no-conversion))) (if vm-xemacs-p (vm-encode-coding-region start end coding) ;; using vm-encode-coding-region causes wrong encoding in GNU Emacs (encode-coding-region start end coding))) ;; encode (if (eq encoding 'Q) (vm-mime-Q-encode-region start end) (vm-mime-base64-encode-region start end)) ;; insert start and end markers (goto-char start) (insert "=?" charset "?" (format "%s" encoding) "?") (setq start (point)) (goto-char end) (insert "?=") ;; goto end for next round (goto-char end)))) ;;;###autoload (defun vm-mime-encode-words-in-string (string &optional encoding) (and string (vm-with-string-as-temp-buffer (vm-substring-no-properties string 0) 'vm-mime-encode-words))) (defun vm-mime-encode-headers () "Encodes the headers of a message. Only the words containing a non 7bit ASCII char are encoded, but not the whole header as this will cause trouble for the recipients and authors headers. Whitespace between encoded words is trimmed during decoding and thus those should be encoded together." (interactive) (save-excursion (let ((headers (concat "^\\(" vm-mime-encode-headers-regexp "\\):")) (case-fold-search nil) (encoding vm-mime-encode-headers-type) body-start start end) (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n")) (setq body-start (vm-marker (match-beginning 0))) (goto-char (point-min)) (while (let ((case-fold-search t)) (re-search-forward headers body-start t)) (goto-char (match-end 0)) (setq start (point)) (when (not (looking-at "\\s-")) (insert " ") (backward-char 1)) (save-excursion (setq end (or (and (re-search-forward "^[^ \t:]+:" body-start t) (match-beginning 0)) body-start))) (vm-save-restriction (narrow-to-region start end) (vm-mime-encode-words)) (goto-char end))))) ;;;###autoload (defun vm-mime-encode-composition (&optional attachments-only) "MIME encode the current mail composition buffer. This function chooses the MIME character set(s) to use, and transforms the message content from the Emacs-internal encoding to the corresponding octets in that MIME character set. It then applies some transfer encoding to the message. For details of the transfer encodings available, see the documentation for `vm-mime-8bit-text-transfer-encoding.' Finally, it creates the headers that are necessary to identify the message as one that uses MIME. Under MULE, it explicitly sets `buffer-file-coding-system' to a binary (no-transformation) coding system, to avoid further transformation of the message content when it's passed to the MTA (that is, the mail transfer agent; under Unix, normally sendmail.) Attachment tags added to the buffer with `vm-attach-file' are expanded and the approriate content-type and boundary markup information is added." (interactive) (vm-mail-mode-show-headers) (vm-disable-modes vm-disable-modes-before-encoding) (vm-mime-encode-headers) (if vm-mail-reorder-message-headers (vm-reorder-message-headers nil :keep-list vm-mail-header-order :discard-regexp 'none)) (buffer-enable-undo) (let ((unwind-needed t) (mybuffer (current-buffer))) (unwind-protect (progn (vm-mime-encode-composition-internal attachments-only) (setq unwind-needed nil)) (and unwind-needed (consp buffer-undo-list) (eq mybuffer (current-buffer)) (setq buffer-undo-list (primitive-undo 1 buffer-undo-list)))))) (defvar enriched-mode) ;; This function was originally XEmacs-specific. It has now been ;; generalized to both XEmacs and GNU Emacs. USR, 2011-03-27 (defun vm-mime-encode-composition-internal (&optional attachments-only) "MIME encode the message composition in the current buffer." (save-restriction (widen) (unless (eq major-mode 'mail-mode) (error "Command must be used in a VM Mail mode buffer.")) (when (vm-mail-mode-get-header-contents "MIME-Version:") (error "Message is already MIME encoded.")) (let ((8bit nil) (multipart t) ; start off asuming multipart (boundary-positions nil) ; position markers for the parts text-result ; results from text encodings forward-local-refs already-mimed layout e e-list boundary type encoding charset params description disposition object opoint-min encoded-attachment) (when vm-xemacs-p ;;Make sure we don't double encode UTF-8 (for example) text. (setq buffer-file-coding-system (vm-binary-coding-system))) (goto-char (mail-text-start)) (setq e-list (vm-mime-attachment-button-extents (point) (point-max) 'vm-mime-object)) ;; We have a multipart message unless there's just one ;; attachment and no other readable text in the buffer. (when (and (= (length e-list) 1) (looking-at "[ \t\n]*") (= (match-end 0) (vm-extent-start-position (car e-list))) (save-excursion (goto-char (vm-extent-end-position (car e-list))) (looking-at "[ \t\n]*\\'"))) (setq multipart nil)) ;; 1. Insert the text parts and attachments (if (null e-list) ;; no attachments (vm-mime-encode-text-part (point) (point-max) t) ;; attachments to be handled (while e-list (setq e (car e-list)) ;; 1a. Insert the text part (if (or (not multipart) (save-excursion (eq (vm-extent-start-position e) (re-search-forward "[ \t\n]*" (vm-extent-start-position e) t)))) ;; found an attachment (delete-region (point) (vm-extent-start-position e)) ;; found text (setq text-result (vm-mime-encode-text-part (point) (vm-extent-start-position e) nil)) (setq boundary-positions (cons (car text-result) boundary-positions)) (setq 8bit (or 8bit (equal (cdr text-result) "8bit")))) ;; 1b. Prepare for the object (goto-char (vm-extent-start-position e)) (narrow-to-region (point) (point)) (setq object (vm-extent-property e 'vm-mime-object)) ;; 1c. Insert the object (cond ((bufferp object) (vm-mime-insert-buffer-substring object (vm-extent-property e 'vm-mime-type))) ;; insert attachment from another folder ((listp object) (save-restriction (with-current-buffer (nth 0 object) (widen)) (setq boundary-positions (cons (point-marker) boundary-positions)) (insert-buffer-substring (nth 0 object) (nth 1 object) (nth 2 object)) (setq encoded-attachment t))) ;; insert file ((stringp object) (vm-mime-insert-file-contents object (vm-extent-property e 'vm-mime-type)))) ;; 1d. Gather information about the object from the extent. (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) (setq layout (vm-mime-parse-entity nil :default-type (list "text/plain" "charset=us-ascii") :default-encoding "7bit") type (or (vm-extent-property e 'vm-mime-type) (car (vm-mm-layout-type layout))) params (or (vm-extent-property e 'vm-mime-parameters) (cdr (vm-mm-layout-qtype layout))) forward-local-refs (car (vm-extent-property e 'vm-mime-forward-local-refs)) description (vm-extent-property e 'vm-mime-description) disposition (if (equal (car (vm-extent-property e 'vm-mime-disposition)) "unspecified") (vm-mm-layout-qdisposition layout) (vm-extent-property e 'vm-mime-disposition))) (setq type (vm-extent-property e 'vm-mime-type) params (vm-extent-property e 'vm-mime-parameters) forward-local-refs (car (vm-extent-property e 'vm-mime-forward-local-refs)) description (vm-extent-property e 'vm-mime-description) disposition (if (equal (car (vm-extent-property e 'vm-mime-disposition)) "unspecified") (if attachments-only '("attachment") nil) (if attachments-only (cons "attachment" (cdr (vm-extent-property e 'vm-mime-disposition))) (vm-extent-property e 'vm-mime-disposition))))) ;; 1e. Encode the object if necessary (cond ((vm-mime-types-match "text" type) (setq encoding (or (vm-extent-property e 'vm-mime-encoding) (vm-determine-proper-content-transfer-encoding (if already-mimed (vm-mm-layout-body-start layout) (point-min)) (point-max))) encoding (vm-mime-transfer-encode-region encoding (if already-mimed (vm-mm-layout-body-start layout) (point-min)) (point-max) t)) (setq 8bit (or 8bit (equal encoding "8bit")))) ((vm-mime-composite-type-p type) (setq opoint-min (point-min)) (unless already-mimed (goto-char (point-min)) (insert "Content-Type: " type "\n") ;; vm-mime-transfer-encode-layout will replace ;; this if the transfer encoding changes. (insert "Content-Transfer-Encoding: 7bit\n\n") (setq layout (vm-mime-parse-entity nil :default-type (list "text/plain" "charset=us-ascii") :default-encoding "7bit")) (setq already-mimed t)) (when (and layout (not forward-local-refs)) (vm-mime-internalize-local-external-bodies layout) ; update the cached data for the new layout (setq type (car (vm-mm-layout-type layout)) params (cdr (vm-mm-layout-qtype layout)) disposition (vm-mm-layout-qdisposition layout))) (setq encoding (vm-mime-transfer-encode-layout layout)) (setq 8bit (or 8bit (equal encoding "8bit"))) (goto-char (point-max)) (widen) (narrow-to-region opoint-min (point))) ((not encoded-attachment) (when (and layout (not forward-local-refs)) (vm-mime-internalize-local-external-bodies layout) ; update the cached data that might now be stale ; but retain the disposition if nothing new (setq type (car (vm-mm-layout-type layout)) params (cdr (vm-mm-layout-qtype layout)) disposition (or (vm-mm-layout-qdisposition layout) disposition))) (if already-mimed (setq encoding (vm-mime-transfer-encode-layout layout)) (vm-mime-base64-encode-region (point-min) (point-max)) (setq encoding "base64")))) ;; 1f. Add the required MIME headers (unless (or (not multipart) encoded-attachment) (goto-char (point-min)) (setq boundary-positions (cons (point-marker) boundary-positions)) (when already-mimed ;; trim headers (vm-reorder-message-headers nil :keep-list '("Content-ID:") :discard-regexp nil) ;; remove header/text separator (goto-char (1- (vm-mm-layout-body-start layout))) (when (looking-at "\n") (delete-char 1))) (insert "Content-Type: " (vm-mime-type-with-params type params) "\n") (when description (insert "Content-Description: " description "\n")) (when disposition (insert "Content-Disposition: " (vm-mime-type-with-params (car disposition) (cdr disposition)) "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n")) (goto-char (point-max)) (widen) ;; 1g. Delete the original attachment button (save-excursion (goto-char (vm-extent-start-position e)) (vm-assert (looking-at "\\[ATTACHMENT"))) (delete-region (vm-extent-start-position e) (vm-extent-end-position e)) (vm-detach-extent e) (when (looking-at "\n") (delete-char 1)) (setq e-list (cdr e-list))) ;; 2. Handle the remaining chunk of text after the last ;; extent, if any. (if (and multipart (not (looking-at "[ \t\n]*\\'"))) (progn (setq text-result (vm-mime-encode-text-part (point) (point-max) nil)) (setq boundary-positions (cons (car text-result) boundary-positions)) (setq 8bit (or 8bit (equal (cdr text-result) "8bit"))) (goto-char (point-max))) (delete-region (point) (point-max))) ;; 3. Create and insert boundary lines (when multipart (setq boundary (vm-mime-make-multipart-boundary)) (mail-text) (while (re-search-forward (concat "^--" (regexp-quote boundary) "\\(--\\)?$") nil t) (setq boundary (vm-mime-make-multipart-boundary)) (mail-text)) (goto-char (point-max)) (insert "\n--" boundary "--\n") (while boundary-positions (goto-char (car boundary-positions)) (insert "\n--" boundary "\n") (setq boundary-positions (cdr boundary-positions)))) ;; 4. Add MIME headers to the message (when (and (not multipart) already-mimed) (goto-char (vm-mm-layout-header-start layout)) ;; trim headers (vm-reorder-message-headers nil :keep-list '("Content-ID:") :discard-regexp nil) ;; remove header/text separator (goto-char (vm-mm-layout-header-end layout)) (when (looking-at "\n") (delete-char 1)) ;; copy remainder to enclosing entity's header section (goto-char (point-max)) (when multipart (insert-buffer-substring (current-buffer) (vm-mm-layout-header-start layout) (vm-mm-layout-body-start layout))) (delete-region (vm-mm-layout-header-start layout) (vm-mm-layout-body-start layout))) (goto-char (point-min)) (vm-remove-mail-mode-header-separator) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") (vm-add-mail-mode-header-separator) (insert "MIME-Version: 1.0\n") (if multipart (progn (insert "Content-Type: " (vm-mime-type-with-params "multipart/mixed" (list (format "boundary=\"%s\"" boundary))) "\n") (insert "Content-Transfer-Encoding: " (if 8bit "8bit" "7bit") "\n")) (insert "Content-Type: " (vm-mime-type-with-params type params) "\n") (when disposition (insert "Content-Disposition: " (vm-mime-type-with-params (car disposition) (cdr disposition)) "\n")) (when description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n")))))) (defun vm-mime-encode-text-part (beg end whole-message) "Encode the text from BEG to END in a composition buffer as MIME part and add appropriate MIME headers. If WHOLE-MESSAGE is true, then encode it as the entire message. Returns a pair consisting of a marker pointing to the start of the encoded MIME part and the transfer-encoding used. But if WHOLE-MESSAGE is true then nil is returned." (let ((enriched (and (boundp 'enriched-mode) enriched-mode)) type encoding charset params description marker) (narrow-to-region beg end) ;; support enriched-mode for text/enriched composition (when enriched (let ((enriched-initial-annotation "")) (if vm-fsfemacs-p (save-excursion ;; insert/delete trick needed to avoid ;; enriched-mode tags from seeping into the ;; attachment overlays. I really wish ;; front-advance / rear-advance overlay ;; endpoint properties actually worked. (goto-char (point-max)) (insert-before-markers "\n") (enriched-encode (point-min) (1- (point))) (goto-char (point-max)) (delete-char -1)) (enriched-encode (point-min) (point-max))))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (when (vm-emacs-mule-p) (let ((coding-system (vm-mime-charset-to-coding charset))) (unless coding-system (error "Can't find a coding system for charset %s" charset)) (encode-coding-region (point-min) (point-max) ;; What about the case where vm-m-m-c-t-c-a doesn't have an ;; entry for the given charset? That shouldn't happen, if ;; vm-mime-mule-coding-to-charset-alist and ;; vm-mime-mule-charset-to-coding-alist have complete and ;; matching entries. Admittedly this last is not a ;; given. Should we make it so on startup? (By setting the ;; key for any missing entries in ;; vm-mime-mule-coding-to-charset-alist to being (format "%s" ;; coding-system), if necessary.) RWF, 2005-03-25 coding-system))) ;; not clear why this is needed. USR, 2011-03-27 (when vm-xemacs-p (when whole-message (enriched-mode -1))) (setq encoding (vm-determine-proper-content-transfer-encoding (point-min) (point-max)) encoding (vm-mime-transfer-encode-region encoding (point-min) (point-max) t) description (vm-mime-text-description (point-min) (point-max))) (if whole-message (progn (widen) (vm-remove-mail-mode-header-separator) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") (insert "MIME-Version: 1.0\n") (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (insert "Content-Transfer-Encoding: " encoding "\n") (vm-add-mail-mode-header-separator) nil) (setq marker (point-marker)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (when description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (widen) (cons marker encoding)))) ;; This function is now defunct. Use vm-mime-encode-composition. ;; USR, 2011-03-27 (defun vm-mime-fsfemacs-encode-composition () "MIME encode the message composition in the current buffer." (save-restriction (widen) (unless (eq major-mode 'mail-mode) (error "Command must be used in a VM Mail mode buffer.")) (when (vm-mail-mode-get-header-contents "MIME-Version:") (error "Message is already MIME encoded.")) (let ((8bit nil) (just-one nil) (boundary-positions nil) ; markers for the start of parts marker forward-local-refs already-mimed layout e e-list boundary type encoding charset params description disposition object opoint-min postponed-attachment) (goto-char (mail-text-start)) (setq e-list (vm-mime-attachment-button-extents (point) (point-max) 'vm-mime-object)) ;; If there's just one attachment and no other readable ;; text in the buffer then make the message type just be ;; the attachment type rather than sending a multipart ;; message with one attachment (setq just-one (and (= (length e-list) 1) (looking-at "[ \t\n]*") (= (match-end 0) (vm-extent-start-position (car e-list))) (save-excursion (goto-char (vm-extent-end-position (car e-list))) (looking-at "[ \t\n]*\\'")))) (if (null e-list) ;; no attachments (vm-mime-encode-text-part (point) (point-max) t) ;; attachments to be handled (while e-list (setq e (car e-list)) (if (or just-one (save-excursion (eq (vm-extent-start-position e) (re-search-forward "[ \t\n]*" (vm-extent-start-position e) t)))) ;; found an attachment (delete-region (point) (vm-extent-start-position e)) ;; found text (setq marker (vm-mime-encode-text-part (point) (vm-extent-start-position e) nil)) (setq boundary-positions (cons marker boundary-positions))) (goto-char (vm-extent-start-position e)) (narrow-to-region (point) (point)) (setq object (vm-extent-property e 'vm-mime-object)) ;; insert the object (cond ((bufferp object) (vm-mime-insert-buffer-substring object (vm-extent-property e 'vm-mime-type))) ;; insert attachment from another folder ((listp object) (save-restriction (with-current-buffer (nth 0 object) (widen)) (setq boundary-positions (cons (point-marker) boundary-positions)) (insert-buffer-substring (nth 0 object) (nth 1 object) (nth 2 object)) (setq postponed-attachment t))) ;; insert file ((stringp object) (vm-mime-insert-file-contents object (vm-extent-property e 'vm-mime-type)))) ;; gather information about the object from the extent. (if (setq already-mimed (vm-extent-property e 'vm-mime-encoded)) (setq layout (vm-mime-parse-entity nil :default-type (list "text/plain" "charset=us-ascii") :default-encoding "7bit") type (or (vm-extent-property e 'vm-mime-type) (car (vm-mm-layout-type layout))) params (or (vm-extent-property e 'vm-mime-parameters) (cdr (vm-mm-layout-qtype layout))) forward-local-refs (car (vm-extent-property e 'vm-mime-forward-local-refs)) description (vm-extent-property e 'vm-mime-description) disposition (if (not (equal (car (vm-extent-property e 'vm-mime-disposition)) "unspecified")) (vm-extent-property e 'vm-mime-disposition) (vm-mm-layout-qdisposition layout))) (setq type (vm-extent-property e 'vm-mime-type) params (vm-extent-property e 'vm-mime-parameters) forward-local-refs (car (vm-extent-property e 'vm-mime-forward-local-refs)) description (vm-extent-property e 'vm-mime-description) disposition (if (not (equal (car (vm-extent-property e 'vm-mime-disposition)) "unspecified")) (vm-extent-property e 'vm-mime-disposition) nil))) (cond ((vm-mime-types-match "text" type) (setq encoding (or (vm-extent-property e 'vm-mime-encoding) (vm-determine-proper-content-transfer-encoding (if already-mimed (vm-mm-layout-body-start layout) (point-min)) (point-max))) encoding (vm-mime-transfer-encode-region encoding (if already-mimed (vm-mm-layout-body-start layout) (point-min)) (point-max) t)) (setq 8bit (or 8bit (equal encoding "8bit")))) ((vm-mime-composite-type-p type) (setq opoint-min (point-min)) (unless already-mimed (goto-char (point-min)) (insert "Content-Type: " type "\n") ;; vm-mime-transfer-encode-layout will replace ;; this if the transfer encoding changes. (insert "Content-Transfer-Encoding: 7bit\n\n") (setq layout (vm-mime-parse-entity nil :default-type (list "text/plain" "charset=us-ascii") :default-encoding "7bit")) (setq already-mimed t)) (when (and layout (not forward-local-refs)) (vm-mime-internalize-local-external-bodies layout) ; update the cached data that might now be stale (setq type (car (vm-mm-layout-type layout)) params (cdr (vm-mm-layout-qtype layout)) disposition (vm-mm-layout-qdisposition layout))) (setq encoding (vm-mime-transfer-encode-layout layout)) (setq 8bit (or 8bit (equal encoding "8bit"))) (goto-char (point-max)) (widen) (narrow-to-region opoint-min (point))) ((not postponed-attachment) (when (and layout (not forward-local-refs)) (vm-mime-internalize-local-external-bodies layout) ; update the cached data that might now be stale (setq type (car (vm-mm-layout-type layout)) params (cdr (vm-mm-layout-qtype layout)) disposition (vm-mm-layout-qdisposition layout))) (if already-mimed (setq encoding (vm-mime-transfer-encode-layout layout)) (vm-mime-base64-encode-region (point-min) (point-max)) (setq encoding "base64")))) (unless (or just-one postponed-attachment) (goto-char (point-min)) (setq boundary-positions (cons (point-marker) boundary-positions)) (when already-mimed ;; trim headers - why remove perfectly good headers? USR (vm-reorder-message-headers nil :keep-list '("Content-ID:") :discard-regexp nil) ;; remove header/text separator (goto-char (1- (vm-mm-layout-body-start layout))) (when (looking-at "\n") (delete-char 1))) (insert "Content-Type: " (vm-mime-type-with-params type params) "\n") (when description (insert "Content-Description: " description "\n")) (when disposition (insert "Content-Disposition: " (car disposition)) (when (cdr disposition) (insert ";\n\t" (mapconcat 'identity (cdr disposition) ";\n\t"))) (insert "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n")) (goto-char (point-max)) (widen) (save-excursion (goto-char (vm-extent-start-position e)) (vm-assert (looking-at "\\[ATTACHMENT"))) (delete-region (vm-extent-start-position e) (vm-extent-end-position e)) (vm-detach-extent e) (if (looking-at "\n") (delete-char 1)) (setq e-list (cdr e-list))) ;; handle the remaining chunk of text after the last ;; extent, if any. (if (or just-one (looking-at "[ \t\n]*\\'")) (delete-region (point) (point-max)) (setq marker (vm-mime-encode-text-part (point) (point-max) nil)) (setq boundary-positions (cons marker boundary-positions)) ;; FIXME is this needed? ;; (setq 8bit (or 8bit (equal encoding "8bit"))) (goto-char (point-max))) (setq boundary (vm-mime-make-multipart-boundary)) (mail-text) (while (re-search-forward (concat "^--" (regexp-quote boundary) "\\(--\\)?$") nil t) (setq boundary (vm-mime-make-multipart-boundary)) (mail-text)) (goto-char (point-max)) (or just-one (insert "\n--" boundary "--\n")) (while boundary-positions (goto-char (car boundary-positions)) (insert "\n--" boundary "\n") (setq boundary-positions (cdr boundary-positions))) (when (and just-one already-mimed) (goto-char (vm-mm-layout-header-start layout)) ;; trim headers (vm-reorder-message-headers nil :keep-list '("Content-ID:") :discard-regexp nil) ;; remove header/text separator (goto-char (vm-mm-layout-header-end layout)) (if (looking-at "\n") (delete-char 1)) ;; copy remainder to enclosing entity's header section (goto-char (point-max)) (unless just-one (insert-buffer-substring (current-buffer) (vm-mm-layout-header-start layout) (vm-mm-layout-body-start layout))) (delete-region (vm-mm-layout-header-start layout) (vm-mm-layout-body-start layout))) (goto-char (point-min)) (vm-remove-mail-mode-header-separator) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") (vm-add-mail-mode-header-separator) (insert "MIME-Version: 1.0\n") (if just-one (insert "Content-Type: " (vm-mime-type-with-params type params) "\n") (insert "Content-Type: " (vm-mime-type-with-params "multipart/mixed" (list (concat "boundary=\"" boundary "\""))) "\n")) (when (and just-one description) (insert "Content-Description: " description "\n")) (when (and just-one disposition) (insert "Content-Disposition: " (vm-mime-type-with-params (car disposition) (cdr disposition)) "\n")) (if just-one (insert "Content-Transfer-Encoding: " encoding "\n") (if 8bit (insert "Content-Transfer-Encoding: 8bit\n") (insert "Content-Transfer-Encoding: 7bit\n"))))))) (make-obsolete 'vm-mime-fsfemacs-encode-composition 'vm-mime-encode-composition-internal "8.2.0") (defun vm-mime-fsfemacs-encode-text-part (beg end whole-message) "Encode the text from BEG to END in a composition buffer as MIME part and add appropriate MIME headers. If WHOLE-MESSAGE is true, then encode it as the entire message. Returns marker pointing to the start of the encoded MIME part." (let ((enriched (and (boundp 'enriched-mode) enriched-mode)) type encoding charset params description marker) (narrow-to-region beg end) ;; support enriched-mode for text/enriched composition (when enriched (let ((enriched-initial-annotation "")) (save-excursion ;; insert/delete trick needed to avoid ;; enriched-mode tags from seeping into the ;; attachment overlays. I really wish ;; front-advance / rear-advance overlay ;; endpoint properties actually worked. (goto-char (point-max)) (insert-before-markers "\n") (enriched-encode (point-min) (1- (point))) (goto-char (point-max)) (delete-char -1)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (when vm-fsfemacs-mule-p (let ((coding-system (vm-mime-charset-to-coding charset))) (unless coding-system (error "Can't find a coding system for charset %s" charset)) (encode-coding-region (point-min) (point-max) coding-system))) (setq encoding (vm-determine-proper-content-transfer-encoding (point-min) (point-max)) encoding (vm-mime-transfer-encode-region encoding (point-min) (point-max) t) description (vm-mime-text-description (point-min) (point-max))) (if whole-message (progn (widen) (vm-remove-mail-mode-header-separator) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(Content-Type:\\|Content-Transfer-Encoding\\|MIME-Version:\\)") (insert "MIME-Version: 1.0\n") (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (insert "Content-Transfer-Encoding: " encoding "\n") (vm-add-mail-mode-header-separator)) (setq marker (point-marker)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (when description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (widen) marker))) (make-obsolete 'vm-mime-fsfemacs-encode-text-part 'vm-mime-encode-text-part "8.2.0") (defun vm-mime-fragment-composition (size) (save-restriction (widen) (vm-inform 5 "Fragmenting message...") (let ((buffers nil) (total-markers nil) (id (vm-mime-make-multipart-boundary)) (n 1) b header-start header-end master-buffer start end) (vm-remove-mail-mode-header-separator) ;; message/partial must have "7bit" content transfer ;; encoding, so force everything to be encoded for ;; 7bit transmission. (let ((vm-mime-8bit-text-transfer-encoding (if (eq vm-mime-8bit-text-transfer-encoding '8bit) 'quoted-printable vm-mime-8bit-text-transfer-encoding))) (vm-mime-transfer-encode-layout (vm-mime-parse-entity nil :default-type (list "text/plain" "charset=us-ascii") :default-encoding "7bit"))) (goto-char (point-min)) (setq header-start (point)) (search-forward "\n\n") (setq header-end (1- (point))) (setq master-buffer (current-buffer)) (goto-char (point-min)) (setq start (point)) (while (not (eobp)) (condition-case nil (progn (forward-char (max (- size 150) 2000)) (beginning-of-line)) (end-of-buffer nil)) (setq end (point)) (setq b (generate-new-buffer (concat (buffer-name) " part " (int-to-string n)))) (setq buffers (cons b buffers)) (set-buffer b) (make-local-variable 'vm-send-using-mime) (setq vm-send-using-mime nil) (insert-buffer-substring master-buffer header-start header-end) (goto-char (point-min)) (vm-reorder-message-headers nil :keep-list nil :discard-regedp "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") (insert "MIME-Version: 1.0\n") (insert (format (if vm-mime-avoid-folding-content-type "Content-Type: message/partial; id=%s; number=%d" "Content-Type: message/partial;\n\tid=%s;\n\tnumber=%d") id n)) (if vm-mime-avoid-folding-content-type (insert (format "; total=%d" n)) (insert (format ";\n\ttotal=%d" n))) (setq total-markers (cons (point) total-markers)) (insert "\nContent-Transfer-Encoding: 7bit\n") (goto-char (point-max)) (insert mail-header-separator "\n") (insert-buffer-substring master-buffer start end) (vm-increment n) (set-buffer master-buffer) (setq start (point))) (vm-decrement n) (vm-add-mail-mode-header-separator) (let ((bufs buffers)) (while bufs (set-buffer (car bufs)) (goto-char (car total-markers)) (prin1 n (current-buffer)) (setq bufs (cdr bufs) total-markers (cdr total-markers))) (set-buffer master-buffer)) (vm-inform 5 "Fragmenting message... done") (nreverse buffers)))) ;; moved to vm-reply.el, not MIME-specific. (fset 'vm-mime-preview-composition 'vm-preview-composition) (defun vm-mime-composite-type-p (type) "Check if TYPE is a MIME type that might have subparts." (or (vm-mime-types-match "message/rfc822" type) (vm-mime-types-match "message/news" type) (vm-mime-types-match "multipart" type))) ;; Unused currrently. ;; ;;(defun vm-mime-map-atomic-layouts (function list) ;; (while list ;; (if (vm-mime-composite-type-p (car (vm-mm-layout-type (car list)))) ;; (vm-mime-map-atomic-layouts function (vm-mm-layout-parts (car list))) ;; (funcall function (car list))) ;; (setq list (cdr list)))) (defun vm-mime-sprintf (format layout) ;; compile the format into an eval'able s-expression ;; if it hasn't been compiled already. (let ((match (assoc format vm-mime-compiled-format-alist))) (if (null match) (progn (vm-mime-compile-format format) (setq match (assoc format vm-mime-compiled-format-alist)))) ;; The local variable name `vm-mime-layout' is mandatory here for ;; the format s-expression to work. (let ((vm-mime-layout layout)) (eval (cdr match))))) (defun vm-mime-compile-format (format) (let ((return-value (vm-mime-compile-format-1 format 0))) (setq vm-mime-compiled-format-alist (cons (cons format (nth 1 return-value)) vm-mime-compiled-format-alist)))) (defun vm-mime-compile-format-1 (format start-index) (or start-index (setq start-index 0)) (let ((case-fold-search nil) (done nil) (sexp nil) (sexp-fmt nil) (last-match-end start-index) new-match-end conv-spec) (store-match-data nil) (while (not done) (while (and (not done) (string-match "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([()acdefknNstTx%]\\)" format last-match-end)) (setq conv-spec (aref format (match-beginning 5))) (setq new-match-end (match-end 0)) (if (memq conv-spec '(?\( ?a ?c ?d ?e ?f ?k ?n ?N ?s ?t ?T ?x)) (progn (cond ((= conv-spec ?\() (save-match-data (let ((retval (vm-mime-compile-format-1 format (match-end 5)))) (setq sexp (cons (nth 1 retval) sexp) new-match-end (car retval))))) ((= conv-spec ?a) (setq sexp (cons (list 'vm-mf-default-action 'vm-mime-layout) sexp))) ((= conv-spec ?c) (setq sexp (cons (list 'vm-mf-text-charset 'vm-mime-layout) sexp))) ((= conv-spec ?d) (setq sexp (cons (list 'vm-mf-content-description 'vm-mime-layout) sexp))) ((= conv-spec ?e) (setq sexp (cons (list 'vm-mf-content-transfer-encoding 'vm-mime-layout) sexp))) ((= conv-spec ?f) (setq sexp (cons (list 'vm-mf-attachment-file 'vm-mime-layout) sexp))) ((= conv-spec ?k) (setq sexp (cons (list 'vm-mf-event-for-default-action 'vm-mime-layout) sexp))) ((= conv-spec ?n) (setq sexp (cons (list 'vm-mf-parts-count 'vm-mime-layout) sexp))) ((= conv-spec ?N) (setq sexp (cons (list 'vm-mf-partial-number 'vm-mime-layout) sexp))) ((= conv-spec ?s) (setq sexp (cons (list 'vm-mf-parts-count-pluralizer 'vm-mime-layout) sexp))) ((= conv-spec ?t) (setq sexp (cons (list 'vm-mf-content-type-description 'vm-mime-layout) sexp))) ((= conv-spec ?T) (setq sexp (cons (list 'vm-mf-partial-total 'vm-mime-layout) sexp))) ((= conv-spec ?x) (setq sexp (cons (list 'vm-mf-external-body-content-type 'vm-mime-layout) sexp)))) (cond ((and (match-beginning 1) (match-beginning 2)) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-left-justify-string 'vm-left-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2)))))) ((match-beginning 2) (setcar sexp (list (if (eq (aref format (match-beginning 2)) ?0) 'vm-numeric-right-justify-string 'vm-right-justify-string) (car sexp) (string-to-number (substring format (match-beginning 2) (match-end 2))))))) (cond ((match-beginning 3) (setcar sexp (list 'vm-truncate-string (car sexp) (string-to-number (substring format (match-beginning 4) (match-end 4))))))) (setq sexp-fmt (cons "%s" (cons (substring format last-match-end (match-beginning 0)) sexp-fmt)))) (setq sexp-fmt (cons (if (eq conv-spec ?\)) (prog1 "" (setq done t)) "%%") (cons (substring format (or last-match-end 0) (match-beginning 0)) sexp-fmt)))) (setq last-match-end new-match-end)) (unless done (setq sexp-fmt (cons (substring format last-match-end (length format)) sexp-fmt) done t)) (setq sexp-fmt (apply 'concat (nreverse sexp-fmt))) (if sexp (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp)))) (setq sexp sexp-fmt))) (list last-match-end sexp))) (defun vm-mime-find-format-for-layout (layout) (let ((p vm-mime-button-format-alist) (type (car (vm-mm-layout-type layout)))) (catch 'done (cond ((vm-mime-types-match "error/error" type) (throw 'done "%d")) ((vm-mime-types-match "text/x-vm-deleted" type) (throw 'done "%d"))) (while p (if (vm-mime-types-match (car (car p)) type) (throw 'done (cdr (car p))) (setq p (cdr p)))) "%-25.25t [%k to %a]" ))) (defun vm-mf-content-type (layout) (car (vm-mm-layout-type layout))) (defun vm-mf-external-body-content-type (layout) (car (vm-mm-layout-type (car (vm-mm-layout-parts layout))))) (defun vm-mf-content-transfer-encoding (layout) (vm-mm-layout-encoding layout)) (defun vm-mf-content-description (layout) (or (vm-mm-layout-description layout) (vm-mf-content-type-description layout))) (defun vm-mf-content-type-description (layout) (let ((p vm-mime-type-description-alist) (type (car (vm-mm-layout-type layout)))) (catch 'done (while p (if (vm-mime-types-match (car (car p)) type) (throw 'done (cdr (car p))) (setq p (cdr p)))) (vm-mf-content-type layout) ))) (defun vm-mf-text-charset (layout) (or (vm-mime-get-parameter layout "charset") "us-ascii")) (defun vm-mf-parts-count (layout) (int-to-string (length (vm-mm-layout-parts layout)))) (defun vm-mf-parts-count-pluralizer (layout) (if (= 1 (length (vm-mm-layout-parts layout))) "" "s")) (defun vm-mf-partial-number (layout) (or (vm-mime-get-parameter layout "number") "?")) (defun vm-mf-partial-total (layout) (or (vm-mime-get-parameter layout "total") "?")) (defun vm-mf-attachment-file (layout) (or vm-mf-attachment-file ;; for %f expansion in external viewer arg lists (vm-mime-get-disposition-filename layout) (vm-mime-get-parameter layout "name") "")) (defun vm-mf-event-for-default-action (layout) (if (vm-mouse-support-possible-here-p) "Click mouse-2" "Press RETURN")) ;; This puts "alternative" on all attachments. Silly. USR, 2011-11-24 ;; (defun vm-mf-default-action (layout) ;; (if (eq vm-mime-alternative-show-method 'all) ;; (concat (vm-mf-default-action-orig layout) " alternative") ;; (vm-mf-default-action-orig layout))) (defun vm-mf-default-action (layout) (or vm-mf-default-action (let (cons) (cond ((or (vm-mime-can-display-internal layout) (vm-mime-find-external-viewer (car (vm-mm-layout-type layout)))) (let ((p vm-mime-default-action-string-alist) (type (car (vm-mm-layout-type layout)))) (catch 'done (while p (if (vm-mime-types-match (car (car p)) type) (throw 'done (cdr (car p))) (setq p (cdr p)))) nil ))) ((setq cons (vm-mime-can-convert (car (vm-mm-layout-type layout)))) "convert") (t "save"))) ;; should not be reached "burn in the raging fires of hell forever")) (defun vm-mime-map-layout-parts (m function &optional layout path) "Apply FUNCTION to each part of the message M. This function will call itself recursively with the currently processed LAYOUT and the PATH to it. PATH is a list of parent layouts where the root is at the end of the path." (unless layout (setq layout (vm-mm-layout m))) (when (vectorp layout) (funcall function m layout path) (let ((parts (copy-sequence (vm-mm-layout-parts layout)))) (while parts (vm-mime-map-layout-parts m function (car parts) (cons layout path)) (setq parts (cdr parts)))))) (defun vm-list-mime-part-structure (&optional verbose) "List mime part structure of the current message." (interactive "P") (vm-check-for-killed-summary) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((m (car vm-message-pointer)) (buffer (get-buffer-create "*VM mime part layout*"))) ;; (switch-to-buffer "*VM mime part layout*") ;; (erase-buffer) (with-current-buffer buffer (setq truncate-lines t)) (with-electric-help (lambda () (princ (format "%s\n" (vm-decode-mime-encoded-words-in-string (vm-su-subject m)))) (vm-mime-map-layout-parts m (lambda (m layout path) (if verbose (princ (format "%s%S\n" (make-string (length path) ? ) layout)) (princ (format "%s%S%s%s%s\n" (make-string (length path) ? ) (vm-mm-layout-type layout) (let ((id (vm-mm-layout-id layout))) (if id (format " id=%S" id) "")) (let ((desc (vm-mm-layout-description layout))) (if desc (format " desc=%S" desc) "")) (let ((dispo (vm-mm-layout-disposition layout))) (if dispo (format " %S" dispo) "")))))))) buffer) )) (defalias 'vm-mime-list-part-structure 'vm-list-mime-part-structure) ;;;###autoload (defun vm-nuke-alternative-text/html-internal (m) "Delete all text/html parts of multipart/alternative parts of message M. Returns the number of deleted parts. text/html parts are only deleted iff the first sub part of a multipart/alternative is a text/plain part." (let ((deleted-count 0) prev-type this-type parent-types nuke-html) (vm-mime-map-layout-parts m (lambda (m layout path) (setq this-type (car (vm-mm-layout-type layout)) parent-types (mapcar (lambda (layout) (car (vm-mm-layout-type layout))) path)) (when (and nuke-html (member "multipart/alternative" parent-types) (vm-mime-types-match "text/html" this-type)) (save-excursion (set-buffer (vm-buffer-of m)) (let ((inhibit-read-only t) (buffer-read-only nil)) (vm-save-restriction (widen) (if (vm-mm-layout-is-converted layout) (setq layout (vm-mm-layout-unconverted-layout layout))) (goto-char (vm-mm-layout-header-start layout)) (forward-line -1) (delete-region (point) (vm-mm-layout-body-end layout)) (vm-set-edited-flag-of m t) (vm-set-byte-count-of m nil) (vm-set-line-count-of m nil) (vm-set-stuff-flag-of m t) (vm-mark-for-summary-update m))) (setq deleted-count (1+ deleted-count)))) (if (and (vm-mime-types-match "multipart/alternative" prev-type) (vm-mime-types-match "text/plain" this-type)) (setq nuke-html t)) (setq prev-type this-type))) deleted-count)) ;;;###autoload (defun vm-nuke-alternative-text/html (&optional count mlist) "Removes the text/html part of all multipart/alternative message parts. This is a destructive operation and cannot be undone!" (interactive "p") (when (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((mlist (or mlist (vm-select-operable-messages count (vm-interactive-p) "Nuke html of")))) (vm-retrieve-operable-messages count mlist) (save-excursion (while mlist (let ((count (vm-nuke-alternative-text/html-internal (car mlist)))) (when (vm-interactive-p) (if (= count 0) (vm-inform 5 "No text/html parts found.") (vm-inform 5 "%d text/html part%s deleted." count (if (> count 1) "s" "")))) (setq mlist (cdr mlist)))))) (when (vm-interactive-p) (vm-discard-cached-data count) (vm-present-current-message))) (defalias 'vm-mime-nuke-alternative-text/html 'vm-nuke-alterantive-text/html) (make-obsolete 'vm-mime-nuke-alternative-text/html 'vm-nuke-alternative-text/html "8.2.0") ;;----------------------------------------------------------------------------- ;; The following functions are taken from vm-pine.el ;; Copyright (C) Robert Widhopf-Fenk ;; Copyright (C) Uday S. Reddy, 2010-2011 ;;;###autoload (defun vm-mime-convert-to-attachment-buttons () "Replace all mime buttons in the current buffer by attachment buttons." ;; called vm-mime-encode-mime-attachments in vm-pine.el (interactive) (cond (vm-xemacs-p (let ((e-list (vm-extent-list (point-min) (point-max) 'vm-mime-layout))) (setq e-list (sort e-list (function (lambda (e1 e2) (< (vm-extent-end-position e1) (vm-extent-end-position e2)))))) ;; Then replace the buttons, because doing it at once will result in ;; problems since the new buttons are from the same extent. (while e-list (vm-mime-replace-by-attachment-button (car e-list)) (setq e-list (cdr e-list))))) (vm-fsfemacs-p (let ((e-list (vm-mime-attachment-button-extents (point-min) (point-max) 'vm-mime-layout))) (while e-list (vm-mime-replace-by-attachment-button (car e-list)) (setq e-list (cdr e-list))) (goto-char (point-max)))) (t (error "don't know how to MIME encode composition for %s" (emacs-version))))) ;; The function vm-mime-re-fake-attachment-overlays from vm-pine.el is ;; now unused. USR, 2011-02-14 (defun vm-mime-replace-by-attachment-button (x) "Replace the MIME button specified by extent X by an attachment button." ;; This was called vm-mime-encode-mime-button in vm-pine.el (save-excursion (let* ((layout (vm-extent-property x 'vm-mime-layout)) (xstart (vm-extent-start-position x)) (xend (vm-extent-end-position x)) (hstart (vm-mm-layout-header-start layout)) (bstart (vm-mm-layout-body-start layout)) (end (vm-mm-layout-body-end layout)) (hbuf (marker-buffer hstart)) (bbuf (marker-buffer bstart)) (type (vm-mm-layout-type layout)) (desc (or (vm-mm-layout-description layout) (vm-mime-get-parameter layout "name") "attachment")) (disp (or (vm-mm-layout-disposition layout) '("inline"))) (file (vm-mime-get-disposition-parameter layout "filename")) (ext-file nil)) ;; special case of message/external-body ;; seems to be unused now. USR, 2011-12-06 (when (and type (string= (car type) "message/external-body") (string= (cadr type) "access-type=local-file")) (save-excursion (setq ext-file (substring (caddr type) 5)) (vm-select-folder-buffer) (save-restriction (let ((start (vm-mm-layout-body-start layout)) (end (vm-mm-layout-body-end layout))) (set-buffer (marker-buffer (vm-mm-layout-body-start layout))) (widen) (goto-char start) (if (not (re-search-forward "Content-Type: \"?\\([^ ;\" \n\t]+\\)\"?;?" end t)) (error "No `Content-Type' header found in: %s" (buffer-substring start end)) (setq type (list (match-string 1)))))))) ;; insert an attached-object-button (goto-char xstart) (cond (ext-file (vm-attach-file ext-file (car type))) ((eq hbuf bbuf) (vm-attach-object (if file (list hbuf hstart end disp file) (list hbuf hstart end disp)) :type (car type) :params (cdr type) :disposition disp :description desc :mimed t)) (t (vm-attach-object bbuf :type (car type) :params (cdr type) :disposition disp :description desc :mimed nil))) ;; delete the mime-button (delete-region (vm-extent-start-position x) (vm-extent-end-position x)) (vm-detach-extent x)))) ;; This code was originally part of ;; vm-mime-xemacs/fsfemacs-encode-composition functions. (defun vm-mime-insert-file-contents (file type) "Safely insert the contents of FILE of TYPE into the current buffer." (if vm-xemacs-p (let ((coding-system-for-read (if (vm-mime-text-type-p type) (vm-line-ending-coding-system) (vm-binary-coding-system))) ;; keep no undos (buffer-undo-list t) ;; no transformations! (format-alist nil) ;; no decompression! (jka-compr-compression-info-list nil) ;; don't let buffer-file-coding-system be changed ;; by insert-file-contents. The ;; value we bind to it to here isn't important. (buffer-file-coding-system (vm-binary-coding-system))) (insert-file-contents file)) ;; as of FSF Emacs 19.34, even with the hooks ;; we've attached to the attachment overlays, ;; text STILL can be inserted into them when ;; font-lock is enabled. Explaining why is ;; beyond the scope of this comment and I ;; don't know the answer anyway. This ;; insertion dance works to prevent it. (insert-before-markers " ") (forward-char -1) (let ((coding-system-for-read (if (vm-mime-text-type-p type) (vm-line-ending-coding-system) (vm-binary-coding-system))) ;; keep no undos (buffer-undo-list t) ;; no transformations! (format-alist nil) ;; no decompression! (jka-compr-compression-info-list nil) ;; don't let buffer-file-coding-system be ;; changed by insert-file-contents. The ;; value we bind to it to here isn't ;; important. (buffer-file-coding-system (vm-binary-coding-system)) ;; For NTEmacs 19: need to do this to make ;; sure CRs aren't eaten. (file-name-buffer-file-type-alist '(("." . t)))) (condition-case data (insert-file-contents file) (error ;; font-lock could signal this error in FSF ;; Emacs versions prior to 21.0. Catch it ;; and ignore it. (if (equal data '(error "Invalid search bound (wrong side of point)")) nil (signal (car data) (cdr data))))) (goto-char (point-max)) (delete-char -1)))) (defun vm-mime-insert-buffer-substring (buffer type) "Safe insert the contents of BUFFER of TYPE into the current buffer." (if vm-xemacs-p (insert-buffer-substring buffer) ;; Under Emacs 20.7 inserting a unibyte buffer ;; contents that contain 8-bit characters into a ;; multibyte buffer causes the inserted data to be ;; corrupted with the dreaded \201 corruption. So ;; we write the data out to disk and let the file ;; be inserted, which gets aoround the problem. (let ((tempfile (vm-make-tempfile))) ;; make note to delete the tempfile after insertion (with-current-buffer buffer (let ((buffer-file-coding-system (vm-binary-coding-system))) (write-region (point-min) (point-max) tempfile nil 0))) (unwind-protect (vm-mime-insert-file-contents tempfile type) (vm-error-free-call 'delete-file tempfile))))) ;;; vm-mime.el ends here vm-8.2.0b/lisp/vm-imap.el0000755000175000017500000051514711676442160015445 0ustar srivastasrivasta;;; vm-imap.el --- Simple IMAP4 (RFC 2060) client for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1998, 2001, 2003 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; Copyright (C) 2006 Robert P. Goldman ;; Copyright (C) 2008-2011 Uday S. Reddy ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-imap) (eval-when-compile (require 'sendmail) (require 'vm-misc)) ;; For function declarations (eval-when-compile (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-crypto) (require 'vm-mime) (require 'vm-reply) ) (declare-function vm-session-initialization "vm.el" ()) (declare-function vm-submit-bug-report "vm.el" (&optional pre-hooks post-hooks)) (declare-function open-network-stream "subr.el" (name buffer host service &rest parameters)) (defvar selectable-only) ; used with dynamic binding ;;; To-Do (USR) ;; - Need to ensure that new imap sessions get created as and when needed. ;; ------------------------------------------------------------------------ ;; The IMAP session protocol ;; ------------------------------------------------------------------------ ;; movemail: Folder-specific IMAP sessions are created and destroyed ;; for each get-new-mail. (Same as in VM 7.19) ;; ;; expunge: expunge-imap-messages creates and destroys sessions. ;; checkmail: check-for-mail also creates and destroys sessions. ;; checkmail: check-for-mail also creates and destroys sessions. ;; IMAP-FCC: Rob F's save-composition creates and destroys its own sessions. ;; folders: imap-folder-completion-list creates and destroys (?) sessions. ;; create, delete folder, rename folder, folders: They are also ;; created and destroyed at a global level for operations like ;; create-mailbox. (VM 7.19 didn't destroy them in the end, but we ;; do.) ;; general operation: synchronize-folder creates an IMAP session but ;; leaves it active. Since session is linked to the folder buffer, ;; the folder can use it for other operations like fetch-imap-message ;; and copy-message. The next time a synchronize-folder is done, this ;; session is killed and a fresh session is created. ;; ------------------------------------------------------------------------ ;;; Utilities ;; ------------------------------------------------------------------------ ;; ;; vm-folder-access-data ;; ;; See the info manual section on "Folder Internals" for the structure ;; of the data stored here. ;; ;; The following functions are based on cached folder-access-data. ;; They will only function when the IMAP process is "valid" and the ;; server message data is non-nil. (defun vm-folder-imap-msn-uid (n) "Returns the UID of the message sequence number N on the IMAP server, using cached data." (let ((cell (assq n (vm-folder-imap-uid-list)))) (nth 1 cell))) (defun vm-folder-imap-msn-size (n) "Returns the message size of the message sequence number N on the IMAP server, using cached data." (let ((cell (assq n (vm-folder-imap-uid-list)))) (nth 2 cell))) (defun vm-folder-imap-msn-flags (n) "Returns the message flags of the message sequence number N on the IMAP server, using cached data." (let ((cell (assq n (vm-folder-imap-uid-list)))) (nthcdr 2 cell))) (defun vm-folder-imap-message-msn (m) "Returns the message sequence number of message M on the IMAP server, using cached data." (let ((uid-key (intern (vm-imap-uid-of m) (vm-folder-imap-uid-obarray)))) (and (boundp uid-key) (symbol-value uid-key)))) (defun vm-folder-imap-message-size (m) "Returns the size of the message M on the IMAP server (as a string), using cached data." (let ((uid-key (intern (vm-imap-uid-of m) (vm-folder-imap-flags-obarray)))) (and (boundp uid-key) (car (symbol-value uid-key))))) (defun vm-folder-imap-message-flags (m) "Returns the flags of the message M on the IMAP server, using cached data." (let ((uid-key (intern (vm-imap-uid-of m) (vm-folder-imap-flags-obarray)))) (and (boundp uid-key) (cdr (symbol-value uid-key))))) (defun vm-folder-imap-uid-msn (uid) "Returns the message sequence number of message with UID on the IMAP server, using cached data." (let ((uid-key (intern uid (vm-folder-imap-uid-obarray)))) (and (boundp uid-key) (symbol-value uid-key)))) (defun vm-folder-imap-uid-message-size (uid) "Returns the size of the message with UID on the IMAP server (as a string), using cached data." (let ((uid-key (intern uid (vm-folder-imap-flags-obarray)))) (and (boundp uid-key) (car (symbol-value uid-key))))) (defun vm-folder-imap-uid-message-flags (uid) "Returns the flags of the message with UID on the IMAP server, using cached data." (let ((uid-key (intern uid (vm-folder-imap-flags-obarray)))) (and (boundp uid-key) (cdr (symbol-value uid-key))))) ;; Status indicator vector ;; timer (defsubst vm-imap-status-timer (o) (aref o 0)) ;; whether the current status has been reported already (defsubst vm-imap-status-did-report (o) (aref o 1)) ;; mailbox specification (defsubst vm-imap-status-mailbox (o) (aref o 2)) ;; message number (count) of the message currently being retrieved (defsubst vm-imap-status-currmsg (o) (aref o 3)) ;; total number of mesasges that need to be retrieved in this round (defsubst vm-imap-status-maxmsg (o) (aref o 4)) ;; amount of the current message that has been retrieved (defsubst vm-imap-status-got (o) (aref o 5)) ;; size of the current message (defsubst vm-imap-status-need (o) (aref o 6)) ;; Data for the message last reported (defsubst vm-imap-status-last-mailbox (o) (aref o 7)) (defsubst vm-imap-status-last-currmsg (o) (aref o 8)) (defsubst vm-imap-status-last-maxmsg (o) (aref o 9)) (defsubst vm-imap-status-last-got (o) (aref o 10)) (defsubst vm-imap-status-last-need (o) (aref o 11)) (defsubst vm-set-imap-status-timer (o val) (aset o 0 val)) (defsubst vm-set-imap-status-did-report (o val) (aset o 1 val)) (defsubst vm-set-imap-status-mailbox (o val) (aset o 2 val)) (defsubst vm-set-imap-status-currmsg (o val) (aset o 3 val)) (defsubst vm-set-imap-status-maxmsg (o val) (aset o 4 val)) (defsubst vm-set-imap-status-got (o val) (aset o 5 val)) (defsubst vm-set-imap-status-need (o val) (aset o 6 val)) (defsubst vm-set-imap-status-last-mailbox (o val) (aset o 7 val)) (defsubst vm-set-imap-status-last-currmsg (o val) (aset o 8 val)) (defsubst vm-set-imap-status-last-maxmsg (o val) (aset o 9 val)) (defsubst vm-set-imap-status-last-got (o val) (aset o 10 val)) (defsubst vm-set-imap-status-last-need (o val) (aset o 11 val)) (defun vm-imap-start-status-timer () (let ((blob (make-vector 12 nil)) timer) (setq timer (add-timeout 2 'vm-imap-report-retrieval-status blob 2)) (vm-set-imap-status-timer blob timer) blob )) (defun vm-imap-stop-status-timer (status-blob) (if (vm-imap-status-did-report status-blob) (vm-inform 6 "")) (if (fboundp 'disable-timeout) (disable-timeout (vm-imap-status-timer status-blob)) (cancel-timer (vm-imap-status-timer status-blob)))) (defun vm-imap-report-retrieval-status (o) (condition-case err (progn (vm-set-imap-status-did-report o t) (cond ((null (vm-imap-status-got o)) t) ;; should not be possible, but better safe... ((not (eq (vm-imap-status-mailbox o) (vm-imap-status-last-mailbox o))) t) ((not (eq (vm-imap-status-currmsg o) (vm-imap-status-last-currmsg o))) t) (t (vm-inform 7 "Retrieving message %d (of %d) from %s, %s..." (vm-imap-status-currmsg o) (vm-imap-status-maxmsg o) (vm-imap-status-mailbox o) (if (vm-imap-status-need o) (format "%d%%%s" (/ (* 100 (vm-imap-status-got o)) (vm-imap-status-need o)) (if (eq (vm-imap-status-got o) (vm-imap-status-last-got o)) " (stalled)" "")) "100%") ))) (vm-set-imap-status-last-mailbox o (vm-imap-status-mailbox o)) (vm-set-imap-status-last-currmsg o (vm-imap-status-currmsg o)) (vm-set-imap-status-last-maxmsg o (vm-imap-status-maxmsg o)) (vm-set-imap-status-last-got o (vm-imap-status-got o)) (vm-set-imap-status-last-need o (vm-imap-status-need o))) (error nil))) ;; For logging IMAP sessions (defvar vm-imap-log-sessions nil "* Boolean flag to turn on or off logging of IMAP sessions. Meant for debugging IMAP server interactions.") (defvar vm-imap-tokens nil) (defsubst vm-imap-init-log () (setq vm-imap-tokens nil)) (defsubst vm-imap-log-token (token) (if vm-imap-log-sessions (setq vm-imap-tokens (cons token vm-imap-tokens)))) (defsubst vm-imap-log-tokens (tokens) (if vm-imap-log-sessions (setq vm-imap-tokens (append (nreverse tokens) vm-imap-tokens)))) ;; For verification of session protocol ;; Possible values are ;; 'active - active session present ;; 'valid - message sequence numbers are valid ;; validity is preserved by FETCH, STORE and SEARCH operations ;; 'inactive - session is inactive ;; (defvar vm-imap-session-type nil) ; moved to vm-vars.el (defsubst vm-imap-session-type:set (type) (setq vm-imap-session-type type)) (defsubst vm-imap-session-type:make-active () (if (eq vm-imap-session-type 'inactive) (setq vm-imap-session-type 'active))) (defsubst vm-imap-session-type:assert (type) (vm-assert (eq vm-imap-session-type type))) (defsubst vm-imap-folder-session-type:assert (type) (with-current-buffer (process-buffer (vm-folder-imap-process)) (vm-assert (eq vm-imap-session-type type)))) (defsubst vm-imap-session-type:assert-active () (vm-assert (or (eq vm-imap-session-type 'active) (eq vm-imap-session-type 'valid)))) ;; Simple macros (defsubst vm-imap-delete-message (process n) (vm-imap-delete-messages process n n)) (if (fboundp 'define-error) (progn (define-error 'vm-imap-protocol-error "IMAP protocol error") (define-error 'vm-imap-normal-error "IMAP error" 'vm-imap-protocol-error) ) (put 'vm-imap-protocol-error 'error-conditions '(vm-imap-protocol-error error)) (put 'vm-imap-protocol-error 'error-message "IMAP protocol error") (put 'vm-imap-normal-error 'error-conditions '(vm-imap-protocol-error vm-imap-normal-error error)) (put 'vm-imap-normal-error 'error-message "IMAP error") ) (defun vm-imap-protocol-error (&rest args) (let ((local (make-local-variable 'vm-imap-keep-trace-buffer))) (unless (symbol-value local) (set local 1))) (signal 'vm-imap-protocol-error (list (apply 'format args)))) (defun vm-imap-normal-error (&rest args) (let ((local (make-local-variable 'vm-imap-keep-trace-buffer))) (unless (symbol-value local) (set local 1))) (signal 'vm-imap-normal-error (list (apply 'format args)))) (defun vm-imap-capability (cap &optional process) (if process (with-current-buffer (process-buffer process) (memq cap vm-imap-capabilities)) (memq cap vm-imap-capabilities))) (defsubst vm-imap-auth-method (auth) (memq auth vm-imap-auth-methods)) (defsubst vm-accept-process-output (process) "Accept output from PROCESS. The variable `vm-imap-server-timeout' specifies how many seconds to wait before timing out. If a timeout occurs, typically VM cannot proceed." ;; protect against possible buffer change due to bug in Emacs (let ((buf (current-buffer)) (got-output (accept-process-output process vm-imap-server-timeout))) (if got-output (when (not (equal (current-buffer) buf)) (when (string-lessp "24" emacs-version) ;; the Emacs bug should have been fixed in version 24 (vm-warn 0 2 "Emacs process output error: Buffer changed to %s" (current-buffer))) ;; recover from the bug (set-buffer buf)) (vm-imap-protocol-error "No response from the IMAP server")))) ;; Mollify the pesky compiler (defvar selectable-only) (defvar vm-imap-connection-mode 'online "* The mode of connection to the IMAP server. Possible values are: 'online, 'offline and 'autoconnect. In the 'online mode, synchronization works normally and message bodies of external messages are fetched when needed. In 'offline mode, no connection is established to the IMAP server and message bodies are not fetched. In the 'autoconnect mode, a connection is established whenever a synchronization operation is performed and the connection mode is then turned into 'online.") (defun delete-common-elements (list1 list2 pred) ;; Takes two lists of unique values with dummy headers and ;; destructively deletes all their common elements (rplacd list1 (sort (cdr list1) pred)) (rplacd list2 (sort (cdr list2) pred)) (while (and (cdr list1) (cdr list2)) (cond ((equal (car (cdr list1)) (car (cdr list2))) (rplacd list1 (cdr (cdr list1))) (rplacd list2 (cdr (cdr list2)))) ((apply pred (car (cdr list1)) (car (cdr list2)) nil) (setq list1 (cdr list1))) (t (setq list2 (cdr list2))) ))) ;; ----------------------------------------------------------------------- ;;; IMAP Spool ;; ;; -- Functions that treat IMAP mailboxes as spools to get mail ;; -- into local buffers and subsequently expunge on the server. ;; -- USR thinks this is obsolete functionality that should not be ;; -- used. Use 'IMAP folders' instead. ;; ;; handler methods: ;; vm-imap-move-mail: (string & string) -> bool ;; vm-imap-check-mail: string -> void ;; ;; interactive commands: ;; vm-expunge-imap-messages: () -> void ;; ;; vm-imap-prune-retrieval-entries: (string & list & ;; (retrieval-entry -> bool) -> list ;; vm-imap-clear-invalid-retrieval-entries: (string & list & string) -> list ;; ------------------------------------------------------------------------ (defsubst vm-imap-fetch-message (process n use-body-peek &optional headers-only) "Fetch IMAP message with sequence number N via PROCESS, which must be a network connection to an IMAP server. If the optional argument HEADERS-ONLY is non-nil, then only the headers are retrieved." (vm-imap-fetch-messages process n n use-body-peek headers-only)) (defun vm-imap-fetch-messages (process beg end use-body-peek &optional headers-only) "Fetch IMAP message with sequence numbers in the range BEG and END via PROCESS, which must be a network connection to an IMAP server. If the optional argument HEADERS-ONLY is non-nil, then only the headers are retrieved." (let ((fetchcmd (if headers-only (if use-body-peek "(BODY.PEEK[HEADER])" "(RFC822.HEADER)") (if use-body-peek "(BODY.PEEK[])" "(RFC822.PEEK)")))) (vm-imap-send-command process (format "FETCH %d:%d %s" beg end fetchcmd)))) (defsubst vm-imap-fetch-uid-message (process uid use-body-peek &optional headers-only) "Fetch IMAP message with UID via PROCESS, which must be a network connection to an IMAP server. If the optional argument HEADERS-ONLY is non-nil, then only the headers are retrieved." (let ((fetchcmd (if headers-only (if use-body-peek "(BODY.PEEK[HEADER])" "(RFC822.HEADER)") (if use-body-peek "(BODY.PEEK[])" "(RFC822.PEEK)")))) (vm-imap-send-command process (format "UID FETCH %s:%s %s" uid uid fetchcmd)))) ;; Our goal is to drag the mail from the IMAP maildrop to the crash box. ;; just as if we were using movemail on a spool file. ;; We remember which messages we have retrieved so that we can ;; leave the message in the mailbox, and yet not retrieve the ;; same messages again and again. ;;;###autoload (defun vm-imap-move-mail (source destination) "move-mail function for IMAP folders. SOURCE is the IMAP mail box from which mail is to be moved and DESTINATION is the VM folder." ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (let ((process nil) (m-per-session vm-imap-messages-per-session) (b-per-session vm-imap-bytes-per-session) (handler (vm-find-file-name-handler source 'vm-imap-move-mail)) (folder (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source))) (statblob nil) (msgid (list nil nil (vm-imapdrop-sans-password source) 'uid)) (imap-retrieved-messages vm-imap-retrieved-messages) (did-delete nil) (did-retain nil) (source-nopwd (vm-imapdrop-sans-password source)) use-body-peek auto-expunge x select source-list uid can-delete read-write uid-validity mailbox mailbox-count recent-count message-size response n (retrieved 0) retrieved-bytes process-buffer) (setq auto-expunge (cond ((setq x (assoc source vm-imap-auto-expunge-alist)) (cdr x)) ((setq x (assoc (vm-imapdrop-sans-password source) vm-imap-auto-expunge-alist)) (cdr x)) (vm-imap-expunge-after-retrieving t) ((member source vm-imap-auto-expunge-warned) nil) (t (vm-warn 6 1 "Warning: IMAP folder is not set to auto-expunge") (setq vm-imap-auto-expunge-warned (cons source vm-imap-auto-expunge-warned)) nil))) (unwind-protect (catch 'end-of-session (when handler (throw 'end-of-session (funcall handler 'vm-imap-move-mail source destination))) (setq process (vm-imap-make-session source vm-imap-ok-to-ask "movemail")) (or process (throw 'end-of-session nil)) (setq process-buffer (process-buffer process)) (save-excursion ; = save-current-buffer? (set-buffer process-buffer) ;;-------------------------------- (vm-buffer-type:enter 'process) ;;-------------------------------- ;; find out how many messages are in the box. (setq source-list (vm-parse source "\\([^:]+\\):?") mailbox (nth 3 source-list)) (setq select (vm-imap-select-mailbox process mailbox t)) (setq mailbox-count (nth 0 select) recent-count (nth 1 select) uid-validity (nth 2 select) read-write (nth 3 select) can-delete (nth 4 select) use-body-peek (vm-imap-capability 'IMAP4REV1)) ;;-------------------------------- (vm-imap-session-type:set 'valid) ;;-------------------------------- ;; The session type is not really "valid" because the uid ;; and flags data has not been obtained. But since ;; move-mail uses a short, bursty session, the effect is ;; that of a valid session throughout. ;; sweep through the retrieval list, removing entries ;; that have been invalidated by the new UIDVALIDITY ;; value. (setq imap-retrieved-messages (vm-imap-clear-invalid-retrieval-entries source-nopwd imap-retrieved-messages uid-validity)) ;; loop through the maildrop retrieving and deleting ;; messages as we go. (setq n 1 retrieved-bytes 0) (setq statblob (vm-imap-start-status-timer)) (vm-set-imap-status-mailbox statblob folder) (vm-set-imap-status-maxmsg statblob mailbox-count) (while (and (<= n mailbox-count) (or (not (natnump m-per-session)) (< retrieved m-per-session)) (or (not (natnump b-per-session)) (< retrieved-bytes b-per-session))) (catch 'skip (vm-set-imap-status-currmsg statblob n) (let (list) (setq list (vm-imap-get-uid-list process n n)) (setq uid (cdr (car list))) (setcar msgid uid) (setcar (cdr msgid) uid-validity) (when (member msgid imap-retrieved-messages) (if vm-imap-ok-to-ask (vm-inform 7 "Skipping message %d (of %d) from %s (retrieved already)..." n mailbox-count folder)) (throw 'skip t))) (setq message-size (vm-imap-get-message-size process n)) (vm-set-imap-status-need statblob message-size) (when (and (integerp vm-imap-max-message-size) (> message-size vm-imap-max-message-size) (progn (setq response (if vm-imap-ok-to-ask (vm-imap-ask-about-large-message process message-size n) 'skip)) (not (eq response 'retrieve)))) (cond ((and read-write can-delete (eq response 'delete)) (vm-inform 6 "Deleting message %d..." n) (vm-imap-delete-message process n) (setq did-delete t)) (vm-imap-ok-to-ask (vm-inform 7 "Skipping message %d..." n)) (t (vm-inform 5 "Skipping message %d in %s, too large (%d > %d)..." n folder message-size vm-imap-max-message-size))) (throw 'skip t)) (vm-inform 7 "Retrieving message %d (of %d) from %s..." n mailbox-count folder) (vm-imap-fetch-message process n use-body-peek nil) ; no headers-only (vm-imap-retrieve-to-target process destination statblob use-body-peek) (vm-imap-read-ok-response process) (vm-inform 7 "Retrieving message %d (of %d) from %s...done" n mailbox-count folder) (vm-increment retrieved) (and b-per-session (setq retrieved-bytes (+ retrieved-bytes message-size))) (if auto-expunge ;; The user doesn't want the messages kept in the mailbox. (when (and read-write can-delete) (vm-imap-delete-message process n) (setq did-delete t)) ;; If message retained on the server, record the UID (setq imap-retrieved-messages (cons (copy-sequence msgid) imap-retrieved-messages)) (setq did-retain t))) (vm-increment n)) (when did-delete ;; CLOSE forces an expunge and avoids the EXPUNGE ;; responses. (vm-imap-send-command process "CLOSE") (vm-imap-read-ok-response process) ;;---------------------------------- (vm-imap-session-type:set 'inactive) ;;---------------------------------- ) (not (equal retrieved 0)) ; return result )) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- (when did-retain (setq vm-imap-retrieved-messages imap-retrieved-messages) (when (eq vm-flush-interval t) (vm-stuff-imap-retrieved)) (vm-mark-folder-modified-p (current-buffer))) (when statblob (vm-imap-stop-status-timer statblob)) (when process (vm-imap-end-session process)) ))) (defun vm-imap-check-mail (source) "Check if there is new mail on the IMAP server mailbox SOURCE. Returns a boolean value." ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (let ((process nil) (handler (vm-find-file-name-handler source 'vm-imap-check-mail)) (retrieved vm-imap-retrieved-messages) (imapdrop (vm-imapdrop-sans-password source)) (count 0) msg-count recent-count uid-validity x response select mailbox source-list result) (unwind-protect (prog1 (save-excursion ; = save-current-buffer? ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (catch 'end-of-session (when handler (throw 'end-of-session (funcall handler 'vm-imap-check-mail source))) (setq process (vm-imap-make-session source nil "checkmail")) (unless process (throw 'end-of-session nil)) (set-buffer (process-buffer process)) (setq source-list (vm-parse source "\\([^:]+\\):?") mailbox (nth 3 source-list)) (setq select (vm-imap-select-mailbox process mailbox t) msg-count (car select) recent-count (nth 1 select) uid-validity (nth 2 select)) (when (zerop msg-count) (vm-store-folder-totals source '(0 0 0 0)) (throw 'end-of-session nil)) ;; sweep through the retrieval list, removing entries ;; that have been invalidated by the new UIDVALIDITY ;; value. (setq retrieved (vm-imap-clear-invalid-retrieval-entries imapdrop retrieved uid-validity)) (setq response (vm-imap-get-uid-list process 1 msg-count)) (if (null response) nil (if (null (car response)) ;; (nil . nil) is returned if there are no ;; messages in the mailbox. (progn (vm-store-folder-totals source '(0 0 0 0)) (throw 'end-of-session nil)) (while response (if (not (and (setq x (assoc (cdr (car response)) retrieved)) (equal (nth 1 x) imapdrop) (eq (nth 2 x) 'uid))) (vm-increment count)) (setq response (cdr response)))) (vm-store-folder-totals source (list count 0 0 0)) (throw 'end-of-session (not (eq count 0)))) (not (equal 0 (car select))))) (setq vm-imap-retrieved-messages retrieved)) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- (when process (vm-imap-end-session process) ;; (vm-imap-dump-uid-and-flags-data) )))) (defun vm-expunge-imap-messages () "Deletes all messages from IMAP mailbox that have already been retrieved into the current folder. VM sets the \\Deleted flag on all such messages on all the relevant IMAP servers and then immediately expunges." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-virtual-folder) (let ((process nil) (source nil) (trouble nil) (delete-count 0) (vm-global-block-new-mail t) (vm-imap-ok-to-ask t) (did-delete nil) msg-count can-delete read-write uid-validity select-response source-list folder uid-alist mailbox data mp match) (unwind-protect (save-excursion ; save-current-buffer? ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (setq vm-imap-retrieved-messages (sort vm-imap-retrieved-messages (function (lambda (a b) (cond ((string-lessp (nth 2 a) (nth 2 b)) t) ((string-lessp (nth 2 b) (nth 2 a)) nil) ((string-lessp (nth 1 a) (nth 1 b)) t) ((string-lessp (nth 1 b) (nth 1 a)) nil) ((string-lessp (nth 0 a) (nth 0 b)) t) (t nil)))))) (setq mp vm-imap-retrieved-messages) (while mp (catch 'replay (condition-case error-data (progn (setq data (car mp)) (when (not (equal source (nth 2 data))) (when process (when did-delete (vm-imap-send-command process "CLOSE") (vm-imap-read-ok-response process) ;;---------------------------------- (vm-imap-session-type:set 'inactive) ;; (vm-imap-dump-uid-and-flags-data) ;;---------------------------------- ) (vm-imap-end-session process) (setq process nil did-delete nil)) (setq source (nth 2 data)) (setq folder (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source))) (condition-case error-data (progn (vm-inform 6 "Opening IMAP session to %s..." folder) (setq process (vm-imap-make-session source vm-imap-ok-to-ask "expunge")) (if (null process) (signal 'vm-imap-protocol-error nil)) ;;-------------------------- (vm-buffer-type:set 'process) ;;-------------------------- (set-buffer (process-buffer process)) (setq source-list (vm-parse source "\\([^:]+\\):?") mailbox (nth 3 source-list) select-response (vm-imap-select-mailbox process mailbox t) msg-count (car select-response) uid-validity (nth 2 select-response) read-write (nth 3 select-response) can-delete (nth 4 select-response)) (setq mp (vm-imap-clear-invalid-retrieval-entries source mp uid-validity)) (unless (eq data (car mp)) ;; this entry must have been ;; discarded as invalid, so ;; skip it and process the ;; entry that is now at the ;; head of the list. (throw 'replay t)) (unless can-delete (error "Can't delete messages in mailbox %s, skipping..." mailbox)) (unless read-write (error "Mailbox %s is read-only, skipping..." mailbox)) (vm-inform 6 "Expunging messages in %s..." folder)) (error (if (cdr error-data) (apply 'message (cdr error-data)) (vm-warn 0 2 "Couldn't open IMAP session to %s, skipping..." folder)) (setq trouble (cons folder trouble)) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t))) (when (zerop msg-count) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t)) (setq uid-alist (vm-imap-get-uid-list process 1 msg-count)) (vm-imap-session-type:make-active)) (when (setq match (rassoc (car data) uid-alist)) (vm-imap-delete-message process (car match)) (setq did-delete t) (vm-increment delete-count))) (error (setq trouble (cons folder trouble)) (vm-warn 0 2 "Something signaled: %s" (prin1-to-string error-data)) (vm-inform 0 "Skipping rest of mailbox %s..." folder) (sleep-for 2) (while (equal (nth 2 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t))) (setq mp (cdr mp)))) (when did-delete (vm-imap-send-command process "CLOSE") (vm-imap-read-ok-response process) ;;---------------------------------- (vm-imap-session-type:set 'inactive) ;; (vm-imap-dump-uid-and-flags-data) ;;---------------------------------- ) (if trouble (progn ;;-------------------------- (vm-buffer-type:set 'scratch) ;;-------------------------- (set-buffer (get-buffer-create "*IMAP Expunge Trouble*")) (setq buffer-read-only nil) (erase-buffer) (insert (format "%s IMAP message%s expunged.\n\n" (if (zerop delete-count) "No" delete-count) (if (= delete-count 1) "" "s"))) (insert "VM had problems expunging messages from:\n") (nreverse trouble) (setq mp trouble) (while mp (insert " " (car mp) "\n") (setq mp (cdr mp))) (setq buffer-read-only t) (display-buffer (current-buffer))) (vm-inform 5 "%s IMAP message%s expunged." (if (zerop delete-count) "No" delete-count) (if (= delete-count 1) "" "s")))) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- (when process (vm-imap-end-session process))) (unless trouble (setq vm-imap-retrieved-messages nil) (when (> delete-count 0) (vm-mark-folder-modified-p (current-buffer)))))) (defun vm-prune-imap-retrieved-list (source) "Prune the X-VM-IMAP-Retrieved header of the current folder by examining which messages are still present in SOURCE. SOURCE should be a maildrop folder on an IMAP server. USR, 2011-04-06" (interactive (let ((this-command this-command) (last-command last-command)) (vm-follow-summary-cursor) (save-current-buffer (vm-session-initialization) (vm-select-folder-buffer) (vm-error-if-folder-empty) (list (vm-read-imap-folder-name "Prune messages from IMAP folder: " t nil nil))))) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-prune-imap-retrieved-list) '(vm-prune-imap-retrieved-list)) ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (let* ((imapdrop (vm-imapdrop-sans-password source)) (process (vm-imap-make-session imapdrop nil "list")) (uid-obarray (make-vector 67 0)) mailbox select mailbox-count uid-validity list retrieved-count pruned-count) (unwind-protect (with-current-buffer (process-buffer process) ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (setq mailbox (nth 3 (vm-parse source "\\([^:]+\\):?"))) (setq select (vm-imap-select-mailbox process mailbox t) mailbox-count (nth 0 select) uid-validity (nth 2 select)) (unless (eq mailbox-count 0) (setq list (vm-imap-get-message-data-list process 1 mailbox-count))) (mapc (lambda (tuple) (set (intern (cadr tuple) uid-obarray) (car tuple))) list)) ;; unwind-protections ;;----------------------------- (vm-buffer-type:exit) ;;----------------------------- (when process (vm-imap-end-session process))) (setq retrieved-count (length vm-imap-retrieved-messages)) (setq vm-imap-retrieved-messages (vm-imap-prune-retrieval-entries imapdrop vm-imap-retrieved-messages (lambda (tuple) (and (equal (nth 1 tuple) uid-validity) (intern-soft (car tuple) uid-obarray))))) (setq pruned-count (- retrieved-count (length vm-imap-retrieved-messages))) (if (= pruned-count 0) (vm-inform 5 "No messages to be pruned") (vm-mark-folder-modified-p) (vm-update-summary-and-mode-line) (vm-inform 5 "%d message%s pruned" pruned-count (if (= pruned-count 1) "" "s"))) )) (defun vm-imap-prune-retrieval-entries (source retrieved pred) "Prune RETRIEVED (a copy of `vm-imap-retrieved-messages') by keeping only those messages from SOURCE that satisfy PRED. SOURCE must be an IMAP maildrop spec without password info. USR, 2011-04-06" (let ((list retrieved) (prev nil)) (setq source (vm-imap-normalize-spec source)) (while list (if (and (equal source (vm-imap-normalize-spec (nth 2 (car list)))) (not (apply pred (car list) nil))) (if prev (setcdr prev (cdr list)) (setq retrieved (cdr retrieved))) (setq prev list)) (setq list (cdr list))) retrieved )) (defun vm-imap-clear-invalid-retrieval-entries (source retrieved uid-validity) "Remove from RETRIEVED (a copy of `vm-imap-retrieved-messages') all the entries for the password-free maildrop spec SOURCE which do not match the given UID-VALIDITY. USR, 2010-05-24" (vm-imap-prune-retrieval-entries source retrieved (lambda (tuple) (equal (nth 1 tuple) uid-validity)))) (defun vm-imap-recorded-uid-validity () "Return the UID-VALIDITY value recorded in the X-IMAP-Retrieved header of the current folder, or nil if none has been recorded." (let ((pos (vm-find vm-imap-retrieved-messages (lambda (record) (nth 1 record))))) (and pos (nth 1 (nth pos vm-imap-retrieved-messages))))) ;; -------------------------------------------------------------------- ;;; Server-side ;; ;; vm-establish-new-folder-imap-session: ;; (&optional interactive string) -> process ;; vm-re-establish-folder-imap-session: ;; (&optional interactive string) -> process ;; vm-establish-writable-imap-session: ;; (maildrop &optional interactive string) -> process ;; ;; -- Functions to handle the interaction with the IMAP server ;; ;; vm-imap-make-session: folder -> process ;; vm-imap-end-session: (process &optional buffer) -> void ;; vm-imap-check-connection: process -> void ;; ;; -- mailbox operations ;; vm-imap-mailbox-list: (process & bool) -> string list ;; vm-imap-create-mailbox: (process & string &optional bool) -> void ;; vm-imap-delete-mailbox: (process & string) -> void ;; vm-imap-rename-mailbox: (process & string & string) -> void ;; ;; -- lower level I/O ;; vm-imap-send-command: (process command &optional tag no-tag) -> ;; void ;; vm-imap-select-mailbox: (process & mailbox &optional bool bool) -> ;; (int int uid-validity bool bool (flag list)) ;; vm-imap-read-capability-response: process -> ? ;; vm-imap-read-greeting: process -> ? ;; vm-imap-read-ok-response: process -> ? ;; vm-imap-read-response: process -> server-resonse ;; vm-imap-read-response-and-verify: process -> server-resopnse ;; vm-imap-read-boolean-response: process -> ? ;; vm-imap-read-object: (process &optinal bool) -> ? ;; vm-imap-response-matches: (string &rest symbol) -> bool ;; vm-imap-response-bail-if-server-says-farewell: ;; response -> void + 'end-of-session exception ;; vm-imap-protocol-error: *&rest ;; ;; -- message opeations ;; vm-imap-retrieve-uid-and-flags-data: () -> void ;; vm-imap-dump-uid-and-flags-data: () -> void ;; vm-imap-dump-uid-seq-num-data: () -> void ;; vm-imap-get-uid-list: (process & int & int) -> (int . uid) list ;; vm-imap-get-message-data-list: (process & int & int) -> ;; (int . uid . string list) list ;; vm-imap-get-message-data: (process & vm-message) -> ;; (int . uid . string list) ;; vm-imap-save-message-flags: (process & int &optional bool) -> void ;; vm-imap-get-message-size: (process & int) -> int ;; vm-imap-get-uid-message-size: (process & uid) -> int ;; vm-imap-save-message: (process & int & string?) -> void ;; vm-imap-delete-message: (process & int) -> void ;; ;; vm-imap-ask-about-large-message: (process int int) -> ? ;; vm-imap-retrieve-to-target: (process target statblob bodypeek) -> bool ;; ;; -- to be phased out ;; vm-imap-get-message-flags: ;; (process & vm-message &optional norecord:bool) -> ;; -------------------------------------------------------------------- ;; The IMAP sessions work as follows: ;; Generally, sessions are created for get-new-mail, save-folder and ;; vm-imap-synchronize operations. All these operations read the ;; uid-and-flags-data and cache it internally. At this stage, the ;; IMAP session is said to be "valid", i.e., message numbers stored in ;; the cache are valid. As long as FETCH and STORE operations are ;; performed, the session remains valid. ;; When other IMAP operations are performed, the server can send ;; EXPUNGE responses and invalidate the cached message sequence ;; numbers. In this state, the IMAP session is "active", but not ;; "valid". Only UID-based commands can be issued in this state. ;;;###autoload (defun vm-imap-make-session (source &optional interactive purpose) "Create a new IMAP session for the IMAP mail box SOURCE. Optional argument INTERACTIVE says the operation has been invoked interactively, and the optional argument PURPOSE is inserted in the process buffer for tracing purposes. Returns the process or nil if the session could not be created." (let ((shutdown nil) ; whether process is to be shutdown (folder-type vm-folder-type) process ooo success (folder (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source))) (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (use-ssl nil) (use-ssh nil) (session-name "IMAP") (process-connection-type nil) greeting host port mailbox auth user pass authinfo source-list imap-buffer source-nopwd-nombox) (vm-imap-log-token 'make) ;; parse the maildrop (setq source-list (vm-parse source "\\([^:]*\\):?" 1 7) host (nth 1 source-list) port (nth 2 source-list) ;; mailbox (nth 3 source-list) auth (nth 4 source-list) user (nth 5 source-list) pass (nth 6 source-list) source-nopwd-nombox (vm-imapdrop-sans-personal-info source)) (cond ((equal auth "preauth") t) ((equal "imap-ssl" (car source-list)) (setq use-ssl t session-name "IMAP over SSL")) ((equal "imap-ssh" (car source-list)) (setq use-ssh t session-name "IMAP over SSH"))) (vm-imap-check-for-server-spec source host port auth user pass use-ssl use-ssh) (setq port (string-to-number port)) (when (and (equal pass "*") (not (equal auth "preauth"))) (setq pass (car (cdr (assoc source-nopwd-nombox vm-imap-passwords)))) (when (and (null pass) (boundp 'auth-sources) (fboundp 'auth-source-user-or-password)) (cond ((and (setq authinfo (auth-source-user-or-password '("login" "password") (vm-imap-account-name-for-spec source) port)) (equal user (car authinfo))) (setq pass (cadr authinfo))) ((and (setq authinfo (auth-source-user-or-password '("login" "password") host port)) (equal user (car authinfo))) (setq pass (cadr authinfo))))) (while (and (null pass) interactive) (setq pass (read-passwd (format "IMAP password for %s: " folder))) (when (equal pass "") (vm-warn 0 2 "Password cannot be empty") (setq pass nil))) (when (null pass) (error "Need password for %s for %s" folder purpose))) ;; get the trace buffer (setq imap-buffer (vm-make-work-buffer (vm-make-trace-buffer-name session-name host))) (vm-imap-log-token imap-buffer) (unwind-protect (catch 'end-of-session (save-excursion ; = save-current-buffer? (set-buffer imap-buffer) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (setq vm-folder-type (or folder-type vm-default-folder-type)) (buffer-disable-undo imap-buffer) (make-local-variable 'vm-imap-read-point) ;; clear the trace buffer of old output (erase-buffer) ;; Tell MULE not to mess with the text. (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-binary-coding-system) t)) (if (equal auth "preauth") (setq process (run-hook-with-args-until-success 'vm-imap-session-preauth-hook host port mailbox user pass))) (if (processp process) (set-process-buffer process (current-buffer)) (insert "Starting " session-name " session " (current-time-string) "\r\n") (insert (format "-- connecting to %s:%s\r\n" host port)) ;; open the connection to the server (condition-case err (cond (use-ssl (if (null vm-stunnel-program) (setq process (open-network-stream session-name imap-buffer host port :type 'tls)) (vm-setup-stunnel-random-data-if-needed) (setq process (apply 'start-process session-name imap-buffer vm-stunnel-program (nconc (vm-stunnel-configuration-args host port) vm-stunnel-program-switches))))) (use-ssh (setq process (open-network-stream session-name imap-buffer "127.0.0.1" (vm-setup-ssh-tunnel host port)))) (t (setq process (open-network-stream session-name imap-buffer host port)))) (error (vm-warn 0 1 "%s" (error-message-string err)) (setq shutdown t) (throw 'end-of-session nil)))) (setq shutdown t) (setq vm-imap-read-point (point)) (vm-process-kill-without-query process) (if (setq greeting (vm-imap-read-greeting process)) (insert-before-markers (format "-- connected for %s\r\n" purpose)) (delete-process process) ; why here? USR (throw 'end-of-session nil)) (set (make-local-variable 'vm-imap-session-done) nil) ;; record server capabilities (vm-imap-send-command process "CAPABILITY") (if (null (setq ooo (vm-imap-read-capability-response process))) (throw 'end-of-session nil)) (set (make-local-variable 'vm-imap-capabilities) (car ooo)) (set (make-local-variable 'vm-imap-auth-methods) (nth 1 ooo)) ;; authentication (cond ((equal auth "login") ;; LOGIN must be supported by all imap servers, ;; no need to check for it in CAPABILITIES. (vm-imap-send-command process (format "LOGIN %s %s" (vm-imap-quote-string user) (vm-imap-quote-string pass))) (unless (vm-imap-read-ok-response process) (vm-inform 0 "IMAP password for %s incorrect" folder) (setq vm-imap-passwords (vm-delete (lambda (pair) (equal (car pair) source-nopwd-nombox)) vm-imap-passwords)) ;; don't sleep unless we're running synchronously. (if vm-imap-ok-to-ask (sleep-for 2)) (throw 'end-of-session nil)) (unless (assoc source-nopwd-nombox vm-imap-passwords) (setq vm-imap-passwords (cons (list source-nopwd-nombox pass) vm-imap-passwords))) (setq success t) ;;-------------------------------- (vm-imap-session-type:set 'active)) ;;-------------------------------- ((equal auth "cram-md5") (if (not (vm-imap-auth-method 'CRAM-MD5)) (error "CRAM-MD5 authentication unsupported by this server")) (let ((ipad (make-string 64 54)) (opad (make-string 64 92)) (command "AUTHENTICATE CRAM-MD5") (secret (concat pass (make-string (max 0 (- 64 (length pass))) 0))) response p challenge answer) (vm-imap-send-command process command) (setq response (vm-imap-read-response-and-verify process command)) (cond ((vm-imap-response-matches response '+ 'atom) (setq p (cdr (nth 1 response)) challenge (buffer-substring (nth 0 p) (nth 1 p)) challenge (vm-mime-base64-decode-string challenge))) (t (vm-imap-protocol-error "Don't understand AUTHENTICATE response"))) (setq answer (concat user " " (vm-md5-string (concat (vm-xor-string secret opad) (vm-md5-raw-string (concat (vm-xor-string secret ipad) challenge))))) answer (vm-mime-base64-encode-string answer)) (vm-imap-send-command process answer nil t) (unless (vm-imap-read-ok-response process) (vm-inform 0 "IMAP password for %s incorrect" folder) ;; don't sleep unless we're running synchronously. (if vm-imap-ok-to-ask (sleep-for 2)) (throw 'end-of-session nil)) (setq success t) (unless (assoc source-nopwd-nombox vm-imap-passwords) (setq vm-imap-passwords (cons (list source-nopwd-nombox pass) vm-imap-passwords))) ;;------------------------------- (vm-imap-session-type:set 'active))) ;;------------------------------- ((equal auth "preauth") (unless (eq greeting 'preauth) (vm-inform 0 "IMAP session was not pre-authenticated") ;; don't sleep unless we're running synchronously. (if vm-imap-ok-to-ask (sleep-for 2)) (throw 'end-of-session nil)) (setq success t) ;;------------------------------- (vm-imap-session-type:set 'active) ;;------------------------------- ) (t (error "Don't know how to authenticate using %s" auth))) (setq shutdown nil))) ;; unwind-protection ;;------------------- (vm-buffer-type:exit) ;;------------------- (if shutdown (vm-imap-end-session process imap-buffer)) (vm-tear-down-stunnel-random-data)) (if success process ;; try again if possible, treat it as non-interactive the next time (when interactive (vm-imap-make-session source nil purpose))))) (defun vm-imap-check-for-server-spec (source host port auth user pass use-ssl use-ssh) (when (null host) (error "No host in IMAP maildrop specification, \"%s\"" source)) (when (or (null port) (not (string-match "^[0-9]+$" port))) (error "No port in IMAP maildrop specification, \"%s\"" source)) (when (null auth) (error "No authentication method in IMAP maildrop specification, \"%s\"" source)) (when (null user) (error "No user in IMAP maildrop specification, \"%s\"" source)) (when (null pass) (error "No password in IMAP maildrop specification, \"%s\"" source)) ;; (when use-ssl ;; (if (null vm-stunnel-program) ;; (error "vm-stunnel-program must be non-nil to use IMAP over SSL."))) (when use-ssh (if (null vm-ssh-program) (error "vm-ssh-program must be non-nil to use IMAP over SSH."))) ) ;;;###autoload (defun vm-imap-end-session (process &optional imap-buffer keep-buffer) "Kill the IMAP session represented by PROCESS. PROCESS could be nil or be already closed. Optional argument IMAP-BUFFER specifies the process-buffer. If the optional argument KEEP-BUFFER is non-nil, the process buffer is retained, otherwise it is killed as well." (vm-imap-log-token 'end-session) (when (and process (null imap-buffer)) (setq imap-buffer (process-buffer process))) (when (and process (memq (process-status process) '(open run)) (buffer-live-p (process-buffer process))) (unwind-protect (save-excursion ; = save-current-buffer? (set-buffer imap-buffer) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- ;; vm-imap-end-session might have already been called on ;; this process, so don't logout and schedule the killing ;; the process again if it's already been done. (unwind-protect (condition-case nil (if vm-imap-session-done ;;------------------------------------- (vm-imap-session-type:assert 'inactive) ;;------------------------------------- (vm-imap-send-command process "LOGOUT") ;; we don't care about the response. ;; try reading it anyway and trap any errors. (vm-imap-read-ok-response process)) (vm-imap-protocol-error ; handler nil) ; ignore errors (error nil)) ; handler ;; unwind-protections (setq vm-imap-session-done t) ;;---------------------------------- (vm-imap-session-type:set 'inactive) ;;---------------------------------- ;; This is just for tracing purposes (goto-char (point-max)) (insert "ending IMAP session " (current-time-string) "\r\n") ;; Schedule killing of the process after a delay to allow ;; any output to be received first (if (fboundp 'add-async-timeout) (add-async-timeout 2 'delete-process process) (run-at-time 2 nil 'delete-process process)))) ;; unwind-protections ;;---------------------------------- (vm-buffer-type:exit) ;;---------------------------------- )) (when (and imap-buffer (buffer-live-p imap-buffer)) (if (and (null vm-imap-keep-trace-buffer) (not keep-buffer)) (kill-buffer imap-buffer) (vm-keep-some-buffers imap-buffer 'vm-kept-imap-buffers vm-imap-keep-trace-buffer "saved ") )) ) (defun vm-imap-check-connection (process) ;;------------------------------ ;; (vm-buffer-type:assert 'process) ;;------------------------------ (cond ((not (memq (process-status process) '(open run))) ;;------------------- ;; (vm-buffer-type:exit) ;;------------------- (vm-imap-normal-error "not connected")) ((not (buffer-live-p (process-buffer process))) ;;------------------- ;; (vm-buffer-type:exit) ;;------------------- (vm-imap-protocol-error "IMAP process %s's buffer has been killed" process)))) (defun vm-imap-send-command (process command &optional tag no-tag) (vm-imap-log-token 'send) ;;------------------------------ (vm-buffer-type:assert 'process) ;;------------------------------ (vm-imap-check-connection process) (if (not (= (point) (point-max))) (vm-imap-log-tokens (list 'send1 (point) (point-max)))) (goto-char (point-max)) ;; try if it makes a difference to get pending output here, use timeout ;; (accept-process-output process 0 0.01) ;; (if (not (= (point) (point-max))) ;; (vm-imap-log-tokens (list 'send2 (point) (point-max)))) ;; (goto-char (point-max)) (or no-tag (insert-before-markers (or tag "VM") " ")) (let ((case-fold-search t)) (if (string-match "^LOGIN" command) (insert-before-markers "LOGIN \r\n") (insert-before-markers command "\r\n"))) (setq vm-imap-read-point (point)) ;; previously we had a process-send-string call for each string ;; to avoid extra consing but that caused a lot of packet overhead. (if no-tag (process-send-string process (format "%s\r\n" command)) (process-send-string process (format "%s %s\r\n" (or tag "VM") command)))) (defun vm-imap-select-mailbox (process mailbox &optional just-retrieve just-examine) "I/O function to select an IMAP mailbox PROCESS - the IMAP process MAILBOX - the name of the mailbox to be selected JUST-RETRIEVE - select the mailbox for retrieval, no writing JUST-EXAMINE - select the mailbox in a read-only (examine) mode Returns a list containing: int msg-count - number of messages in the mailbox int recent-count - number of recent messages in the mailbox string uid-validity - the UID validity value of the mailbox bool read-write - whether the mailbox is writable bool can-delete - whether the mailbox allows message deletion server-response permanent-flags - permanent flags used in the mailbox." ;;------------------------------ (vm-buffer-type:assert 'process) ;;------------------------------ (let ((imap-buffer (current-buffer)) (command (if just-examine "EXAMINE" "SELECT")) tok response p (flags nil) (permanent-flags nil) (msg-count nil) (recent-count nil) (uid-validity nil) (read-write (not just-examine)) (can-delete t) (need-ok t)) (vm-imap-log-token 'select-mailbox) (vm-imap-send-command process (format "%s %s" command (vm-imap-quote-string mailbox))) (while need-ok (setq response (vm-imap-read-response-and-verify process command)) (cond ((vm-imap-response-matches response '* 'OK 'vector) (setq p (cdr (nth 2 response))) (cond ((vm-imap-response-matches p 'UIDVALIDITY 'atom) (setq tok (nth 1 p)) (setq uid-validity (buffer-substring (nth 1 tok) (nth 2 tok)))) ((vm-imap-response-matches p 'PERMANENTFLAGS 'list) (setq permanent-flags (nth 1 p))))) ((vm-imap-response-matches response '* 'FLAGS 'list) (setq flags (nth 2 response))) ((vm-imap-response-matches response '* 'atom 'EXISTS) (setq tok (nth 1 response)) (goto-char (nth 1 tok)) (setq msg-count (read imap-buffer))) ((vm-imap-response-matches response '* 'atom 'RECENT) (setq tok (nth 1 response)) (goto-char (nth 1 tok)) (setq recent-count (read imap-buffer))) ((vm-imap-response-matches response 'VM 'OK '(vector READ-WRITE)) (setq need-ok nil read-write t)) ((vm-imap-response-matches response 'VM 'OK '(vector READ-ONLY)) (setq need-ok nil read-write nil)) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) (if (null flags) (vm-imap-protocol-error "FLAGS missing from SELECT responses")) (if (null msg-count) (vm-imap-protocol-error "EXISTS missing from SELECT responses")) (if (null uid-validity) (vm-imap-protocol-error "UIDVALIDITY missing from SELECT responses")) (setq can-delete (vm-imap-scan-list-for-flag flags "\\Deleted")) (unless just-retrieve (if (vm-imap-scan-list-for-flag permanent-flags "\\*") (unless (vm-imap-scan-list-for-flag flags "\\Seen") (vm-inform 5 "Warning: No permanent changes permitted for the IMAP mailbox")) (vm-inform 5 "Warning: No user-definable flags available for the IMAP mailbox"))) ;;------------------------------- (vm-imap-session-type:set 'active) ;;------------------------------- (list msg-count recent-count uid-validity read-write can-delete permanent-flags))) (defun vm-imap-read-expunge-response (process) (let ((list nil) (imap-buffer (current-buffer)) (need-ok t) tok msg-num response ) (vm-imap-log-token 'read-expunge) (while need-ok (setq response (vm-imap-read-response-and-verify process "EXPUNGE")) (cond ((vm-imap-response-matches response '* 'atom 'EXPUNGE) (setq tok (nth 1 response)) (goto-char (nth 1 tok)) (setq msg-num (read imap-buffer)) (setq list (cons msg-num list))) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) ;;-------------------------------- (vm-imap-session-type:set 'active) ; seq nums are now invalid ;;-------------------------------- (nreverse list))) (defun vm-imap-get-uid-list (process first last) "I/O function to read the uid's of a message range PROCESS - the IMAP process FIRST - message sequence number of the first message in the range LAST - message sequene number of the last message in the range Returns an alist with pairs int msg-num - message sequence number of a message string uid - uid of the message or nil indicating failure If there are no messages in the range then (nil) is returned. See also `vm-imap-get-message-data-list' for a newer version of this function." (let ((list nil) (imap-buffer (current-buffer)) tok msg-num uid response p (need-ok t)) (vm-imap-log-token 'uid-list) ;;---------------------------------- (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "FETCH %s:%s (UID)" first last)) (while need-ok (setq response (vm-imap-read-response-and-verify process "UID FETCH")) (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list) (setq p (cdr (nth 3 response))) (if (not (vm-imap-response-matches p 'UID 'atom)) (vm-imap-protocol-error "expected (UID number) in FETCH response")) (setq tok (nth 1 response)) (goto-char (nth 1 tok)) (setq msg-num (read imap-buffer)) (setq tok (nth 1 p)) (setq uid (buffer-substring (nth 1 tok) (nth 2 tok)) list (cons (cons msg-num uid) list))) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) ;;------------------------------- (vm-imap-session-type:set 'valid) ;;------------------------------- ;; returning nil means the uid fetch failed so return ;; something other than nil if there aren't any messages. (if (null list) (cons nil nil) list ))) ;; This function is not recommended, but is available to use when ;; caching uid-and-flags data might be too expensive. (defun vm-imap-get-message-data (process m uid-validity) "I/O function to read the flags of a message PROCESS - The IMAP process M - a vm-message uid-validity - the folder's uid-validity Returns (msg-num: int . uid: string . size: string . flags: string list) Throws vm-imap-protocol-error for failure. See also `vm-imap-get-message-list' for a bulk version of this function." (let ((imap-buffer (current-buffer)) response tok need-ok msg-num list) (if (not (equal (vm-imap-uid-validity-of m) uid-validity)) (vm-imap-normal-error "message has invalid uid")) (vm-imap-log-tokens (list 'message-data (current-buffer))) ;;---------------------------------- (vm-imap-session-type:assert 'valid) ;;---------------------------------- (vm-imap-send-command process (format "SEARCH UID %s" (vm-imap-uid-of m))) (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "UID")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((vm-imap-response-matches response '* 'SEARCH 'atom) (if (null (setq tok (nth 2 response))) (vm-imap-normal-error "message not found on server")) (goto-char (nth 1 tok)) (setq msg-num (read imap-buffer)) ))) (setq list (vm-imap-get-message-data-list process msg-num msg-num)) (car list))) (defun vm-imap-get-message-data-list (process first last) "I/O function to read the flags of a message range PROCESS - the IMAP process FIRST - message sequence number of the first message in the range LAST - message sequene number of the last message in the range Returns an assoc list with entries int msg-num - message sequence number of a message string uid - uid of the message string size - message size (string list) flags - list of flags for the message throws vm-imap-protocol-error for failure. See `vm-imap-get-message-data' for getting the data for individual messages. `vm-imap-get-uid-list' is an older version of this function." (let ((list nil) (imap-buffer (current-buffer)) tok msg-num uid size flag flags response p pl (need-ok t)) (vm-imap-log-token (list 'message-data-list (current-buffer))) ;;---------------------------------- (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'message-data vm-buffer-type-trail))) (vm-buffer-type:assert 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "FETCH %s:%s (UID RFC822.SIZE FLAGS)" first last)) (while need-ok (setq response (vm-imap-read-response-and-verify process "FLAGS FETCH")) (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list) (setq p (cdr (nth 3 response))) (setq tok (nth 1 response)) (goto-char (nth 1 tok)) (setq msg-num (read imap-buffer)) (while p (cond ((vm-imap-response-matches p 'UID 'atom) (setq tok (nth 1 p)) (setq uid (buffer-substring (nth 1 tok) (nth 2 tok))) (setq p (nthcdr 2 p))) ((vm-imap-response-matches p 'RFC822\.SIZE 'atom) (setq tok (nth 1 p)) (setq size (buffer-substring (nth 1 tok) (nth 2 tok))) (setq p (nthcdr 2 p))) ((vm-imap-response-matches p 'FLAGS 'list) (setq pl (cdr (nth 1 p)) flags nil) (while pl (setq tok (car pl)) (if (not (vm-imap-response-matches (list tok) 'atom)) (vm-imap-protocol-error "expected atom in FLAGS list in FETCH response")) (setq flag (downcase (buffer-substring (nth 1 tok) (nth 2 tok))) flags (cons flag flags) pl (cdr pl))) (setq p (nthcdr 2 p))) (t (vm-imap-protocol-error "expected UID, RFC822.SIZE and (FLAGS list) in FETCH response")) )) (setq list (cons (cons msg-num (cons uid (cons size flags))) list))) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) list)) (defun vm-imap-ask-about-large-message (process size n) (let ((work-buffer nil) (imap-buffer (current-buffer)) (need-ok t) (need-header t) response fetch-response list p start end) (unwind-protect (save-excursion ; save-current-buffer? ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (save-window-excursion ;;---------------------------------- (vm-imap-session-type:assert 'valid) ;;---------------------------------- (vm-imap-send-command process (format "FETCH %d (RFC822.HEADER)" n)) (while need-ok (setq response (vm-imap-read-response-and-verify process "header FETCH")) (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list) (setq fetch-response response need-header nil)) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) (if need-header (vm-imap-protocol-error "FETCH OK sent before FETCH response")) (setq vm-imap-read-point (point-marker)) (setq list (cdr (nth 3 fetch-response))) (if (not (vm-imap-response-matches list 'RFC822\.HEADER 'string)) (vm-imap-protocol-error "expected (RFC822.HEADER string) in FETCH response")) (setq p (nth 1 list) start (nth 1 p) end (nth 2 p)) (setq work-buffer (generate-new-buffer "*imap-glop*")) ;;-------------------------- (vm-buffer-type:set 'scratch) ;;-------------------------- (set-buffer work-buffer) (insert-buffer-substring imap-buffer start end) (vm-imap-cleanup-region (point-min) (point-max)) (vm-display-buffer work-buffer) (setq minibuffer-scroll-window (selected-window)) (goto-char (point-min)) (if (re-search-forward "^Received:" nil t) (progn (goto-char (match-beginning 0)) (vm-reorder-message-headers nil :keep-list vm-visible-headers :discard-regexp vm-invisible-header-regexp))) (set-window-point (selected-window) (point)) (if (y-or-n-p (format "Retrieve message %d (size = %d)? " n size)) 'retrieve (if (y-or-n-p (format "Delete message %d (size = %d) from maildrop? " n size)) 'delete 'skip)))) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- (when work-buffer (kill-buffer work-buffer))))) (defun vm-imap-retrieve-to-target (process target statblob bodypeek) "Read a mail message from PROCESS and store it in TARGET, which is either a file or a buffer. Report status using STATBLOB. The boolean BODYPEEK tells if the bodypeek function is available for the IMAP server." (vm-assert (not (null vm-imap-read-point))) (vm-imap-log-token 'retrieve) (let ((***start vm-imap-read-point) ; avoid dynamic binding of 'start' end fetch-response list p) (goto-char ***start) (vm-set-imap-status-got statblob 0) (let* ((func (function (lambda (beg end len) (if vm-imap-read-point (progn (vm-set-imap-status-got statblob (- end ***start)) (if (zerop (% (random) 10)) (vm-imap-report-retrieval-status statblob))))))) ;; this seems to slow things down. USR, 2008-04-25 ;; reenabled. USR, 2010-09-17 (after-change-functions (cons func after-change-functions)) (need-ok t) response) (setq response (vm-imap-read-response-and-verify process "message FETCH")) (cond ((vm-imap-response-matches response '* 'atom 'FETCH 'list) (setq fetch-response response)) (t (vm-imap-normal-error "cannot retrieve message from the server")))) ;; must make the read point a marker so that it stays fixed ;; relative to the text when we modify things below. (setq vm-imap-read-point (point-marker)) (setq list (cdr (nth 3 fetch-response))) (cond (bodypeek (cond ((vm-imap-response-matches list 'BODY '(vector) 'string) (setq p (nth 2 list) ***start (nth 1 p))) ((vm-imap-response-matches list 'UID 'atom 'BODY '(vector) 'string) (setq p (nth 4 list) ***start (nth 1 p))) (t (vm-imap-protocol-error "expected (BODY[] string) in FETCH response")))) (t (if (not (vm-imap-response-matches list 'RFC822 'string)) (vm-imap-protocol-error "expected (RFC822 string) in FETCH response")) (setq p (nth 1 list) ***start (nth 1 p)))) (goto-char (nth 2 p)) (setq end (point-marker)) (vm-set-imap-status-need statblob nil) (vm-imap-cleanup-region ***start end) (vm-munge-message-separators vm-folder-type ***start end) (goto-char ***start) (vm-set-imap-status-got statblob nil) ;; avoid the consing and stat() call for all but babyl ;; files, since this will probably slow things down. ;; only babyl files have the folder header, and we ;; should only insert it if the crash box is empty. (if (and (eq vm-folder-type 'babyl) (cond ((stringp target) (let ((attrs (file-attributes target))) (or (null attrs) (equal 0 (nth 7 attrs))))) ((bufferp target) (with-current-buffer target (zerop (buffer-size)))))) (let ((opoint (point))) (vm-convert-folder-header nil vm-folder-type) ;; if start is a marker, then it was moved ;; forward by the insertion. restore it. (setq ***start opoint) (goto-char ***start) (vm-skip-past-folder-header))) (insert (vm-leading-message-separator)) (save-restriction (narrow-to-region (point) end) (vm-convert-folder-type-headers 'baremessage vm-folder-type)) (goto-char end) ;; Some IMAP servers don't understand Sun's stupid ;; From_-with-Content-Length style folder and assume the last ;; newline in the message is a separator. And so the server ;; strips it, leaving us with a message that does not end ;; with a newline. Add the newline if needed. ;; ;; Added From_ folders among the ones to be repaired. USR, 2010-05-19 (if (and (not (eq ?\n (char-after (1- (point))))) (memq vm-folder-type '(From_-with-Content-Length BellFrom_ From_))) (insert-before-markers "\n")) (insert-before-markers (vm-trailing-message-separator)) (if (stringp target) ;; Set file type to binary for DOS/Windows. I don't know if ;; this is correct to do or not; it depends on whether the ;; the CRLF or the LF newline convention is used on the inbox ;; associated with this crashbox. This setting assumes the LF ;; newline convention is used. (let ((buffer-file-type t) (selective-display nil)) (write-region ***start end target t 0)) (let ((b (current-buffer))) (with-current-buffer target ;;---------------------------- (vm-buffer-type:enter 'unknown) ;;---------------------------- (let ((buffer-read-only nil)) (insert-buffer-substring b ***start end) ) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (delete-region ***start end) t )) (defun vm-imap-delete-messages (process beg end) ;;---------------------------------- (vm-buffer-type:assert 'process) (vm-imap-session-type:assert 'valid) ;;---------------------------------- (vm-imap-send-command process (format "STORE %d:%d +FLAGS.SILENT (\\Deleted)" beg end)) (if (null (vm-imap-read-ok-response process)) (vm-imap-normal-error "deletion failed"))) (defun vm-imap-get-message-size (process n) "Use imap PROCESS to query the size the message with sequence number N. Returns the size. See also `vm-imap-get-uid-message-size'." (let ((imap-buffer (current-buffer)) tok size response p (need-size t) (need-ok t)) ;;---------------------------------- (vm-buffer-type:assert 'process) (vm-imap-session-type:assert 'valid) (vm-imap-log-tokens (list 'message-size (current-buffer))) ;;---------------------------------- (vm-imap-send-command process (format "FETCH %d:%d (RFC822.SIZE)" n n)) (while need-ok (setq response (vm-imap-read-response-and-verify process "size FETCH")) (cond ((and need-size (vm-imap-response-matches response '* 'atom 'FETCH 'list)) (setq need-size nil) (setq p (cdr (nth 3 response))) (catch 'done (while p (if (vm-imap-response-matches p 'RFC822\.SIZE 'atom) (throw 'done nil) (setq p (nthcdr 2 p)) (if (null p) (vm-imap-protocol-error "expected (RFC822.SIZE number) in FETCH response"))))) (setq tok (nth 1 p)) (goto-char (nth 1 tok)) (setq size (read imap-buffer))) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) size )) (defun vm-imap-get-uid-message-size (process uid) "Uses imap PROCESS to get the size of the message with UID. Returns the size. See also `vm-imap-get-message-size'." (let ((imap-buffer (current-buffer)) tok size response p (need-size t) (need-ok t)) ;;---------------------------------- (vm-buffer-type:assert 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-log-token 'uid-size) (vm-imap-send-command process (format "UID FETCH %s:%s (RFC822.SIZE)" uid uid)) (while need-ok (setq response (vm-imap-read-response-and-verify process "size FETCH")) (cond ((and need-size (vm-imap-response-matches response '* 'atom 'FETCH 'list)) (setq p (cdr (nth 3 response))) (while p (cond ((vm-imap-response-matches p 'UID 'atom) (setq tok (nth 1 p)) (unless (equal uid (buffer-substring (nth 1 tok) (nth 2 tok))) (vm-imap-protocol-error "UID number mismatch in SIZE query")) (setq p (nthcdr 2 p))) ((vm-imap-response-matches p 'RFC822\.SIZE 'atom) (setq tok (nth 1 p)) (goto-char (nth 1 tok)) (setq size (read imap-buffer)) (setq need-size nil) (setq p (nthcdr 2 p))) (t (setq p (nthcdr 2 p)))))) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ;; Otherwise, skip the response )) (if need-size (vm-imap-protocol-error "expected UID, RFC822.SIZE in FETCH response") size ))) (defun vm-imap-read-capability-response (process) ;;---------------------------------- (vm-buffer-type:assert 'process) ;;---------------------------------- (vm-imap-log-token 'read-capability) (let (response r cap-list auth-list (need-ok t)) (while need-ok (setq response (vm-imap-read-response-and-verify process "CAPABILITY")) (if (vm-imap-response-matches response 'VM 'OK) (setq need-ok nil) (if (not (vm-imap-response-matches response '* 'CAPABILITY)) nil ;; skip * CAPABILITY (setq response (cdr (cdr response))) (while response (setq r (car response)) (if (not (eq (car r) 'atom)) nil (if (save-excursion (goto-char (nth 1 r)) (let ((case-fold-search t)) (eq (re-search-forward "AUTH=." (nth 2 r) t) (+ 6 (nth 1 r))))) (progn (setq auth-list (cons (intern (upcase (buffer-substring (+ 5 (nth 1 r)) (nth 2 r)))) auth-list))) (setq r (car response)) (if (not (eq (car r) 'atom)) nil (setq cap-list (cons (intern (upcase (buffer-substring (nth 1 r) (nth 2 r)))) cap-list))))) (setq response (cdr response)))))) (if (or cap-list auth-list) (list (nreverse cap-list) (nreverse auth-list)) nil))) (defun vm-imap-read-greeting (process) ;;---------------------------------- (vm-buffer-type:assert 'process) ;;---------------------------------- (vm-imap-log-token 'read-greeting) (let (response) (setq response (vm-imap-read-response process)) (cond ((vm-imap-response-matches response '* 'OK) t ) ((vm-imap-response-matches response '* 'PREAUTH) 'preauth ) (t nil)))) (defun vm-imap-read-ok-response (process) ;;---------------------------------- (vm-buffer-type:assert 'process) ;;---------------------------------- (vm-imap-log-token 'read-ok) (let (response retval (done nil)) (while (not done) (setq response (vm-imap-read-response process)) (cond ((vm-imap-response-matches response '*) nil ) ((vm-imap-response-matches response 'VM 'OK) (setq retval t done t)) ((vm-imap-response-matches response 'VM 'NO) (setq retval nil done t)) ((vm-imap-response-matches response 'VM 'BAD) (setq retval nil done t) (vm-imap-normal-error "Server said BAD")) (t (vm-imap-protocol-error "Did not receive OK response")))) retval )) (defun vm-imap-cleanup-region (start end) (setq end (vm-marker end)) (save-excursion (goto-char start) ;; CRLF -> LF (while (and (< (point) end) (search-forward "\r\n" end t)) (replace-match "\n" t t))) (set-marker end nil)) (defun vm-imap-read-response (process) ;; Reads a line of respose from the imap PROCESS ;;-------------------------------------------- ;; This assertion often fails for some reason, ;; perhaps some asynchrony involved? ;; Assertion check being disabled unless debugging is on. (if vm-buffer-type-debug (vm-buffer-type:assert 'process)) (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'read vm-buffer-type-trail))) ;;-------------------------------------------- (vm-imap-log-tokens (list 'response vm-imap-read-point)) (let ((list nil) tail obj) (when vm-buffer-type-debug (unless vm-imap-read-point (debug nil "vm-imap-read-response: null vm-imap-read-point"))) (goto-char vm-imap-read-point) (catch 'done (while t (setq obj (vm-imap-read-object process)) (if (eq (car obj) 'end-of-line) (throw 'done list)) (if (null list) (setq list (cons obj nil) tail list) (setcdr tail (cons obj nil)) (setq tail (cdr tail))))))) (defun vm-imap-read-response-and-verify (process &optional command-desc) ;; Reads a line of response from the imap PROCESS and checks for ;; standard errors like "BAD" and "BYE". Optional COMMAND-DESC is a ;; command description that can be printed with the error message. ;;-------------------------------------------- ;; This assertion often fails for some reason, ;; perhaps some asynchrony involved? ;; Assertion check being disabled unless debugging is on. (if vm-buffer-type-debug (vm-buffer-type:assert 'process)) (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'verify vm-buffer-type-trail))) ;;-------------------------------------------- (let ((response (vm-imap-read-response process))) (if (vm-imap-response-matches response 'VM 'NO) (vm-imap-normal-error (format "server said NO"))) (if (vm-imap-response-matches response 'VM 'BAD) (vm-imap-normal-error (format "server said BAD"))) (if (vm-imap-response-matches response '* 'BYE) (vm-imap-normal-error (format "server disconnected"))) response)) (defun vm-imap-read-object (process &optional skip-eol) ;;---------------------------------- ;; Originally, this assertion failed often for some reason, ;; perhaps some asynchrony involved? ;; It has been mostly chased up by now. (Nov 2009) ;; Still assertion check being disabled unless debugging is on. (when vm-buffer-type-debug (vm-buffer-type:assert 'process)) (vm-imap-log-tokens (list 'object (current-buffer))) ;;---------------------------------- (let ((done nil) opoint (token nil)) (unwind-protect (while (not done) ; object continuing (skip-chars-forward " \t") (cond ((< (- (point-max) (point)) 2) (setq opoint (point)) (vm-imap-check-connection process) ;; point might change here? (vm-accept-process-output process) (goto-char opoint)) ((looking-at "\r\n") (forward-char 2) (setq token '(end-of-line) done (not skip-eol))) ((looking-at "\n") (vm-warn 0 2 "missing CR before LF - possible connection problem") (forward-char 1) (setq token '(end-of-line) done (not skip-eol))) ((looking-at "\\[") (forward-char 1) (let* ((list (list 'vector)) (tail list) obj) (setq obj (vm-imap-read-object process t)) (while (not (eq (car obj) 'close-bracket)) (when (eq (car obj) 'close-paren) (vm-imap-protocol-error "unexpected )")) (setcdr tail (cons obj nil)) (setq tail (cdr tail)) (setq obj (vm-imap-read-object process t))) (setq token list done t))) ((looking-at "\\]") (forward-char 1) (setq token '(close-bracket) done t)) ((looking-at "(") (forward-char 1) (let* ((list (list 'list)) (tail list) obj) (setq obj (vm-imap-read-object process t)) (while (not (eq (car obj) 'close-paren)) (when (eq (car obj) 'close-bracket) (vm-imap-protocol-error "unexpected ]")) (setcdr tail (cons obj nil)) (setq tail (cdr tail)) (setq obj (vm-imap-read-object process t))) (setq token list done t))) ((looking-at ")") (forward-char 1) (setq token '(close-paren) done t)) ((looking-at "{") ;; string ::= { n-octets } end-of-line octets... (forward-char 1) (let (start obj n-octets) ;; better check if we have a number here because ;; gmail sometimes puts random stuff. (if (not (save-excursion (looking-at "[0-9]*}"))) (setq token '(open-brace) done t) (setq obj (vm-imap-read-object process)) (unless (eq (car obj) 'atom) (vm-imap-protocol-error "number expected after {")) (setq n-octets (string-to-number (buffer-substring (nth 1 obj) (nth 2 obj)))) (setq obj (vm-imap-read-object process)) (unless (eq (car obj) 'close-brace) (vm-imap-protocol-error "} expected")) (setq obj (vm-imap-read-object process)) (unless (eq (car obj) 'end-of-line) (vm-imap-protocol-error "CRLF expected")) (setq start (point)) (while (< (- (point-max) start) n-octets) (vm-imap-check-connection process) ;; point might change here? USR, 2011-03-16 (vm-accept-process-output process)) (goto-char (+ start n-octets)) (setq token (list 'string start (point)) done t)))) ((looking-at "}") (forward-char 1) (setq token '(close-brace) done t)) ((looking-at "\042") ;; double quote (forward-char 1) (let ((start (point)) (curpoint (point))) (while (not done) (skip-chars-forward "^\042") (setq curpoint (point)) (if (looking-at "\042") (progn (setq done t) (forward-char 1)) (vm-imap-check-connection process) ;; point might change here? (vm-accept-process-output process) (goto-char curpoint)) (setq token (list 'string start curpoint))))) ;; should be (looking-at "[\000-\040\177-\377]") ;; but Microsoft Exchange emits 8-bit chars. ((and (looking-at "[\000-\040\177]") (= vm-imap-tolerant-of-bad-imap 0)) (vm-imap-protocol-error "illegal char (%d)" (char-after (point)))) (t (let ((start (point)) (curpoint (point)) ;; We should be considering 8-bit chars as ;; non-word chars also but Microsoft Exchange ;; uses them, despite the RFC 2060 prohibition. ;; If we ever resume disallowing 8-bit chars, ;; remember to write the range as \177-\376 ... ;; \376 instead of \377 because Emacs 19.34 has ;; a bug in the fastmap initialization code ;; that causes it to infloop. (not-word-chars "^\000-\040\177()[]{}") (not-word-regexp "[][\000-\040\177(){}]")) (while (not done) (skip-chars-forward not-word-chars) (setq curpoint (point)) (if (looking-at not-word-regexp) (setq done t) (vm-imap-check-connection process) ;; point might change here? (vm-accept-process-output process) (goto-char curpoint)) (vm-imap-log-token (buffer-substring start curpoint)) (setq token (list 'atom start curpoint))))))) ;; unwind-protections (setq vm-imap-read-point (point)) (vm-imap-log-token vm-imap-read-point) (vm-imap-log-token token)) token )) (defun vm-imap-response-matches (response &rest expr) "Checks if a REPSONSE from the IMAP server matches the pattern EXPR. The syntax of patterns is: expr ::= quoted-symbol | 'atom | 'string | ('vector expr*) | ('list expr*) Numbers are included among atoms." (let ((case-fold-search t) e r) (catch 'done (while (and expr response) (setq e (car expr) r (car response)) (cond ((stringp e) (if (or (not (eq (car r) 'string)) (save-excursion (goto-char (nth 1 r)) (not (eq (search-forward e (nth 2 r) t) (nth 2 r))))) (throw 'done nil))) ((numberp e) (if (or (not (eq (car r) 'atom)) (save-excursion (goto-char (nth 1 r)) (not (eq (search-forward (int-to-string e) (nth 2 r) t) (nth 2 r))))) (throw 'done nil))) ((consp e) (if (not (eq (car e) (car r))) (throw 'done nil)) (apply 'vm-imap-response-matches (cdr r) (cdr e))) ((eq e 'atom) (if (not (eq (car r) 'atom)) (throw 'done nil))) ((eq e 'vector) (if (not (eq (car r) 'vector)) (throw 'done nil))) ((eq e 'list) (if (not (eq (car r) 'list)) (throw 'done nil))) ((eq e 'string) (if (not (eq (car r) 'string)) (throw 'done nil))) ;; this must to come after all the comparisons for ;; specific symbols. ((symbolp e) (if (or (not (eq (car r) 'atom)) (save-excursion (goto-char (nth 1 r)) (not (eq (search-forward (symbol-name e) (nth 2 r) t) (nth 2 r))))) (throw 'done nil)))) (setq response (cdr response) expr (cdr expr))) t ))) (defun vm-imap-bail-if-server-says-farewell (response) (if (vm-imap-response-matches response '* 'BYE) (throw 'end-of-session t))) (defun vm-imap-scan-list-for-flag (list flag) (setq list (cdr list)) (let ((case-fold-search t) e) (catch 'done (while list (setq e (car list)) (if (not (eq (car e) 'atom)) nil (goto-char (nth 1 e)) (if (eq (search-forward flag (nth 2 e) t) (nth 2 e)) (throw 'done t))) (setq list (cdr list))) nil ))) ;; like Lisp get but for IMAP property lists like those returned by FETCH. (defun vm-imap-plist-get (list name) (setq list (cdr list)) (let ((case-fold-search t) e) (catch 'done (while list (setq e (car list)) (if (not (eq (car e) 'atom)) nil (goto-char (nth 1 e)) (if (eq (search-forward name (nth 2 e) t) (nth 2 e)) (throw 'done (car (cdr list))))) (setq list (cdr (cdr list)))) nil ))) (defun vm-imap-quote-string (string) (vm-with-string-as-temp-buffer string 'vm-imap-quote-buffer)) (defun vm-imap-quote-buffer () (goto-char (point-min)) (insert "\"") (while (re-search-forward "[\"\\]" nil t) (forward-char -1) (insert "\\") (forward-char 1)) (goto-char (point-max)) (insert "\"")) (defun vm-imap-poke-session (process) "Poke the IMAP session by sending a NOOP command, just to make sure that the session is active. Returns t or nil." (if (and process (memq (process-status process) '(open run)) (buffer-live-p (process-buffer process))) (if vm-imap-ensure-active-sessions (let ((buffer (process-buffer process))) (with-current-buffer buffer ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (vm-imap-send-command process "NOOP") (condition-case err (let ((response nil) (need-ok t)) (while need-ok (setq response (vm-imap-read-response-and-verify process "NOOP")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) ;;---------------------------- (vm-buffer-type:exit) ;;---------------------------- t) (vm-imap-protocol-error ; handler ;;-------------------- (vm-buffer-type:exit) ;;-------------------- nil)))) ; ignore errors t) nil)) (defun vm-re-establish-folder-imap-session (&optional interactive purpose just-retrieve) "If the IMAP session for the current folder has died, re-establish a new one. Optional argument PURPOSE is inserted into the process buffer for tracing purposes. Optional argument JUST-RETRIEVE says whether the session will only be used for retrieval of mail. Returns the IMAP process or nil if unsuccessful." (let ((process (vm-folder-imap-process)) temp) (if (and (processp process) (vm-imap-poke-session process)) process (when process (vm-imap-end-session process)) (vm-establish-new-folder-imap-session interactive purpose just-retrieve)))) (defun vm-establish-new-folder-imap-session (&optional interactive purpose just-retrieve) "Kill and restart the IMAP session for the current folder. Optional argument PURPOSE is inserted into the process buffer for tracing purposes. Optional argument JUST-RETRIEVE says whether the session will only be used for retrieval of mail. Returns the IMAP process or nil if unsuccessful." ;; This is necessary because we might get unexpected EXPUNGE responses ;; which we don't know how to deal with. (let (process (vm-imap-ok-to-ask interactive) mailbox select mailbox-count recent-count uid-validity permanent-flags read-write can-delete body-peek) (if (vm-folder-imap-process) (vm-imap-end-session (vm-folder-imap-process))) (vm-imap-log-token 'new) (setq process (vm-imap-make-session (vm-folder-imap-maildrop-spec) interactive purpose)) (when (processp process) (vm-set-folder-imap-process process) (setq mailbox (vm-imap-parse-spec-to-list (vm-folder-imap-maildrop-spec)) mailbox (nth 3 mailbox)) (unwind-protect (with-current-buffer (process-buffer process) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (setq select (vm-imap-select-mailbox process mailbox just-retrieve)) (setq mailbox-count (nth 0 select) recent-count (nth 1 select) uid-validity (nth 2 select) read-write (nth 3 select) can-delete (nth 4 select) permanent-flags (nth 5 select) body-peek (vm-imap-capability 'IMAP4REV1)) ;;--------------------------------- (vm-imap-session-type:set 'active) ;;--------------------------------- ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- (when (and (vm-folder-imap-uid-validity) (not (equal (vm-folder-imap-uid-validity) uid-validity))) (unless (y-or-n-p (concat "Folder's UID VALIDITY value has changed " "on the server. Refresh cache? ")) (error "Aborted")) (vm-warn 5 4 (concat "VM will download new copies of messages" " and mark the old ones for deletion")) (setq vm-imap-retrieved-messages (vm-imap-clear-invalid-retrieval-entries (vm-folder-imap-maildrop-spec) vm-imap-retrieved-messages uid-validity)) (vm-mark-folder-modified-p (current-buffer)))) (vm-set-folder-imap-uid-validity uid-validity) ; unique per session (vm-set-folder-imap-mailbox-count mailbox-count) (unless (vm-folder-imap-retrieved-count) (vm-set-folder-imap-retrieved-count mailbox-count)) (vm-set-folder-imap-recent-count recent-count) (vm-set-folder-imap-read-write read-write) (vm-set-folder-imap-can-delete can-delete) (vm-set-folder-imap-body-peek body-peek) (vm-set-folder-imap-permanent-flags permanent-flags) ;;------------------------------- (vm-imap-dump-uid-and-flags-data) ;;------------------------------- process ))) (defun vm-re-establish-writable-imap-session (&optional interactive purpose) "If the IMAP session for the current folder has died, re-establish a new one. Returns the IMAP process or nil if unsuccessful." (let ((process (vm-folder-imap-process)) temp) (if (and (processp process) (vm-imap-poke-session process)) process (if process (vm-imap-end-session process)) (vm-establish-writable-imap-session interactive purpose)))) (defun vm-establish-writable-imap-session (maildrop &optional interactive purpose) "Create a new writable IMAP session for MAILDROP and return the process. Optional argument PURPOSE is inserted into the process buffer for tracing purposes. Returns the IMAP process or nil if unsuccessful." (let (process (vm-imap-ok-to-ask interactive) mailbox select mailbox-count recent-count uid-validity permanent-flags read-write can-delete body-peek) (vm-imap-log-token 'new) (setq process (vm-imap-make-session maildrop interactive purpose)) (if (processp process) (unwind-protect (save-current-buffer (setq mailbox (vm-imap-parse-spec-to-list maildrop) mailbox (nth 3 mailbox)) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) (setq select (vm-imap-select-mailbox process mailbox nil)) (setq mailbox-count (nth 0 select) recent-count (nth 1 select) uid-validity (nth 2 select) read-write (nth 3 select) can-delete (nth 4 select) permanent-flags (nth 5 select) body-peek (vm-imap-capability 'IMAP4REV1)) ;;--------------------------------- (vm-imap-session-type:set 'active) (vm-buffer-type:exit) ;;--------------------------------- (if read-write process (vm-imap-end-session process) nil)) ;; unwind-protections ;;-------------------- (vm-buffer-type:exit) ;;-------------------- ) nil))) (defun vm-kill-folder-imap-session (&optional interactive) (let ((process (vm-folder-imap-process))) (if (processp process) (vm-imap-end-session process)))) (defun vm-imap-retrieve-uid-and-flags-data () "Retrieve the uid's and message flags for all the messages on the IMAP server in the current mail box. The results are stored in `vm-folder-access-data' in the fields imap-uid-list, imap-uid-obarray and imap-flags-obarray. Throws vm-imap-protocol-error for failure. This function is preferable to `vm-imap-get-uid-list' because it fetches flags in addition to uid's and stores them in obarrays." ;;------------------------------ (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'uid-and-flags-data vm-buffer-type-trail))) (vm-buffer-type:assert 'folder) ;;------------------------------ (if (vm-folder-imap-uid-list) nil ; don't retrieve twice (let ((there (make-vector 67 0)) (flags (make-vector 67 0)) (process (vm-folder-imap-process)) (mailbox-count (vm-folder-imap-mailbox-count)) list tuples tuple uid) (unwind-protect (with-current-buffer (process-buffer process) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (if (eq mailbox-count 0) (setq list nil) (setq list (vm-imap-get-message-data-list process 1 mailbox-count))) (setq tuples list) (while tuples (setq tuple (car tuples)) (set (intern (cadr tuple) there) (car tuple)) (set (intern (cadr tuple) flags) (nthcdr 2 tuple)) (setq tuples (cdr tuples))) ;;------------------------------- (vm-imap-session-type:set 'valid) ;;------------------------------- ) ;; unwind-protections ;; --------------------- (vm-buffer-type:exit) ;; --------------------- ) ;; Clear the old obarrays to make sure no space leaks (let ((uid-obarray (vm-folder-imap-uid-obarray)) (flags-obarray (vm-folder-imap-flags-obarray))) (mapc (function (lambda (uid) (unintern uid uid-obarray) (unintern uid flags-obarray))) (vm-folder-imap-uid-list))) ;; Assign the new data (vm-set-folder-imap-uid-list list) (vm-set-folder-imap-uid-obarray there) (vm-set-folder-imap-flags-obarray flags)))) (defun vm-imap-dump-uid-and-flags-data () (when (and vm-folder-access-data (eq (car vm-buffer-types) 'folder)) ;;------------------------------ (vm-buffer-type:assert 'folder) ;;------------------------------ (vm-set-folder-imap-uid-list nil) (vm-set-folder-imap-uid-obarray nil) (vm-set-folder-imap-flags-obarray nil) (if (processp (vm-folder-imap-process)) (with-current-buffer (process-buffer (vm-folder-imap-process)) ;;--------------------------------- (vm-imap-session-type:set 'active) ;;--------------------------------- )) )) (defun vm-imap-dump-uid-seq-num-data () (when (and vm-folder-access-data (eq (car vm-buffer-types) 'folder)) ;;------------------------------ (vm-buffer-type:assert 'folder) ;;------------------------------ (vm-set-folder-imap-uid-list nil) (vm-set-folder-imap-uid-obarray nil) (if (processp (vm-folder-imap-process)) (with-current-buffer (process-buffer (vm-folder-imap-process)) ;;--------------------------------- (vm-imap-session-type:set 'active) ;;--------------------------------- )) )) ;; This function is now obsolete. It is faster to get flags of ;; several messages at once, using vm-imap-get-message-data-list (defun vm-imap-get-message-flags (process m &optional norecord) ;; gives an error if the message has an invalid uid (let (need-ok p r flag response saw-Seen) (unless (equal (vm-imap-uid-validity-of m) (vm-folder-imap-uid-validity)) (vm-imap-normal-error "message UIDVALIDITY does not match the server")) (unwind-protect (with-current-buffer (process-buffer process) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "UID FETCH %s (FLAGS)" (vm-imap-uid-of m))) ;;-------------------------------- (vm-imap-session-type:set 'active) ;;-------------------------------- (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "UID FETCH (FLAGS)")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((vm-imap-response-matches response '* 'atom 'FETCH 'list) (setq r (nthcdr 3 response) r (car r) r (vm-imap-plist-get r "FLAGS") r (cdr r)) (while r (setq p (car r)) (if (not (eq (car p) 'atom)) nil (setq flag (downcase (buffer-substring (nth 1 p) (nth 2 p)))) (cond ((string= flag "\\answered") (vm-set-replied-flag m t norecord)) ((string= flag "\\deleted") (vm-set-deleted-flag m t norecord)) ((string= flag "\\flagged") (vm-set-flagged-flag m t norecord)) ((string= flag "\\seen") (vm-set-unread-flag m nil norecord) (vm-set-new-flag m nil norecord) (setq saw-Seen t)) ((string= flag "\\recent") (vm-set-new-flag m t norecord)))) (setq r (cdr r))) (if (not saw-Seen) (vm-set-unread-flag m t norecord)))))) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defun vm-imap-update-message-flags (m flags &optional norecord) "Update the flags of the message M in the folder to imap flags FLAGS. Optional argument NORECORD says whether this fact should not be recorded in the undo stack." (let (flag saw-Seen saw-Deleted saw-Flagged seen-labels labels) (while flags (setq flag (car flags)) (cond ((string= flag "\\answered") (when (null (vm-replied-flag m)) (vm-set-replied-flag m t norecord) (vm-set-stuff-flag-of m t))) ((string= flag "\\deleted") (when (null (vm-deleted-flag m)) (vm-set-deleted-flag m t norecord) (vm-set-stuff-flag-of m t)) (setq saw-Deleted t)) ((string= flag "\\flagged") (when (null (vm-flagged-flag m)) (vm-set-flagged-flag m t norecord) (vm-set-stuff-flag-of m t)) (setq saw-Flagged t)) ((string= flag "\\seen") (when (vm-unread-flag m) (vm-set-unread-flag m nil norecord) (vm-set-stuff-flag-of m t)) (when (vm-new-flag m) (vm-set-new-flag m nil norecord) (vm-set-stuff-flag-of m t)) (setq saw-Seen t)) ((string= flag "\\recent") (when (null (vm-new-flag m)) (vm-set-new-flag m t norecord) (vm-set-stuff-flag-of m t))) ((string= flag "forwarded") (when (null (vm-forwarded-flag m)) (vm-set-forwarded-flag m t norecord) (vm-set-stuff-flag-of m t))) ((string= flag "redistributed") (when (null (vm-redistributed-flag m)) (vm-set-redistributed-flag m t norecord) (vm-set-stuff-flag-of m t))) ((string= flag "filed") (when (null (vm-filed-flag m)) (vm-set-filed-flag m t norecord) (vm-set-stuff-flag-of m t))) ((string= flag "written") (when (null (vm-written-flag m)) (vm-set-written-flag m t norecord) (vm-set-stuff-flag-of m t))) (t ; all other flags including \flagged (setq seen-labels (cons flag seen-labels))) ) (setq flags (cdr flags))) (if (not saw-Seen) ; unread if the server says so (if (null (vm-unread-flag m)) (vm-set-unread-flag m t norecord))) (if (not saw-Deleted) ; undelete if the server says so (if (vm-deleted-flag m) (vm-set-deleted-flag m nil norecord))) (setq labels (sort (vm-labels-of m) 'string-lessp)) (setq seen-labels (sort seen-labels 'string-lessp)) (if (equal labels seen-labels) t (vm-set-labels-of m seen-labels) (vm-set-label-string-of m nil) (vm-mark-for-summary-update m) (vm-set-stuff-flag-of m t)) )) (defun vm-imap-save-message-flags (process m &optional by-uid) "Saves the message flags of a message on the IMAP server, adding or deleting flags on the server as necessary. Monotonic flags, however, are not deleted. Optional argument BY-UID says that the save commands to the server should be issued by UID, not message sequence number." ;; Comment by USR ;; According to RFC 2060, it is not an error to store flags that ;; are not listed in PERMANENTFLAGS. Removed unnecessary checks to ;; this effect. ;; There are ;; - monotonic flags that can only be set, and ;; - reversible flags that can be set or unset. ;; For monotonic flags that are set in VM, we set them on the ;; server. ;; For reversible flags, we copy the state from VM to the server. ;; (We don't know which one has precedence, but we punt that issue.) ;; The cache needs to be maintained consistently. ;;----------------------------------------------------- (vm-buffer-type:assert 'folder) (or by-uid (vm-imap-folder-session-type:assert 'valid)) ;;----------------------------------------------------- (if (not (equal (vm-imap-uid-validity-of m) (vm-folder-imap-uid-validity))) (vm-imap-normal-error "message UIDVALIDITY does not match the server")) (let* ((uid (vm-imap-uid-of m)) (uid-key1 (intern uid (vm-folder-imap-uid-obarray))) (uid-key2 (intern-soft uid (vm-folder-imap-flags-obarray))) (message-num (and (boundp uid-key1) (symbol-value uid-key1))) (cached-flags (and (boundp uid-key2) (symbol-value uid-key2))) ; leave uid as the dummy header (labels (vm-labels-of m)) copied-flags need-ok flags+ flags- response) (when message-num ;; Reversible flags are treated the same as labels (if (not (vm-unread-flag m)) (setq labels (cons "\\seen" labels))) (if (vm-deleted-flag m) (setq labels (cons "\\deleted" labels))) (if (vm-flagged-flag m) (setq labels (cons "\\flagged" labels))) ;; Irreversible flags (if (and (vm-replied-flag m) (not (member "\\answered" cached-flags))) (setq flags+ (cons "\\Answered" flags+))) (if (and (vm-filed-flag m) (not (member "filed" cached-flags))) (setq flags+ (cons "filed" flags+))) (if (and (vm-written-flag m) (not (member "written" cached-flags))) (setq flags+ (cons "written" flags+))) (if (and (vm-forwarded-flag m) (not (member "forwarded" cached-flags))) (setq flags+ (cons "forwarded" flags+))) (if (and (vm-redistributed-flag m) (not (member "redistributed" cached-flags))) (setq flags+ (cons "redistributed" flags+))) (mapc (lambda (flag) (delete flag cached-flags)) '("\\answered" "filed" "written" "forwarded" "redistributed")) ;; make copies for side effects (setq copied-flags (copy-sequence cached-flags)) (setq labels (cons nil (copy-sequence labels))) ;; Ignore labels that are both in vm and the server (delete-common-elements labels copied-flags 'string<) ;; Ignore reversible flags that we have locally reversed -- Why? ;; (mapc (lambda (flag) (delete flag copied-flags)) ;; '("\\seen" "\\deleted" "\\flagged")) ;; Flags to be added to the server (setq flags+ (append (cdr labels) flags+)) ;; Flags to be deleted from the server (setq flags- (append (cdr copied-flags) flags-)) (unwind-protect (save-excursion ; = save-current-buffer? (set-buffer (process-buffer process)) ;;---------------------------------- (vm-buffer-type:enter 'process) ;;---------------------------------- (when flags+ (vm-imap-send-command process (format "%sSTORE %s +FLAGS.SILENT %s" (if by-uid "UID " "") (if by-uid uid message-num) (mapc 'intern flags+))) (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "STORE +FLAGS.SILENT")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) (nconc cached-flags flags+)) (when flags- (vm-imap-send-command process (format "%sSTORE %s -FLAGS.SILENT %s" (if by-uid "UID " "") (if by-uid uid message-num) (mapc 'intern flags-))) (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "STORE -FLAGS.SILENT")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) (while flags- (delete (car flags-) cached-flags) (setq flags- (cdr flags-)))) (vm-set-attribute-modflag-of m nil) ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- )))) (defvar vm-imap-subst-char-in-string-buffer (get-buffer-create " *subst-char-in-string*")) (defun vm-imap-subst-CRLF-for-LF (string) (with-current-buffer vm-imap-subst-char-in-string-buffer (erase-buffer) (insert string) (goto-char (point-min)) (while (search-forward "\n" nil t) (replace-match "\r\n" nil t)) (buffer-substring-no-properties (point-min) (point-max)))) ;;;###autoload (defun vm-imap-save-message (process m mailbox) "Using the IMAP process PROCESS, save the message M to IMAP mailbox MAILBOX." (let (need-ok need-plus flags response string) ;; save the message's flag along with it. ;; don't save the deleted flag. (if (vm-replied-flag m) (setq flags (cons (intern "\\Answered") flags))) (if (not (vm-unread-flag m)) (setq flags (cons (intern "\\Seen") flags))) (with-current-buffer (vm-buffer-of m) ;;---------------------------- (vm-buffer-type:enter 'folder) ;;---------------------------- (save-restriction (widen) (setq string (buffer-substring (vm-headers-of m) (vm-text-end-of m)) string (vm-imap-subst-CRLF-for-LF string))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (unwind-protect (save-excursion ; = save-current-buffer? (set-buffer (process-buffer process)) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (condition-case nil (vm-imap-create-mailbox process mailbox) ;; ignore errors (vm-imap-protocol-error (vm-buffer-type:set 'process))) ;;---------------------------------- (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "APPEND %s %s {%d}" (vm-imap-quote-string mailbox) (if flags flags "()") (length string))) ;;-------------------------------- (vm-imap-session-type:set 'active) ;;-------------------------------- (setq need-plus t) (while need-plus (setq response (vm-imap-read-response-and-verify process "APPEND")) (cond ((vm-imap-response-matches response '+) (setq need-plus nil)))) (vm-imap-send-command process string nil t) (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "APPEND data")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)))) ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) ;; Incomplete -- Yet to be finished. USR ;; creation of new mailboxes has to be straightened out (defun vm-imap-copy-message (process m mailbox) "Use IMAP session PROCESS to copy message M to MAILBOX. The PROCESS is expected to have logged in and selected the current folder. This is similar to `vm-imap-save-message' but uses the internal copy operation of the server to minimize I/O." ;;----------------------------- (vm-buffer-type:set 'folder) ;;----------------------------- (let ((uid (vm-imap-uid-of m)) (uid-validity (vm-imap-uid-validity-of m)) need-ok response string) (if (not (equal uid-validity (vm-folder-imap-uid-validity))) (error "Message does not have a valid UID")) (unwind-protect (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (if (vm-attribute-modflag-of m) (condition-case nil (progn (if (null (vm-folder-imap-flags-obarray)) (vm-imap-retrieve-uid-and-flags-data)) (vm-imap-save-message-flags process m 'by-uid)) (vm-imap-protocol-error nil))) ; is this right? ;; (condition-case nil ;; (vm-imap-create-mailbox process mailbox) ;; (vm-imap-protocol-error nil)) (set-buffer (process-buffer process)) ;;----------------------------------------- (vm-buffer-type:set 'process) (vm-imap-session-type:assert-active) ;;----------------------------------------- (vm-imap-send-command process (format "UID COPY %s %s" (vm-imap-uid-of m) (vm-imap-quote-string mailbox))) ;;-------------------------------- (vm-imap-session-type:set 'active) ;;-------------------------------- (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "UID COPY")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil))))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) ;; ------------------------------------------------------------------------ ;; ;;; interactive commands: ;; ;; vm-create-imap-folder: string -> void ;; vm-delete-imap-folder: string -> void ;; vm-rename-imap-folder: string & string -> void ;; ;; top-level operations ;; vm-fetch-imap-message: (vm-message) -> void ;; vm-imap-synchronize-folder: ;; (&optional :interactive bool & ;; :do-remote-expunges nil|t|'all & ;; :do-local-expunges bool & ;; :do-retrieves bool & ;; :save-attributes nil|t|'all & ;; :retrieve-attributes bool) -> void ;; vm-imap-save-attributes: (&optional :interactive bool & ;; :all-flags bool) -> void ;; vm-imap-folder-check-mail: (&optional interactive) -> ? ;; ;; vm-imap-get-synchronization-data: (&optional bool) -> ;; (retrieve-list: (uid . int) list & ;; remote-expunge-list: (uid . uidvalidity) list & ;; local-expunge-list: vm-message list & ;; stale-list: vm-message list) ;; ;; ------------------------------------------------------------------------ (defun vm-imap-get-synchronization-data (&optional do-retrieves) "Compares the UID's of messages in the local cache and the IMAP server. Returns a list containing: RETRIEVE-LIST: A list of pairs consisting of UID's and message sequence numbers of the messages that are not present in the local cache and not retrieved previously, and, hence, need to be retrieved now. REMOTE-EXPUNGE-LIST: A list of pairs consisting of UID's and UIDVALIDITY's of the messages that are not present in the local cache (but we have reason to believe that they have been retrieved previously) and, hence, need to be expunged on the server. LOCAL-EXPUNGE-LIST: A list of message descriptors for messages in the local cache which are not present on the server and, hence, need to expunged locally. STALE-LIST: A list of message descriptors for messages in the local cache whose UIDVALIDITY values are stale. If the argument DO-RETRIEVES is 'full, then all the messages that are not presently in cache are retrieved. Otherwise, the messages previously retrieved are ignored." ;; Comments by USR ;; - Originally, messages with stale UIDVALIDITY values were ;; ignored. So, they would never get expunged from the cache. The ;; STALE-LIST component was added to fix this. ;;----------------------------- (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'synchronization-data vm-buffer-type-trail))) (vm-buffer-type:assert 'folder) ;;----------------------------- (let ((here (make-vector 67 0)) ; OBARRAY(uid, vm-message) there flags (uid-validity (vm-folder-imap-uid-validity)) (do-full-retrieve (eq do-retrieves 'full)) retrieve-list remote-expunge-list local-expunge-list stale-list uid mp retrieved-entry) (vm-imap-retrieve-uid-and-flags-data) (setq there (vm-folder-imap-uid-obarray)) ;; Figure out stale uidvalidity values and messages to be expunged ;; in the cache. (setq mp vm-message-list) (while mp (cond ((not (equal (vm-imap-uid-validity-of (car mp)) uid-validity)) (setq stale-list (cons (car mp) stale-list))) ((member "stale" (vm-labels-of (car mp))) nil) (t (setq uid (vm-imap-uid-of (car mp))) (set (intern uid here) (car mp)) (if (not (boundp (intern uid there))) (setq local-expunge-list (cons (car mp) local-expunge-list))))) (setq mp (cdr mp))) ;; Figure out messages that need to be retrieved (mapatoms (lambda (sym) (let ((uid (symbol-name sym))) (unless (boundp (intern uid here)) ;; message not in cache. if it has been retrieved ;; previously, it needs to be expunged on the server. ;; otherwise, it needs to be retrieved. (setq retrieved-entry (vm-find vm-imap-retrieved-messages (lambda (entry) (and (equal (car entry) uid) (equal (cadr entry) uid-validity))))) (if (or do-full-retrieve (null retrieved-entry)) ; already retrieved (setq retrieve-list (cons (cons uid (symbol-value sym)) retrieve-list)) (setq remote-expunge-list (cons (cons uid uid-validity) remote-expunge-list)))))) there) (setq retrieve-list (sort retrieve-list (lambda (**pair1 **pair2) (< (cdr **pair1) (cdr **pair2))))) (list retrieve-list remote-expunge-list local-expunge-list stale-list))) (defun vm-imap-server-error (msg &rest args) (if (eq vm-imap-connection-mode 'online) (apply (function error) msg args) (vm-inform 1 "VM working in offline mode"))) ;;;###autoload (defun* vm-imap-synchronize-folder (&key (interactive nil) (do-remote-expunges nil) (do-local-expunges nil) (do-retrieves nil) (save-attributes nil) (retrieve-attributes nil)) "Synchronize IMAP folder with the server. INTERACTIVE, true if the function was invoked interactively, e.g., as vm-get-spooled-mail. DO-REMOTE-EXPUNGES indicates whether the server mail box should be expunged. If it is 'all, then all messages not present in the cache folder are expunged. DO-LOCAL-EXPUNGES indicates whether the cache buffer should be expunged. DO-RETRIEVES indicates if new messages that are not already in the cache should be retrieved from the server. If this flag is 'full then messages previously retrieved but not in cache are retrieved as well. SAVE-ATTRIBUTES indicates if the message attributes should be updated on the server. If it is 'all, then the attributes of all messages are updated irrespective of whether they were modified or not. RETRIEVE-ATTRIBTUES indicates if the message attributes on the server should be retrieved, updating the cache. " ;; -- Comments by USR ;; Not clear why do-local-expunges and do-remote-expunges should be ;; separate. It doesn't make sense to do one but not the other! ;;-------------------------- (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'synchronize vm-buffer-type-trail))) (vm-buffer-type:set 'folder) (vm-imap-init-log) (vm-imap-log-tokens (list 'synchronize (current-buffer) (vm-folder-imap-process))) (setq vm-buffer-type-trail nil) ;;-------------------------- (if (and do-retrieves vm-block-new-mail) (error "Can't get new mail until you save this folder")) (if (or vm-global-block-new-mail (eq vm-imap-connection-mode 'offline) (null (vm-establish-new-folder-imap-session interactive "general operation" nil))) (vm-imap-server-error "Could not connect to the IMAP server") (if do-retrieves (vm-assimilate-new-messages)) ; Just to be sure (vm-inform 6 "Logging into the IMAP server...") (let* ((folder-buffer (current-buffer)) (process (vm-folder-imap-process)) (imap-buffer (process-buffer process)) (uid-validity (vm-folder-imap-uid-validity)) (imapdrop (vm-folder-imap-maildrop-spec)) (folder (or (vm-imap-folder-for-spec imapdrop) (vm-safe-imapdrop-string imapdrop))) new-messages (sync-data (vm-imap-get-synchronization-data do-retrieves)) (retrieve-list (nth 0 sync-data)) (remote-expunge-list (nth 1 sync-data)) (local-expunge-list (nth 2 sync-data)) (stale-list (nth 3 sync-data))) (when save-attributes (let ((mp vm-message-list) (errors 0)) ;; (perm-flags (vm-folder-imap-permanent-flags)) (vm-inform 6 "Updating attributes on the IMAP server... ") (while mp (if (or (eq save-attributes 'all) (vm-attribute-modflag-of (car mp))) (condition-case nil (vm-imap-save-message-flags process (car mp)) (vm-imap-protocol-error ; handler (setq errors (1+ errors)) (vm-buffer-type:set 'folder)))) (setq mp (cdr mp))) (if (> errors 0) (vm-inform 3 "Updating attributes on the IMAP server... %d errors" errors) (vm-inform 6 "Updating attributes on the IMAP server... done")))) (when retrieve-attributes (let ((mp vm-message-list) (len (length vm-message-list)) (n 0) uid m mflags) (vm-inform 6 "Retrieving message attributes and labels... ") (while mp (setq m (car mp)) (setq uid (vm-imap-uid-of m)) (when (and (equal (vm-imap-uid-validity-of m) uid-validity) (vm-folder-imap-uid-msn uid)) (setq mflags (vm-folder-imap-uid-message-flags uid)) (vm-imap-update-message-flags m mflags t)) (setq mp (cdr mp) n (1+ n))) (vm-inform 6 "Retrieving message atrributes and labels... done") )) (when (and do-retrieves retrieve-list) (setq new-messages (vm-imap-retrieve-messages retrieve-list))) (when do-local-expunges (vm-inform 6 "Expunging messages in cache... ") (vm-expunge-folder :quiet t :just-these-messages local-expunge-list) (if (and interactive stale-list) (if (y-or-n-p (format "Found %s messages with invalid UIDs. Expunge them? " (length stale-list))) (vm-expunge-folder :quiet t :just-these-messages stale-list) (vm-inform 1 "They will be labelled 'stale'") (mapc (lambda (m) (vm-add-or-delete-message-labels "stale" (list m) 'all)) stale-list) )) (vm-inform 6 "Expunging messages in cache... done")) (when (and do-remote-expunges (if (eq do-remote-expunges 'all) (setq vm-imap-messages-to-expunge remote-expunge-list) vm-imap-messages-to-expunge)) (vm-imap-expunge-remote-messages)) ;; Not clear that one should end the session right away. We ;; will keep it around for use with headers-only messages. ;; (vm-imap-end-session process) (setq vm-imap-connection-mode 'online) new-messages))) (defun vm-imap-retrieve-messages (retrieve-list) "Retrieve into the current folder messages listed in RETRIEVE-LIST and return the list of the retrieved messages. The RETRIEVE-LIST is a list of cons-pairs (uid . n) of the UID's and message sequence numbers of messages on the IMAP server. If `vm-enable-external-messages' includes 'imap, then messages larger than `vm-imap-max-message-size' are retrieved in headers-only form." (let* ((folder-buffer (current-buffer)) (process (vm-folder-imap-process)) (imapdrop (vm-folder-imap-maildrop-spec)) (folder (or (vm-imap-folder-for-spec imapdrop) (vm-safe-imapdrop-string imapdrop))) (use-body-peek (vm-folder-imap-body-peek)) (uid-validity (vm-folder-imap-uid-validity)) uid r-list r-entry range new-messages message-size statblob old-eob pos k mp pair (headers-only (or (eq vm-enable-external-messages t) (memq 'imap vm-enable-external-messages))) (n 0)) (save-excursion (vm-inform 6 "Retrieving new messages... ") (vm-save-restriction (widen) (setq old-eob (point-max)) (goto-char (point-max)) (when (null vm-imap-max-message-size) (setq vm-imap-max-message-size most-positive-fixnum)) ;; Annotate retrieve-list with headers-only flags (setq retrieve-list (mapcar (lambda (pair) (if (> (read (vm-folder-imap-uid-message-size (car pair))) vm-imap-max-message-size) (list (car pair) (cdr pair) headers-only) (list (car pair) (cdr pair) nil))) retrieve-list)) (setq r-list (vm-imap-bunch-retrieve-list (mapcar (function cdr) retrieve-list))) (unwind-protect (condition-case error-data (save-excursion ; = save-current-buffer? (set-buffer (process-buffer process)) ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (setq statblob (vm-imap-start-status-timer)) (vm-set-imap-status-mailbox statblob folder) (vm-set-imap-status-maxmsg statblob (length retrieve-list)) (while r-list (setq pair (car r-list) range (car pair) headers-only (cadr pair)) (vm-set-imap-status-currmsg statblob n) (setq message-size (vm-imap-get-message-size process (car range))) ; sloppy, one size fits all (vm-set-imap-status-need statblob message-size) ;;---------------------------------- (vm-imap-session-type:assert 'valid) ;;---------------------------------- (vm-imap-fetch-messages process (car range) (cdr range) use-body-peek headers-only) (setq k (1+ (- (cdr range) (car range)))) (setq pos (with-current-buffer folder-buffer (point))) (while (> k 0) (vm-imap-retrieve-to-target process folder-buffer statblob use-body-peek) (with-current-buffer folder-buffer (if (= (point) pos) (debug "IMAP internal error #2012: the point hasn't moved"))) (setq k (1- k))) (vm-imap-read-ok-response process) (setq r-list (cdr r-list) n (+ n (1+ (- (cdr range) (car range))))))) (vm-imap-normal-error ; handler (vm-warn 0 2 "IMAP error: %s" (cadr error-data))) (vm-imap-protocol-error ; handler (vm-warn 0 2 "Retrieval from %s signaled: %s" folder error-data)) ;; Continue with whatever messages have been read (quit (delete-region old-eob (point-max)) (error (format "Quit received during retrieval from %s" folder)))) ;; unwind-protections (when statblob (vm-imap-stop-status-timer statblob)) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) ;; to make the "Mail" indicator go away (setq vm-spooled-mail-waiting nil) (vm-set-folder-imap-retrieved-count (vm-folder-imap-mailbox-count)) (intern (buffer-name) vm-buffers-needing-display-update) (vm-inform 6 "Updating summary... ") (vm-update-summary-and-mode-line) (setq mp (vm-assimilate-new-messages :read-attributes nil)) (setq new-messages mp) (if new-messages (vm-increment vm-modification-counter)) (setq r-list retrieve-list) (while mp (setq r-entry (car r-list) uid (car r-entry) headers-only (nth 2 r-entry)) (when headers-only (vm-set-body-to-be-retrieved-of (car mp) t) (vm-set-body-to-be-discarded-of (car mp) nil)) (vm-set-imap-uid-of (car mp) uid) (vm-set-imap-uid-validity-of (car mp) uid-validity) (vm-set-byte-count-of (car mp) (vm-folder-imap-uid-message-size uid)) (vm-imap-update-message-flags (car mp) (vm-folder-imap-uid-message-flags uid) t) (vm-mark-for-summary-update (car mp)) (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp) r-list (cdr r-list))) ;; (vm-update-summary-and-mode-line) ; update message sizes, possibly (when vm-arrived-message-hook (mapc (lambda (m) (vm-run-hook-on-message 'vm-arrived-message-hook m)) new-messages)) (run-hooks 'vm-arrived-messages-hook) new-messages )))) (defun vm-imap-expunge-remote-messages () "Expunge from the IMAP server messages listed in `vm-imap-messages-to-expunge'." ;; New code. Kyle's version was piggybacking on IMAP spool ;; file code and wasn't ideal. (let* ((folder-buffer (current-buffer)) (process (vm-folder-imap-process)) (imapdrop (vm-folder-imap-maildrop-spec)) (folder (or (vm-imap-folder-for-spec imapdrop) (vm-safe-imapdrop-string imapdrop))) (uid-validity (vm-folder-imap-uid-validity)) (mailbox-count (vm-folder-imap-mailbox-count)) (expunge-count (length vm-imap-messages-to-expunge)) uids-to-delete m-list d-list message e-list count) (vm-inform 6 "Expunging messages on the server... ") ;; uids-to-delete to have UID's of all UID-valid messages in ;; vm-imap-messages-to-expunge (unwind-protect (condition-case error-data (progn (setq uids-to-delete (mapcar (lambda (message) (if (equal (cdr message) uid-validity) (car message) nil)) vm-imap-messages-to-expunge)) (setq uids-to-delete (delete nil uids-to-delete)) (unless (equal expunge-count (length uids-to-delete)) (vm-warn 3 2 "%s stale deleted messages are ignored" (- expunge-count (length uids-to-delete)))) ;; m-list to have the uid's and message sequence ;; numbers of messages to be expunged, in descending ;; order. the message sequence numbers don't change ;; in the process, according to the IMAP4 protocol (setq m-list (mapcar (lambda (uid) (let* ((msn (vm-folder-imap-uid-msn uid))) (and msn (cons uid msn)))) uids-to-delete)) (setq m-list (sort (delete nil m-list) (lambda (**pair1 **pair2) (> (cdr **pair1) (cdr **pair2))))) ;; d-list to have ranges of message sequence numbers ;; of messages to be expuntged, in ascending order. (setq d-list (vm-imap-bunch-messages (nreverse (mapcar (function cdr) m-list)))) (setq expunge-count 0) ; number of messages expunged (save-excursion ; = save-current-buffer? (set-buffer (process-buffer process)) ;;--------------------------- (vm-buffer-type:set 'process) ;;--------------------------- (mapc (lambda (range) (vm-imap-delete-messages process (car range) (cdr range))) d-list) ;; now expunge and verify that all messages are gone (setq m-list (cons nil m-list)) ; dummy header added (setq count 0) (while (and (cdr m-list) (<= count vm-imap-expunge-retries)) ;;---------------------------------- (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process "EXPUNGE") ;;-------------------------------- (vm-imap-session-type:set 'active) ;;-------------------------------- ;; e-list to have the message sequence numbers of ;; messages that got expunged (setq e-list (sort (vm-imap-read-expunge-response process) '>)) (setq expunge-count (+ expunge-count (length e-list))) (mapc (lambda (e) (let ((m-cons m-list) (m-pair nil)) ; uid . msn (catch 'done (while (cdr m-cons) (setq m-pair (car (cdr m-cons))) (if (> (cdr m-pair) e) ; decrement the message sequence ; numbers following e in m-list (rplacd m-pair (1- (cdr m-pair))) (when (= (cdr m-pair) e) (rplacd m-cons (cdr (cdr m-cons)))) ;; if (< (cdr m-pair) e) it is already expunged ;; clear the message from ;; vm-imap-retrieved-messages (with-current-buffer folder-buffer (setq vm-imap-retrieved-messages (vm-delete (lambda (ret) (and (equal (car ret) (car m-pair)) (equal (cadr ret) uid-validity))) vm-imap-retrieved-messages))) (throw 'done t)) (setq m-cons (cdr m-cons)))))) e-list) ;; m-list has message sequence numbers of messages ;; that haven't yet been expunged (if (cdr m-list) (vm-inform 7 "%s messages yet to be expunged" (length (cdr m-list)))) ; try again, if the user wants us to (setq count (1+ count))) (vm-inform 6 "Expunging messages on the server... done"))) (vm-imap-normal-error ; handler (vm-warn 0 2 "IMAP error: %s" (cadr error-data))) (vm-imap-protocol-error ; handler (vm-warn 0 2 "Expunge from %s signalled: %s" folder error-data)) (quit ; handler (error "Quit received during expunge from %s" folder))) ;; unwind-protections ;;----------------------------- (vm-buffer-type:exit) (vm-imap-dump-uid-seq-num-data) ;;----------------------------- ) (vm-set-folder-imap-mailbox-count (- mailbox-count expunge-count)) (vm-set-folder-imap-retrieved-count (- (vm-folder-imap-retrieved-count) expunge-count)) (vm-mark-folder-modified-p) )) (defun vm-imap-bunch-retrieve-list (retrieve-list) "Given a sorted list of pairs consisting of message sequence numbers and headers-only flags, creates a list of bunched message sequences, each of the form (begin-num . end-num), along with their headers-only flags." (let ((ranges nil) pair headers-only beg last last-headers-only next diff) (when retrieve-list (setq pair (car retrieve-list) beg (car pair) headers-only (cadr pair)) (setq last beg last-headers-only headers-only) (setq retrieve-list (cdr retrieve-list)) (while retrieve-list (setq pair (car retrieve-list) next (car pair) headers-only (cadr pair)) (if (and (= (- next last) 1) (eq last-headers-only headers-only) (< (- next beg) vm-imap-message-bunch-size)) (setq last next) (setq ranges (cons (list (cons beg last) last-headers-only) ranges)) (setq beg next) (setq last next) (setq last-headers-only headers-only)) (setq retrieve-list (cdr retrieve-list))) (setq ranges (cons (list (cons beg last) last-headers-only) ranges))) (nreverse ranges))) (defun vm-imap-bunch-messages (seq-nums) "Given a sorted list of message sequence numbers, creates a list of bunched message sequences, each of the form (begin-num . end-num)." (let ((seqs nil) beg last next diff) (when seq-nums (setq beg (car seq-nums)) (setq last beg) (setq seq-nums (cdr seq-nums)) (while seq-nums (setq next (car seq-nums)) (if (and (= (- next last) 1) (< (- next beg) vm-imap-message-bunch-size)) (setq last next) (setq seqs (cons (cons beg last) seqs)) (setq beg next) (setq last next)) (setq seq-nums (cdr seq-nums))) (setq seqs (cons (cons beg last) seqs))) (nreverse seqs))) (defun vm-fetch-imap-message (m) "Insert the message body of M in the current buffer, which must be either the folder buffer or the presentation buffer. Returns a boolean indicating success: t if the message was fully fetched and nil otherwise. (This is a special case of vm-fetch-message, not to be confused with vm-imap-fetch-message.)" (let ((body-buffer (current-buffer)) (statblob nil)) (unwind-protect (save-excursion ; save-current-buffer? ;;---------------------------------- (vm-buffer-type:enter 'folder) ;;---------------------------------- (set-buffer (vm-buffer-of (vm-real-message-of m))) (let* ((statblob nil) (uid (vm-imap-uid-of m)) (imapdrop (vm-folder-imap-maildrop-spec)) (folder (or (vm-imap-folder-for-spec imapdrop) (vm-safe-imapdrop-string imapdrop))) (process (and (eq vm-imap-connection-mode 'online) (vm-re-establish-folder-imap-session imapdrop "fetch"))) (imap-buffer (and process (process-buffer process))) (use-body-peek (vm-folder-imap-body-peek)) (server-uid-validity (vm-folder-imap-uid-validity)) (old-eob (point-max)) message-size ) (when (null process) (if (eq vm-imap-connection-mode 'offline) (error "Working in offline mode") (setq vm-imap-connection-mode 'autoconnect) (error (concat "Could not connect to IMAP server; " "Type g to reconnect")))) (unless (equal (vm-imap-uid-validity-of m) server-uid-validity) (error "Message has an invalid UID")) (setq imap-buffer (process-buffer process)) (unwind-protect (save-excursion ; = save-current-buffer? (set-buffer imap-buffer) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (condition-case error-data (progn (setq message-size (vm-imap-get-uid-message-size process uid)) (setq statblob (vm-imap-start-status-timer)) (vm-set-imap-status-mailbox statblob folder) (vm-set-imap-status-maxmsg statblob 1) (vm-set-imap-status-currmsg statblob 1) (vm-set-imap-status-need statblob message-size) (vm-imap-fetch-uid-message process uid use-body-peek nil) (vm-imap-retrieve-to-target process body-buffer statblob use-body-peek) (vm-imap-read-ok-response process) t) (vm-imap-normal-error ; handler (vm-warn 0 2 "IMAP error: %s" (cadr error-data)) nil) (vm-imap-protocol-error ; handler (vm-warn 0 2 "Retrieval from %s signaled: %s" folder error-data) nil ;; Continue with whatever messages have been read ) (quit (delete-region old-eob (point-max)) (error (format "Quit received during retrieval from %s" folder))))) ;; unwind-protections (when statblob (vm-imap-stop-status-timer statblob)) ;;----------------------------- (vm-buffer-type:exit) (vm-imap-dump-uid-seq-num-data) ;;----------------------------- ))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defun* vm-imap-save-attributes (&optional &key (interactive nil) (all-flags nil)) "* Save the attributes of changed messages to the IMAP folder. INTERACTIVE, true if the function was invoked interactively, e.g., as vm-get-spooled-mail. ALL-FLAGS, if true says that the attributes of all messages should be saved to the IMAP folder, not only those of changed messages. " ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (let* ((process (vm-folder-imap-process)) (uid-validity (vm-folder-imap-uid-validity)) (mp vm-message-list) (errors 0)) ;; (perm-flags (vm-folder-imap-permanent-flags)) (vm-inform 6 "Updating attributes on the IMAP server... ") ;;----------------------------------------- (vm-imap-folder-session-type:assert 'valid) ;;----------------------------------------- (while mp (if (or all-flags (vm-attribute-modflag-of (car mp))) (condition-case nil (vm-imap-save-message-flags process (car mp)) (vm-imap-protocol-error ; handler (setq errors (1+ errors)) (vm-buffer-type:set 'folder)))) (setq mp (cdr mp))) (if (> errors 0) (vm-inform 3 "Updating attributes on the IMAP server... %d errors" errors) (vm-inform 6 "Updating attributes on the IMAP server... done")))) (defun vm-imap-synchronize (&optional full) "Synchronize the current folder with the IMAP mailbox. Changes made to the buffer are uploaded to the server first before downloading the server data. Deleted messages are not expunged. Prefix argument FULL says that all the attribute changes and expunges made to the cache folder should be written to the server even if those changes were not made in the current VM session. This is useful for saving offline work on the cache folder." (interactive "P") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (vm-display nil nil '(vm-imap-synchronize) '(vm-imap-synchronize)) (if (not (eq vm-folder-access-method 'imap)) (vm-inform 0 "This is not an IMAP folder") (when (vm-establish-new-folder-imap-session t "general operation" nil) (vm-imap-retrieve-uid-and-flags-data) (vm-imap-save-attributes :interactive t :all-flags full) ;; (vm-imap-synchronize-folder :interactive t ;; :save-attributes (if full 'all t)) (vm-imap-synchronize-folder :interactive t :do-remote-expunges (if full 'all t) :do-local-expunges t :do-retrieves t :retrieve-attributes t) ;; stuff the attributes of messages that need it. ;; (vm-inform 7 "Stuffing cached data...") ;; (vm-stuff-folder-data nil) ;; (vm-inform 7 "Stuffing cached data... done") ;; stuff bookmark and header variable values (when vm-message-list ;; get summary cache up-to-date (vm-inform 6 "Updating summary... ") (vm-update-summary-and-mode-line) (vm-inform 6 "Updating summary... done") ;; (vm-stuff-bookmark) ;; (vm-stuff-pop-retrieved) ;; (vm-stuff-imap-retrieved) ;; (vm-stuff-last-modified) ;; (vm-stuff-header-variables) ;; (vm-stuff-labels) ;; (vm-stuff-summary) ;; (and vm-message-order-changed ;; (vm-stuff-message-order)) )))) ;;;###autoload (defun vm-imap-folder-check-mail (&optional interactive) "Check if there is new mail on the server for the current IMAP folder. The optional argument INTERACTIVE says if the function is being invoked interactively." (vm-buffer-type:wait-for-imap-session) ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (vm-inform 10 "Checking for new mail in %s... " (buffer-name (current-buffer))) (cond (vm-global-block-new-mail nil) ((null (vm-establish-new-folder-imap-session interactive "checkmail" t)) nil) (t (let ((result nil)) (cond ((> (vm-folder-imap-recent-count) 0) t) ((null (vm-folder-imap-retrieved-count)) (setq result (car (vm-imap-get-synchronization-data)))) (t (setq result (> (vm-folder-imap-mailbox-count) (vm-folder-imap-retrieved-count))))) (vm-imap-end-session (vm-folder-imap-process)) (vm-inform 10 "Checking for new mail in %s... done" (buffer-name (current-buffer))) result)))) (defalias 'vm-imap-folder-check-for-mail 'vm-imap-folder-check-mail) (make-obsolete 'vm-imap-folder-check-for-mail 'vm-imap-folder-check-mail "8.2.0") ;; --------------------------------------------------------------------------- ;;; Utilities for maildrop specs (this should be moved up top) ;; ;; A maildrop spec is of the form ;; protocol:hostname:port:mailbox:auth:loginid:password ;; 0 1 2 3 4 5 6 ;; vm-imap-find-spec-for-buffer: (buffer) -> maildrop-spec ;; vm-imap-make-filename-for-spec: (maildrop-spec) -> string ;; vm-imap-normalize-spec: (maildrop-spec) -> maildrop-spec ;; vm-imap-account-name-for-spec: (maildrop-spec) -> string ;; vm-imap-spec-for-account: (string) -> maildrop-spec ;; vm-imap-parse-spec-to-list: (maildrop-spec) -> string list ;; vm-imap-spec-list-to-host-alist: ;; (maildrop-spec list) -> (string, maildrop-spec) alist ;; --------------------------------------------------------------------------- ;; ----------- missing functions----------- ;;;###autoload (defun vm-imap-find-name-for-spec (spec) "This is a stub for a function that has not been defined." (error "vm-imap-find-name-for-spec has not been defined. Please report it." )) ;;----------------------------------------- ;;;###autoload (defun vm-imap-find-spec-for-buffer (buffer) "Find the IMAP maildrop spec for the folder BUFFER." (with-current-buffer buffer (vm-folder-imap-maildrop-spec))) ;; (let ((list (mapcar 'car vm-imap-account-alist)) ;; (done nil) ;; (spec-items nil)) ;; (while (and (not done) list) ;; (setq spec-items (vm-imap-parse-spec-to-list (car list))) ;; (setcar (nthcdr 3 spec-items) folder) ;; (if (eq buffer (vm-get-file-buffer ;; (vm-imap-make-filename-for-spec ;; (mapconcat 'identity spec-items ":")))) ;; (setq done t) ;; (setq list (cdr list)))) ;; (and list (car list))) ;;;###autoload (defun vm-imap-make-filename-for-spec (spec) "Returns a cache file name appropriate for the IMAP maildrop specification SPEC." (let (md5) (setq spec (vm-imap-normalize-spec spec)) (setq md5 (vm-md5-string spec)) (expand-file-name (concat "imap-cache-" md5) (or vm-imap-folder-cache-directory vm-folder-directory (getenv "HOME"))))) ;;;###autoload (defun vm-imap-normalize-spec (spec) (let (comps) (setq comps (vm-imap-parse-spec-to-list spec)) (setcar (vm-last comps) "*") ; scrub password (setcar comps "imap") ; standardise protocol name (setcar (nthcdr 2 comps) "*") ; scrub portnumber (setcar (nthcdr 4 comps) "*") ; scrub authentication method (setq spec (mapconcat (function identity) comps ":")) spec )) ;;;###autoload (defun vm-imap-account-name-for-spec (spec) "Returns the IMAP account name for maildrop specification SPEC, by looking up `vm-imap-account-alist' or nil if there is no such account." (let ((alist vm-imap-account-alist) comps account-comps) (setq comps (vm-imap-parse-spec-to-list spec)) (catch 'return (while alist (setq account-comps (vm-imap-parse-spec-to-list (car (car alist)))) (if (and (equal (nth 1 comps) (nth 1 account-comps)) ; host (equal (nth 5 comps) (nth 5 account-comps))) ; login (throw 'return (cadr (car alist))) (setq alist (cdr alist)))) nil))) ;;;###autoload (defun vm-imap-folder-for-spec (spec) "Returns the IMAP folder for maildrop specification SPEC in the format account:mailbox." (let (comps account-comps (alist vm-imap-account-alist)) (setq comps (vm-imap-parse-spec-to-list spec)) (catch 'return (while alist (setq account-comps (vm-imap-parse-spec-to-list (car (car alist)))) (if (and (equal (nth 1 comps) (nth 1 account-comps)) ; host (equal (nth 5 comps) (nth 5 account-comps))) ; login (throw 'return (concat (cadr (car alist)) ":" (nth 3 comps))) (setq alist (cdr alist)))) nil))) ;;;###autoload (defun vm-imap-spec-for-account (account) "Returns the IMAP maildrop spec for ACCOUNT, by looking up `vm-imap-account-alist' or nil if there is no such account." (car (rassoc (list account) vm-imap-account-alist))) ;;;###autoload (defun vm-imap-parse-spec-to-list (spec) "Parses the IMAP maildrop specification SPEC and returns a list of its components." (vm-parse spec "\\([^:]+\\):?" 1 6)) (defun vm-imap-spec-list-to-host-alist (spec-list) (let (host-alist spec host) (while spec-list (setq spec (vm-imapdrop-sans-password-and-mailbox (car spec-list))) (setq host-alist (cons (list (nth 1 (vm-imap-parse-spec-to-list spec)) spec) host-alist) spec-list (cdr spec-list))) host-alist )) (defvar vm-imap-account-folder-cache nil "Caches the list of all folders on an IMAP account.") (defun vm-imap-folder-completion-list (string predicate flag) "Find completions for STRING as an IMAP folder name, satisfying PREDICATE. The third argument FLAG is one of: `nil' - try-completion, returns string if there are mult possibilities, `t' - all-completions, returns a list of all completions, `lambda' - test-completion, test if the string is an exact match for a possibility , and a pair (boundaries. SUFFIX) - completion-boundaries. See Info node `(elisp)Programmed Completion'." ;; selectable-only is used via dynamic binding (let ((account-list (mapcar (lambda (a) (list (concat (cadr a) ":"))) vm-imap-account-alist)) completion-list folder account spec process mailbox-list) ;; handle SPC completion (remove last " " from string) (and (> (length string) 0) (string= " " (substring string -1)) (setq string (substring string 0 -1))) ;; check for account (setq folder (try-completion (or string "") account-list predicate)) (if (stringp folder) (setq account (car (vm-parse folder "\\([^:]+\\):?" 1))) (setq account (car (vm-parse string "\\([^:]+\\):?" 1)))) ;; get folders of this account (when account (setq mailbox-list (cdr (assoc account vm-imap-account-folder-cache))) (setq spec (vm-imap-spec-for-account account)) (when (and (null mailbox-list) spec) (unwind-protect (progn (setq process (vm-imap-make-session spec t "folders")) (when process (setq mailbox-list (vm-imap-mailbox-list process selectable-only)) (when mailbox-list (add-to-list 'vm-imap-account-folder-cache (cons account mailbox-list))))) ;; unwind-protection (when process (vm-imap-end-session process)))) (setq completion-list (mapcar (lambda (m) (list (format "%s:%s" account m))) mailbox-list)) (setq folder (try-completion (or string "") completion-list predicate))) (setq folder (or folder string)) (if (eq folder t) (setq folder string)) (cond ((null flag) folder) ((eq t flag) (mapcar 'car (vm-delete (lambda (c) (string-prefix-p folder (car c))) (or completion-list account-list) t)) ) ((eq 'lambda flag) (try-completion folder completion-list predicate))))) ;;;###autoload (defun vm-read-imap-folder-name (prompt &optional selectable-only newone default) "Read an IMAP folder name in the format account:mailbox, return an IMAP mailbox spec." (let* (folder-input completion-list spec process list default-account default-folder (vm-imap-ok-to-ask t) (account-list (mapcar 'cadr vm-imap-account-alist)) account-and-folder account folder mailbox-list) (if (null account-list) (error "No known IMAP accounts. Please set vm-imap-account-alist.")) (if default (setq list (vm-imap-parse-spec-to-list default) default-account (cadr (assoc (vm-imapdrop-sans-password-and-mailbox default) vm-imap-account-alist)) default-folder (nth 3 list)) (setq default-account vm-last-visit-imap-account)) (setq folder-input (completing-read (format ; prompt ;; "IMAP folder:%s " "%s%s" prompt (if (and default-account default-folder) (format "(default %s:%s) " default-account default-folder) "")) 'vm-imap-folder-completion-list ; collection nil ; predicate nil ; require-match (if default-account ; initial-input (format "%s:" default-account) ""))) (if (or (equal folder-input "") (equal folder-input (format "%s:" default-account))) (if (and default-account default-folder) (setq folder-input (format "%s:%s" default-account default-folder)) (error "IMAP folder required in the format account-name:folder-name"))) (setq account-and-folder (vm-parse folder-input "\\([^:]+\\):?" 1 2) account (car account-and-folder) folder (cadr account-and-folder) spec (vm-imap-spec-for-account account)) (if (null folder) (error "IMAP folder required in the format account-name:folder-name")) (if (null spec) (error "Unknown IMAP account %s" account)) (setq list (vm-imap-parse-spec-to-list spec)) (setcar (nthcdr 3 list) folder) (setq vm-last-visit-imap-account account) (mapconcat 'identity list ":"))) (defun vm-imap-directory-separator (process ref) (let ((c-list nil) sep p r response need-ok) (vm-imap-check-connection process) (unwind-protect (save-excursion ; = save-current-buffer? (set-buffer (process-buffer process)) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "LIST %s \"\"" (vm-imap-quote-string ref))) ;;-------------------------------- (vm-imap-dump-uid-seq-num-data) ;;-------------------------------- (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "LIST")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((vm-imap-response-matches response '* 'LIST 'list 'string) (setq r (nthcdr 3 response) p (car r) sep (buffer-substring (nth 1 p) (nth 2 p)))) ((vm-imap-response-matches response '* 'LIST 'list) (vm-imap-protocol-error "unexpedcted LIST response")))) sep ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defun vm-imap-mailbox-list (process selectable-only) "Query the IMAP PROCESS to get a list of the mailboxes (folders) available in the IMAP account. SELECTABLE-ONLY flag asks only selectable mailboxes to be listed. Returns a list of mailbox names." (let ((c-list nil) p r response need-ok) (vm-imap-check-connection process) (unwind-protect (with-current-buffer (process-buffer process) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) (vm-imap-dump-uid-seq-num-data) ;;---------------------------------- (vm-imap-send-command process "LIST \"\" \"*\"") (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "LIST")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((vm-imap-response-matches response '* 'LIST 'list) (setq r (nthcdr 2 response) p (car r)) (if (and selectable-only (vm-imap-scan-list-for-flag p "\\Noselect")) nil (setq r (nthcdr 4 response) p (car r)) (if (memq (car p) '(atom string)) (setq c-list (cons (buffer-substring (nth 1 p) (nth 2 p)) c-list))))))) c-list ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) ;; This is unfinished (defun vm-imap-mailbox-p (process mailbox selectable-only) "Query the IMAP PROCESS to check if MAILBOX exists as a folder. SELECTABLE-ONLY flag asks whether the mailbox is selectable as well. Returns a boolean value." (let ((c-list nil) p r response need-ok) (vm-imap-check-connection process) (unwind-protect (with-current-buffer (process-buffer process) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) (vm-imap-dump-uid-seq-num-data) ;;---------------------------------- (vm-imap-send-command process (concat "LIST \"\" \"" mailbox "\"")) (setq need-ok t) (while need-ok (setq response (vm-imap-read-response-and-verify process "LIST")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((vm-imap-response-matches response '* 'LIST 'list) (setq r (nthcdr 2 response) p (car r)) (if (and selectable-only (vm-imap-scan-list-for-flag p "\\Noselect")) nil (setq r (nthcdr 4 response) p (car r)) (if (memq (car p) '(atom string)) (setq c-list (cons (buffer-substring (nth 1 p) (nth 2 p)) c-list))))))) c-list ) ;; unwind-protections ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defun vm-imap-read-boolean-response (process) (let ((need-ok t) retval response) (while need-ok (vm-imap-check-connection process) (setq response (vm-imap-read-response process)) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil retval t)) ((vm-imap-response-matches response 'VM 'NO) (setq need-ok nil retval nil)) ((vm-imap-response-matches response '* 'BYE) (vm-imap-normal-error "server disconnected")) ((vm-imap-response-matches response 'VM 'BAD) (vm-imap-normal-error "server said BAD")))) retval )) (defun vm-imap-create-mailbox (process mailbox &optional dont-create-parent-directories) (if (not dont-create-parent-directories) (let (dir sep sep-regexp i) (setq sep (vm-imap-directory-separator process "") sep-regexp (regexp-quote sep) i 0) (while (string-match sep-regexp mailbox i) (setq dir (substring mailbox i (match-end 0))) (vm-imap-create-mailbox process dir t) ;; ignore command result since creating a directory will ;; routinely fail with "File exists". We'll generate a ;; real error if the final mailbox creation fails. (vm-imap-read-boolean-response process) (setq i (match-end 0))))) (vm-imap-send-command process (format "CREATE %s" (vm-imap-quote-string mailbox))) (if (null (vm-imap-read-boolean-response process)) (vm-imap-normal-error "creation of %s failed" mailbox))) (defun vm-imap-delete-mailbox (process mailbox) (vm-imap-send-command process (format "DELETE %s" (vm-imap-quote-string mailbox))) (if (null (vm-imap-read-boolean-response process)) (vm-imap-normal-error "deletion of %s failed" mailbox))) (defun vm-imap-rename-mailbox (process source dest) (vm-imap-send-command process (format "RENAME %s %s" (vm-imap-quote-string source) (vm-imap-quote-string dest))) (if (null (vm-imap-read-boolean-response process)) (vm-imap-normal-error "renaming of %s to %s failed" source dest))) ;;;###autoload (defun vm-create-imap-folder (folder) "Create a folder on an IMAP server. First argument FOLDER is read from the minibuffer if called interactively. Non-interactive callers must provide an IMAP maildrop specification for the folder as described in the documentation for `vm-spool-files'." ;; Creates a self-contained IMAP session and destroys it at the end. (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) ;; (vm-check-for-killed-folder) ; seems no need for this ;; (vm-select-folder-buffer-if-possible) (let ((this-command this-command) (last-command last-command) (folder (vm-read-imap-folder-name "Create IMAP folder: " nil t))) ;;------------------- (vm-buffer-type:exit) ;;------------------- (list folder)) )) (let ((vm-imap-ok-to-ask t) process mailbox folder-display) (setq process (vm-imap-make-session folder t "create")) (if (null process) (error "Couldn't open IMAP session for %s" (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder)))) (unwind-protect (with-current-buffer (process-buffer process) ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder))) (setq folder-display (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder))) (vm-imap-create-mailbox process mailbox t) (vm-inform 5 "Folder %s created" folder-display)) ;; unwind-protections (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defalias 'vm-imap-create-folder 'vm-create-imap-folder) ;;;###autoload (defun vm-delete-imap-folder (folder) "Delete a folder on an IMAP server. First argument FOLDER is read from the minibuffer if called interactively. Non-interactive callers must provide an IMAP maildrop specification for the folder as described in the documentation for `vm-spool-files'." ;; Creates a self-contained IMAP session and destroys it at the end. (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) ;; (vm-check-for-killed-folder) ; seems no need for this ;; (vm-select-folder-buffer-if-possible) (let ((this-command this-command) (last-command last-command)) (list (vm-read-imap-folder-name "Delete IMAP folder: " nil nil))))) (let ((vm-imap-ok-to-ask t) process mailbox folder-display) (setq process (vm-imap-make-session folder t "delete folder")) (if (null process) (error "Couldn't open IMAP session for %s" (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder)))) (unwind-protect (save-current-buffer ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (set-buffer (process-buffer process)) (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder))) (setq folder-display (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder))) (vm-imap-delete-mailbox process mailbox) (vm-inform 5 "Folder %s deleted" folder-display)) ;; unwind-protections (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) (defalias 'vm-imap-delete-folder 'vm-delete-imap-folder) ;;;###autoload (defun vm-rename-imap-folder (source dest) "Rename a folder on an IMAP server. Argument SOURCE and DEST are read from the minibuffer if called interactively. Non-interactive callers must provide full IMAP maildrop specifications for SOURCE and DEST as described in the documentation for `vm-spool-files'." ;; Creates a self-contained IMAP session and destroys it at the end. (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) ;; (vm-check-for-killed-folder) ; seems no need for this ;; (vm-select-folder-buffer-if-possible) (let ((this-command this-command) (last-command last-command) source dest) (setq source (vm-read-imap-folder-name "Rename IMAP folder: " t nil)) (setq dest (vm-read-imap-folder-name (format "Rename %s to: " (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source))) nil t)) (list source dest)))) (let ((vm-imap-ok-to-ask t) process mailbox-source mailbox-dest) (setq process (vm-imap-make-session source t "rename folder")) (if (null process) (error "Couldn't open IMAP session for %s" (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source)))) (unwind-protect (save-current-buffer ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (set-buffer (process-buffer process)) (setq mailbox-source (nth 3 (vm-imap-parse-spec-to-list source))) (setq mailbox-dest (nth 3 (vm-imap-parse-spec-to-list dest))) (vm-imap-rename-mailbox process mailbox-source mailbox-dest) (vm-inform 5 "Folder %s renamed to %s" (or (vm-imap-folder-for-spec source) (vm-safe-imapdrop-string source)) (or (vm-imap-folder-for-spec dest) (vm-safe-imapdrop-string dest)))) ;;------------------- (vm-buffer-type:exit) ;;------------------- (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ))) (defalias 'vm-rename-imap-folder 'vm-imap-rename-folder) ;;;###autoload (defun vm-list-imap-folders (account &optional filter-new) "List all folders on an IMAP account ACCOUNT, along with the counts of messages in them. The account must be one declared in `vm-imap-account-alist'. With a prefix argument, it lists only the folders with new messages in them." ;; Creates a self-contained IMAP session and destroys it at the end. (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) (let ((this-command this-command) (last-command last-command) (completion-list (mapcar (function cadr) vm-imap-account-alist))) (list (completing-read "IMAP account: " completion-list nil t (if vm-last-visit-imap-account ; initial-input (format "%s" vm-last-visit-imap-account) "") ) current-prefix-arg)))) (require 'ehelp) (setq vm-last-visit-imap-account account) (let ((vm-imap-ok-to-ask t) folder spec process mailbox-list mailbox-status-list buffer) (setq spec (vm-imap-spec-for-account account)) (setq process (and spec (vm-imap-make-session spec t "folders"))) ; new session required for STATUS (if (null process) (error "Couldn't open IMAP session for %s" (or (vm-imap-folder-for-spec account) (vm-safe-imapdrop-string account)))) (unwind-protect (progn (setq mailbox-list (vm-imap-mailbox-list process nil)) (setq mailbox-status-list (mapcar (lambda (mailbox) (cons mailbox (vm-imap-get-mailbox-status process mailbox))) mailbox-list)) (when mailbox-list (add-to-list 'vm-imap-account-folder-cache (cons account mailbox-list)))) ;; unwind-protection (when process (vm-imap-end-session process))) (setq mailbox-status-list (sort mailbox-status-list (lambda (mbstat1 mbstat2) (string-lessp (car mbstat1) (car mbstat2))))) ;; Display the results (setq buffer (get-buffer-create (format "*%s folders*" account))) ;; (with-help-buffer (buffer-name buffer) ;; (dolist (mailbox mailbox-list) ;; (princ (format "%s\n" mailbox)))) (with-electric-help (lambda () (dolist (mbstat mailbox-status-list) (if (or (null filter-new) (> (nth 2 mbstat) 0)) (princ (format "%s: %s messages, %s new \n" (car mbstat) (nth 1 mbstat) (nth 2 mbstat)))))) buffer) )) (defalias 'vm-imap-list-folders 'vm-list-imap-folders) (defun vm-imap-get-mailbox-status (process mailbox) "Requests the status of IMAP MAILBOX from the server and returns the message count and recent message count (a list of two numbers)." (let ((imap-buffer (process-buffer process)) (need-ok t) response p tok msg-count recent-count) (with-current-buffer imap-buffer ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (vm-imap-send-command process (format "STATUS %s (MESSAGES RECENT)" (vm-imap-quote-string mailbox))) (while need-ok (setq response (vm-imap-read-response-and-verify process "STATUS")) (cond ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil)) ((or (vm-imap-response-matches response '* 'STATUS 'string 'list) (vm-imap-response-matches response '* 'STATUS 'atom 'list)) (setq p (cdr (nth 3 response))) (while p (cond ((vm-imap-response-matches p 'MESSAGES 'atom) (setq tok (nth 1 p)) (goto-char (nth 1 tok)) (setq msg-count (read imap-buffer)) (setq p (nthcdr 2 p))) ((vm-imap-response-matches p 'RECENT 'atom) (setq tok (nth 1 p)) (goto-char (nth 1 tok)) (setq recent-count (read imap-buffer)) (setq p (nthcdr 2 p))) (t (vm-imap-protocol-error "expected MESSAGES and RECENT in STATUS response")) ))) (t (vm-imap-protocol-error "unexpected response to STATUS command")) )) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (list msg-count recent-count))) ;;; Robert Fenk's draft function for saving messages to IMAP folders. ;;;###autoload (defun vm-imap-save-composition () "Saves the current composition in the IMAP folder given by the IMAP-FCC header. Add this to your `mail-send-hook' and start composing from an IMAP folder." ;; Creates a self-contained IMAP session and destroys it at the end. (let ((mailbox (vm-mail-get-header-contents "IMAP-FCC:")) (mailboxes nil) (fcc-string (vm-mail-get-header-contents "FCC:" ",")) fcc-list fcc maildrop spec-list process flags response string m (vm-imap-ok-to-ask t)) (if (null mailbox) (setq mailboxes nil) ;; IMAP-FCC header present (when vm-mail-buffer ; has parent folder (save-current-buffer ;;---------------------------- (vm-buffer-type:enter 'folder) ;;---------------------------- (vm-select-folder-buffer) (setq m (car vm-message-pointer)) (when m (set-buffer (vm-buffer-of (vm-real-message-of m)))) (if (eq vm-folder-access-method 'imap) (setq maildrop (vm-folder-imap-maildrop-spec))) ;;------------------- (vm-buffer-type:exit) ;;------------------- )) (when (and (null maildrop) vm-imap-default-account) (setq maildrop (vm-imap-spec-for-account vm-imap-default-account))) (when (null maildrop) (error "Set `vm-imap-default-account' to use IMAP-FCC")) (setq process (vm-imap-make-session maildrop t "IMAP-FCC")) (if (null process) (error "Could not connect to the IMAP server for IMAP-FCC")) (setq mailboxes (list (cons mailbox process))) (vm-mail-mode-remove-header "IMAP-FCC:")) (when fcc-string (setq fcc-list (vm-parse fcc-string "\\([^,]+\\),?")) (while fcc-list (setq fcc (car fcc-list)) (setq spec-list (vm-parse fcc "\\([^:]+\\):?")) (when (member (car spec-list) '("imap" "imap-ssl" "imap-ssh")) (setq process (vm-imap-make-session fcc nil "IMAP-FCC")) (if (null process) (error "Could not connect to the IMAP server for IMAP-FCC")) (setq mailboxes (cons (cons (nth 3 spec-list) process) mailboxes))) (setq fcc-list (cdr fcc-list)))) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (setq string (concat (buffer-substring (point-min) (match-beginning 0)) (buffer-substring (match-end 0) (point-max)))) (setq string (vm-imap-subst-CRLF-for-LF string)) (while mailboxes (setq mailbox (car (car mailboxes))) (setq process (cdr (car mailboxes))) (unwind-protect (save-excursion ; = save-current-buffer? ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- ;; this can go awry if the process has died... (unless process (error "No connection to IMAP server for IMAP-FCC")) (set-buffer (process-buffer process)) (condition-case nil (vm-imap-create-mailbox process mailbox) (vm-imap-protocol-error ; handler (vm-buffer-type:set 'process))) ; ignore errors ;;---------------------------------- ;; (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (format "APPEND %s %s {%d}" (vm-imap-quote-string mailbox) (if flags flags "()") (length string))) ;; could these be done with vm-imap-read-boolean-response? (let ((need-plus t) response) (while need-plus (setq response (vm-imap-read-response process)) (cond ((vm-imap-response-matches response 'VM 'NO) (vm-imap-normal-error "server said NO")) ((vm-imap-response-matches response 'VM 'BAD) (vm-imap-normal-error "server said BAD")) ((vm-imap-response-matches response '* 'BYE) (vm-imap-normal-error "server disconnected")) ((vm-imap-response-matches response '+) (setq need-plus nil))))) (vm-imap-send-command process string nil t) (let ((need-ok t) response) (while need-ok (setq response (vm-imap-read-response process)) (cond ((vm-imap-response-matches response 'VM 'NO) (vm-imap-protocol-error "server said NO to APPEND data")) ((vm-imap-response-matches response 'VM 'BAD) (vm-imap-protocol-error "server said BAD to APPEND data")) ((vm-imap-response-matches response '* 'BYE) (vm-imap-protocol-error "server said BYE to APPEND data")) ((vm-imap-response-matches response 'VM 'OK) (setq need-ok nil))))) ) ;; unwind-protections (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (setq mailboxes (cdr mailboxes))) )) (defun vm-imap-start-bug-report () "Begin to compose a bug report for IMAP support functionality." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq vm-kept-imap-buffers nil) (setq vm-imap-keep-trace-buffer 20)) (defun vm-imap-submit-bug-report () "Submit a bug report for VM's IMAP support functionality. It is necessary to run vm-imap-start-bug-report before the problem occurrence and this command after the problem occurrence, in order to capture the trace of IMAP sessions during the occurrence." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (or vm-imap-keep-trace-buffer (y-or-n-p "Did you run vm-imap-start-bug-report earlier? ")) (vm-inform 5 "Thank you. Preparing the bug report... ") (vm-inform 1 "Consider running vm-imap-start-bug-report before the problem occurrence")) (let ((process (vm-folder-imap-process))) (if process (vm-imap-end-session (vm-folder-imap-process)))) (let ((trace-buffer-hook (lambda () (let ((bufs vm-kept-imap-buffers) buf) (insert "\n\n") (insert "IMAP Trace buffers - most recent first\n\n") (while bufs (setq buf (car bufs)) (insert "----") (insert (format "%s" buf)) (insert "----------\n") (insert (with-current-buffer buf (buffer-string))) (setq bufs (cdr bufs))) (insert "--------------------------------------------------\n")) ))) (vm-submit-bug-report nil (list trace-buffer-hook)) )) (defun vm-imap-set-default-attributes (m) (vm-set-headers-to-be-retrieved-of m nil) (vm-set-body-to-be-retrieved-of m nil) (vm-set-body-to-be-discarded-of m nil)) (defun vm-imap-unset-body-retrieve () "Unset the body-to-be-retrieved flag of all the messages. May be needed if the folder has become corrupted somehow." (interactive) (save-current-buffer (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((mp vm-message-list)) (while mp (vm-set-body-to-be-retrieved-of (car mp) nil) (vm-set-body-to-be-discarded-of (car mp) nil) (setq mp (cdr mp)))) (vm-inform 5 "Marked %s messages as having retrieved bodies" (length vm-message-list)) )) (defun vm-imap-unset-byte-counts () "Unset the byte counts of all the messages, so that the size of the downloaded bodies will be displayed." (interactive) (save-current-buffer (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((mp vm-message-list)) (while mp (vm-set-byte-count-of (car mp) nil) (setq mp (cdr mp)))) (vm-inform 5 "Unset the byte counts of %s messages" (length vm-message-list)) )) ;;; vm-imap.el ends here vm-8.2.0b/lisp/vm-pcrisis.el0000755000175000017500000017134311676442160016167 0ustar srivastasrivasta;;; vm-pcrisis.el --- wide-ranging auto-setup for personalities in VM ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 1999 Rob Hodges, ;; 2006 Robert Widhopf, Robert P. Goldman ;; 2011 Uday S. Reddy ;; ;; Package: Personality Crisis for VM ;; Author: Rob Hodges ;; ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, you can either send email to this ;; program's maintainer or write to: The Free Software Foundation, ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. ;; DOCUMENTATION: ;; ------------- ;; ;; Documentation is now in Texinfo format, included ;; in the standard VM distribution. ;;; Code: (provide 'vm-pcrisis) (eval-and-compile (require 'timezone) (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-motion) (require 'vm-reply)) (eval-when-compile ;; get the macros we need. (require 'cl) (require 'advice) (condition-case e (progn (require 'regexp-opt) (require 'bbdb) (require 'bbdb-com)) (error (message "%S" e) (message "Could not load bbdb.el. Related functions may not work correctly!") ;; (vm-sit-for 5) ))) (declare-function set-extent-face "vm-xemacs" (extent face)) (declare-function timezone-absolute-from-gregorian "ext:timezone" (month day year)) (declare-function bbdb-buffer "ext:bbdb" ()) (declare-function vm-imap-account-name-for-spec "vm-imap" (maildrop-spec)) (declare-function vm-pop-find-name-for-spec "vm-pop" (maildrop-spec)) ;; Dummy declarations for variables that are defined in bbdb (defvar bbdb-records) (defvar bbdb-file) (defvar bbdb-records) ;; ------------------------------------------------------------------- ;; Variables: ;; ------------------------------------------------------------------- (defconst vmpc-version "0.9.1" "Version of pcrisis.") (defgroup vmpc nil "Manage personalities and more in VM." :group 'vm-ext) (defcustom vmpc-conditions () "*List of conditions which will be checked by pcrisis." :group 'vmpc) (defcustom vmpc-actions () "*List of actions. Actions are associated with conditions from `vmpc-conditions' by one of `vmpc-actions-alist', `vmpc-reply-alist', `', `vmpc-forward-alist', `vmpc-resend-alist', `vmpc-newmail-alist' or `vmpc-automorph-alist'. These are also the actions from which you can choose when using the newmail features of Personality Crisis, or the `vmpc-prompt-for-profile' action. You may also define an action without associated commands, e.g. \"none\"." :type '(repeat (list (string :tag "Action name") (sexp :tag "Commands"))) :group 'vmpc) (defun vmpc-alist-set (symbol value) "Used as :set for vmpc-*-alist variables. Checks if the condition and all the actions exist." (while value (let ((condition (caar value)) (actions (cdar value))) (if (and condition (not (assoc condition vmpc-conditions))) (error "Condition '%s' does not exist!" condition)) (while actions (if (not (assoc (car actions) vmpc-actions)) (error "Action '%s' does not exist!" (car actions))) (setq actions (cdr actions)))) (setq value (cdr value))) (set symbol value)) (defun vmpc-defcustom-alist-type () "Generate :type for vmpc-*-alist variables." (list 'repeat (list 'list (append '(choice :tag "Condition") (mapcar (lambda (c) (list 'const (car c))) vmpc-conditions) '((string))) (list 'repeat :tag "Actions to run" (append '(choice :tag "Action") (mapcar (lambda (a) (list 'const (car a))) vmpc-actions) '(string)))))) (defcustom vmpc-actions-alist () "*An alist associating conditions with actions from `vmpc-actions'. If you do not want to map actions for each state, e.g. for replying, forwarding, resending, composing or automorphing, then set this one." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-reply-alist () "*An alist associating conditions with actions from `vmpc-actions' when replying." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-forward-alist () "*An alist associating conditions with actions from `vmpc-actions' when forwarding." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-automorph-alist () "*An alist associating conditions with actions from `vmpc-actions' when automorphing." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-newmail-alist () "*An alist associating conditions with actions from `vmpc-actions' when composing." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-resend-alist () "*An alist associating conditions with actions from `vmpc-actions' when resending." :type (vmpc-defcustom-alist-type) ; :set 'vmpc-alist-set :group 'vmpc) (defcustom vmpc-default-profile "default" "*The default profile to select if no profile was found." :type '(choice (const :tag "None" nil) (string)) :group 'vmpc) (defcustom vmpc-auto-profiles-file "~/.vmpc-auto-profiles" "*File in which to save information used by `vmpc-prompt-for-profile'. When set to the symbol 'BBDB, profiles will be stored there." :type '(choice (file) (const BBDB)) :group 'vmpc) (defcustom vmpc-auto-profiles-expunge-days 100 "*Number of days after which to expunge old address-profile associations. Performance may suffer noticeably if this file becomes enormous, but in other respects it is preferable for this value to be fairly high. The value that is right for you will depend on how often you send email to new addresses using `vmpc-prompt-for-profile'." :type 'integer :group 'vmpc) (defvar vmpc-current-state nil "The current state of pcrisis. It is one of 'reply, 'forward, 'resend, 'automorph or 'newmail. It controls which actions/functions can/will be run.") (defvar vmpc-current-buffer nil "The current buffer, i.e. 'none or 'composition. It is 'none before running an adviced VM function and 'composition afterward, i.e. when within the composition buffer.") (defvar vmpc-saved-headers-alist nil "Alist of headers from the original message saved for later use.") (defvar vmpc-actions-to-run nil "The actions to run.") (defvar vmpc-true-conditions nil "The true conditions.") (defvar vmpc-auto-profiles nil "The auto profiles as stored in `vmpc-auto-profiles-file'.") ;; An "exerlay" is an overlay in FSF Emacs and an extent in XEmacs. ;; It's not a real type; it's just the way I'm dealing with the damn ;; things to produce containers for the signature and pre-signature ;; which can be highlighted etc. and work on both platforms. (defvar vmpc-pre-sig-exerlay () "Don't mess with this.") (make-variable-buffer-local 'vmpc-pre-sig-exerlay) (defvar vmpc-sig-exerlay () "Don't mess with this.") (make-variable-buffer-local 'vmpc-sig-exerlay) (defvar vmpc-pre-sig-face (progn (make-face 'vmpc-pre-sig-face "Face used for highlighting the pre-signature.") (set-face-foreground 'vmpc-pre-sig-face "forestgreen") 'vmpc-pre-sig-face) "Face used for highlighting the pre-signature.") (defvar vmpc-sig-face (progn (make-face 'vmpc-sig-face "Face used for highlighting the signature.") (set-face-foreground 'vmpc-sig-face "steelblue") 'vmpc-sig-face) "Face used for highlighting the signature.") (defvar vmpc-intangible-pre-sig 'nil "Whether to forbid the cursor from entering the pre-signature.") (defvar vmpc-intangible-sig 'nil "Whether to forbid the cursor from entering the signature.") (defvar vmpc-expect-default-signature 'nil "*Set this to 't if you have a signature-inserting function. It will ensure that pcrisis correctly handles the signature .") ;; ------------------------------------------------------------------- ;; Some easter-egg functionality: ;; ------------------------------------------------------------------- (defun vmpc-my-identities (&rest identities) "Setup pcrisis with the given IDENTITIES." (setq vmpc-conditions '(("always true" t)) vmpc-actions-alist '(("always true" "prompt for a profile")) vmpc-actions '(("prompt for a profile" (vmpc-prompt-for-profile t t)))) (setq vmpc-actions (append (mapcar (lambda (identity) `(,identity (vmpc-substitute-header "From" ,identity))) identities) vmpc-actions))) (defun vmpc-header-field-for-point () "*Return a string indicating the mail header field point is in. If point is not in a header field, returns nil." (save-excursion (unless (save-excursion (re-search-backward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-min) t)) (re-search-backward "^\\([^ \t\n:]+\\):") (match-string 1)))) (defun vmpc-tab-header-or-tab-stop (&optional backward) "*If in a mail header field, moves to next useful header or body. When moving to the message body, calls the `vmpc-automorph' function. If within the message body, runs `tab-to-tab-stop'. If BACKWARD is specified and non-nil, moves to previous useful header field, whether point is in the body or the headers. \"Useful header fields\" are currently, in order, \"To\" and \"Subject\"." (interactive) (let ((curfield) (nextfield) (useful-headers '("To" "Subject"))) (if (or (setq curfield (vmpc-header-field-for-point)) backward) (progn (setq nextfield (- (length useful-headers) (length (member curfield useful-headers)))) (if backward (setq nextfield (nth (1- nextfield) useful-headers)) (setq nextfield (nth (1+ nextfield) useful-headers))) (if nextfield (mail-position-on-field nextfield) (mail-text) (vmpc-automorph)) ) (tab-to-tab-stop) ))) (defun vmpc-backward-tab-header-or-tab-stop () "*Wrapper for `vmpc-tab-header-or-tab-stop' with BACKWARD set." (interactive) (vmpc-tab-header-or-tab-stop t)) ;; ------------------------------------------------------------------- ;; Stuff for dealing with exerlays: ;; ------------------------------------------------------------------- (defun vmpc-set-overlay-insertion-types (overlay start end) "Set insertion types for OVERLAY from START to END. In fact a new copy of OVERLAY with different insertion types at START and END is created and returned. START and END should be nil or t -- the marker insertion types at the start and end. This seems to be the only way you of changing the insertion types for an overlay -- save the overlay properties that we care about, create a new overlay with the new insertion types, set its properties to the saved ones. Overlays suck. Extents rule. XEmacs got this right." (let* ((useful-props (list 'face 'intangible 'evaporate)) (saved-props) (i 0) (len (length useful-props)) (startpos) (endpos) (new-ovl)) (while (< i len) (setq saved-props (append saved-props (cons (overlay-get overlay (nth i useful-props)) ()))) (setq i (1+ i))) (setq startpos (overlay-start overlay)) (setq endpos (overlay-end overlay)) (delete-overlay overlay) (if (and startpos endpos) (setq new-ovl (make-overlay startpos endpos (current-buffer) start end)) (setq new-ovl (make-overlay 1 1 (current-buffer) start end)) (vmpc-forcefully-detach-exerlay new-ovl)) (setq i 0) (while (< i len) (overlay-put new-ovl (nth i useful-props) (nth i saved-props)) (setq i (1+ i))) new-ovl)) (defun vmpc-set-extent-insertion-types (extent start end) "Set the insertion types of EXTENT from START to END. START and END should be either nil or t, indicating the desired value of the 'start-open and 'end-closed properties of the extent respectively. This is the XEmacs version of `vmpc-set-overlay-insertion-types'." ;; pretty simple huh? (vm-set-extent-property extent 'start-open start) (vm-set-extent-property extent 'end-closed end)) (defun vmpc-set-exerlay-insertion-types (exerlay start end) "Set the insertion types for EXERLAY from START to END. In other words, EXERLAY is the name of the overlay or extent with a quote in front. START and END are the equivalent of the marker insertion types for the start and end of the overlay/extent." (if vm-xemacs-p (vmpc-set-extent-insertion-types (symbol-value exerlay) start end) (set exerlay (vmpc-set-overlay-insertion-types (symbol-value exerlay) start end)))) (defun vmpc-exerlay-start (exerlay) "Return buffer position of the start of EXERLAY." (if vm-xemacs-p (vm-extent-start-position exerlay) (overlay-start exerlay))) (defun vmpc-exerlay-end (exerlay) "Return buffer position of the end of EXERLAY." (if vm-xemacs-p (vm-extent-end-position exerlay) (overlay-end exerlay))) (defun vmpc-move-exerlay (exerlay new-start new-end) "Change EXERLAY to cover region from NEW-START to NEW-END." (if vm-xemacs-p (vm-set-extent-endpoints exerlay new-start new-end (current-buffer)) (move-overlay exerlay new-start new-end (current-buffer)))) (defun vmpc-set-exerlay-detachable-property (exerlay newval) "Set the 'detachable or 'evaporate property for EXERLAY to NEWVAL." (if vm-xemacs-p (vm-set-extent-property exerlay 'detachable newval) (overlay-put exerlay 'evaporate newval))) (defun vmpc-set-exerlay-intangible-property (exerlay newval) "Set the 'intangible or 'atomic property for EXERLAY to NEWVAL." (if vm-xemacs-p (progn (require 'atomic-extents) (vm-set-extent-property exerlay 'atomic newval)) (overlay-put exerlay 'intangible newval))) (defun vmpc-set-exerlay-face (exerlay newface) "Set the face used by EXERLAY to NEWFACE." (if vm-xemacs-p (set-extent-face exerlay newface) (overlay-put exerlay 'face newface))) (defun vmpc-forcefully-detach-exerlay (exerlay) "Leave EXERLAY in memory but detaches it from the buffer." (if vm-xemacs-p (vm-detach-extent exerlay) (delete-overlay exerlay))) (defun vmpc-make-exerlay (startpos endpos) "Create a new exerlay spanning from STARTPOS to ENDPOS." (vm-make-extent startpos endpos)) (defun vmpc-create-sig-and-pre-sig-exerlays () "Create the extents in which the pre-sig and sig can reside. Or overlays, in the case of GNU Emacs. Thus, exerlays." (setq vmpc-pre-sig-exerlay (vmpc-make-exerlay 1 2)) (setq vmpc-sig-exerlay (vmpc-make-exerlay 3 4)) (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay t) (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay t) (vmpc-forcefully-detach-exerlay vmpc-pre-sig-exerlay) (vmpc-forcefully-detach-exerlay vmpc-sig-exerlay) (vmpc-set-exerlay-face vmpc-pre-sig-exerlay 'vmpc-pre-sig-face) (vmpc-set-exerlay-face vmpc-sig-exerlay 'vmpc-sig-face) (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay vmpc-intangible-pre-sig) (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay vmpc-intangible-sig) (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay t nil) (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay t nil) ;; deal with signatures inserted by other things than vm-pcrisis: (if vmpc-expect-default-signature (save-excursion (let ((p-max (point-max)) (body-start (save-excursion (mail-text) (point))) (sig-start nil)) (goto-char p-max) (setq sig-start (re-search-backward "\n-- \n" body-start t)) (if sig-start (vmpc-move-exerlay vmpc-sig-exerlay sig-start p-max)))))) ;; ------------------------------------------------------------------- ;; Functions for vmpc-actions: ;; ------------------------------------------------------------------- (defmacro vmpc-composition-buffer (&rest form) "Evaluate FORM if in the composition buffer. That is to say, evaluates the form if you are really in a composition buffer. This function should not be called directly, only from within the `vmpc-actions' list." (list 'if '(eq vmpc-current-buffer 'composition) (list 'eval (cons 'progn form)))) (put 'vmpc-composition-buffer 'lisp-indent-hook 'defun) (defmacro vmpc-pre-function (&rest form) "Evaluate FORM if in pre-function state. That is to say, evaluates the FORM before VM does its thing, whether that be creating a new mail or a reply. This function should not be called directly, only from within the `vmpc-actions' list." (list 'if '(and (eq vmpc-current-buffer 'none) (not (eq vmpc-current-state 'automorph))) (list 'eval (cons 'progn form)))) (put 'vmpc-pre-function 'lisp-indent-hook 'defun) (defun vmpc-delete-header (hdrfield &optional entire) "Delete the contents of a HDRFIELD in the current mail message. If ENTIRE is specified and non-nil, deletes the header field as well." (if (eq vmpc-current-buffer 'composition) (save-excursion (let ((start) (end)) (mail-position-on-field hdrfield) (if entire (setq end (+ (point) 1)) (setq end (point))) (re-search-backward ": ") (if entire (setq start (progn (beginning-of-line) (point))) (setq start (+ (point) 2))) (delete-region start end))))) (defun vmpc-insert-header (hdrfield content) "Insert to HDRFIELD the new CONTENT. Both arguments are strings. The field can either be present or not, but if present, HDRCONT will be appended to the current header contents." (if (eq vmpc-current-buffer 'composition) (save-excursion (mail-position-on-field hdrfield) (insert content)))) (defun vmpc-substitute-header (hdrfield content) "Substitute HDRFIELD with new CONTENT. Both arguments are strings. The field can either be present or not. If the header field is present and already contains something, the contents will be replaced, otherwise a new header is created." (if (eq vmpc-current-buffer 'composition) (save-excursion (vmpc-delete-header hdrfield) (vmpc-insert-header hdrfield content)))) (defun vmpc-add-header (hdrfield content) "Add HDRFIELD with CONTENT if it is not present already. Both arguments are strings. If a header field with the same CONTENT is present already nothing will be done, otherwise a new field with the same name and the new CONTENT will be added to the message. This is suitable for FCC, which can be specified multiple times." (unless (eq vmpc-current-buffer 'composition) (error "attempting to insert a header into a non-composition buffer.")) (let ((prev-contents (vmpc-get-header-contents hdrfield "\n"))) (setq prev-contents (vmpc-split prev-contents "\n")) ;; don't add this new header if it's already there (unless (member content prev-contents) (save-excursion (or (mail-position-on-field hdrfield t) ; Put new field after existing one (mail-position-on-field "to")) (unless (eq (aref hdrfield (1- (length hdrfield))) ?:) (setq hdrfield (concat hdrfield ":"))) (insert "\n" hdrfield " ") (insert content))))) (defun vmpc-get-current-header-contents (hdrfield &optional clump-sep) "Return the contents of HDRFIELD in the current mail message. Returns an empty string if the header doesn't exist. HDRFIELD should be a string. If the string CLUMP-SEP is specified, it means to return the contents of all headers matching the regexp HDRFIELD, separated by CLUMP-SEP." ;; This code is based heavily on vm-get-header-contents and vm-match-header. ;; Thanks Kyle :) (if (eq vmpc-current-state 'automorph) (save-excursion (let ((contents nil) (header-name-regexp "\\([^ \t\n:]+\\):") (case-fold-search t) (temp-contents) (end-of-headers) (regexp)) (if (not (listp hdrfield)) (setq hdrfield (list hdrfield))) ;; find the end of the headers: (goto-char (point-min)) (or (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") nil t) (error "Cannot find mail-header-separator %S in buffer %S" mail-header-separator (current-buffer))) (setq end-of-headers (match-beginning 0)) ;; now rip through finding all the ones we want: (while hdrfield (setq regexp (concat "^\\(" (car hdrfield) "\\)")) (goto-char (point-min)) (while (and (or (null contents) clump-sep) (re-search-forward regexp end-of-headers t) (save-excursion (goto-char (match-beginning 0)) (let (header-cont-start header-cont-end) (if (if (not clump-sep) (and (looking-at (car hdrfield)) (looking-at header-name-regexp)) (looking-at header-name-regexp)) (save-excursion (goto-char (match-end 0)) ;; skip leading whitespace (skip-chars-forward " \t") (setq header-cont-start (point)) (forward-line 1) (while (looking-at "[ \t]") (forward-line 1)) ;; drop the trailing newline (setq header-cont-end (1- (point))))) (setq temp-contents (buffer-substring header-cont-start header-cont-end))))) (if contents (setq contents (concat contents clump-sep temp-contents)) (setq contents temp-contents))) (setq hdrfield (cdr hdrfield))) (if (null contents) (setq contents "")) contents )))) (defun vmpc-get-current-body-text () "Return the body text of the mail message in the current buffer." (if (eq vmpc-current-state 'automorph) (save-excursion (goto-char (point-min)) (let ((start (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))) (end (point-max))) (buffer-substring start end))))) (defun vmpc-get-replied-header-contents (hdrfield &optional clump-sep) "Return the contents of HDRFIELD in the message being replied to. If that header does not exist, returns an empty string. If the string CLUMP-SEP is specified, treat HDRFIELD as a regular expression and return the contents of all header fields which match that regexp, separated from each other by CLUMP-SEP." (if (and (eq vmpc-current-buffer 'none) (memq vmpc-current-state '(reply forward resend))) (let ((mp (car (vm-select-operable-messages 1 (vm-interactive-p) "Operate on"))) content c) (if (not (listp hdrfield)) (setq hdrfield (list hdrfield))) (while hdrfield (setq c (vm-get-header-contents mp (car hdrfield) clump-sep)) (if c (setq content (cons c content))) (setq hdrfield (cdr hdrfield))) (or (mapconcat 'identity content "\n") "")))) (defun vmpc-get-header-contents (hdrfield &optional clump-sep) "Return the contents of HDRFIELD." (cond ((and (eq vmpc-current-buffer 'none) (memq vmpc-current-state '(reply forward resend))) (vmpc-get-replied-header-contents hdrfield clump-sep)) ((eq vmpc-current-state 'automorph) (vmpc-get-current-header-contents hdrfield clump-sep)))) (defun vmpc-get-replied-body-text () "Return the body text of the message being replied to." (if (and (eq vmpc-current-buffer 'none) (memq vmpc-current-state '(reply forward resend))) (save-excursion (let* ((mp (car (vm-select-operable-messages 1 (vm-interactive-p) "Operate on"))) (message (vm-real-message-of mp)) start end) (set-buffer (vm-buffer-of message)) (save-restriction (widen) (setq start (vm-text-of message)) (setq end (vm-end-of message)) (buffer-substring start end)))))) (defun vmpc-save-replied-header (hdrfield) "Save the contents of HDRFIELD in `vmpc-saved-headers-alist'. Does nothing if that header doesn't exist." (let ((hdrcont (vmpc-get-replied-header-contents hdrfield))) (if (and (eq vmpc-current-buffer 'none) (memq vmpc-current-state '(reply forward resend)) (not (equal hdrcont ""))) (add-to-list 'vmpc-saved-headers-alist (cons hdrfield hdrcont))))) (defun vmpc-get-saved-header (hdrfield) "Return the contents of HDRFIELD from `vmpc-saved-headers-alist'. The alist in question is created by `vmpc-save-replied-header'." (if (and (eq vmpc-current-buffer 'composition) (memq vmpc-current-state '(reply forward resend))) (cdr (assoc hdrfield vmpc-saved-headers-alist)))) (defun vmpc-substitute-replied-header (dest src) "Substitute header DEST with content from SRC. For example, if the address you want to send your reply to is the same as the contents of the \"From\" header in the message you are replying to, use (vmpc-substitute-replied-header \"To\" \"From\"." (if (memq vmpc-current-state '(reply forward resend)) (progn (if (eq vmpc-current-buffer 'none) (vmpc-save-replied-header src)) (if (eq vmpc-current-buffer 'composition) (vmpc-substitute-header dest (vmpc-get-saved-header src)))))) (defun vmpc-get-header-extents (hdrfield) "Return buffer positions (START . END) for the contents of HDRFIELD. If HDRFIELD does not exist, return nil." (if (eq vmpc-current-buffer 'composition) (save-excursion (let ((header-name-regexp "^\\([^ \t\n:]+\\):") (start) (end)) (setq end (if (mail-position-on-field hdrfield t) (point) nil)) (setq start (if (re-search-backward header-name-regexp (point-min) t) (match-end 0) nil)) (and start end (<= start end) (cons start end)))))) (defun vmpc-substitute-within-header (hdrfield regexp to-string &optional append-if-no-match sep) "Replace in HDRFIELD strings matched by REGEXP with TO-STRING. HDRFIELD need not exist. TO-STRING may contain references to groups within REGEXP, in the same manner as `replace-regexp'. If REGEXP is not found in the header contents, and APPEND-IF-NO-MATCH is t, TO-STRING will be appended to the header contents (with HDRFIELD being created if it does not exist). In this case, if the string SEP is specified, it will be used to separate the previous header contents from TO-STRING, unless HDRFIELD has just been created or was previously empty." (if (eq vmpc-current-buffer 'composition) (save-excursion (let ((se (vmpc-get-header-extents hdrfield)) (found)) (if se ;; HDRFIELD exists (save-restriction (narrow-to-region (car se) (cdr se)) (goto-char (point-min)) (while (re-search-forward regexp nil t) (setq found t) (replace-match to-string)) (if (and (not found) append-if-no-match) (progn (goto-char (cdr se)) (if (and sep (not (equal (car se) (cdr se)))) (insert sep)) (insert to-string)))) ;; HDRFIELD does not exist (if append-if-no-match (progn (mail-position-on-field hdrfield) (insert to-string)))))))) (defun vmpc-replace-or-add-in-header (hdrfield regexp hdrcont &optional sep) "Replace in HDRFIELD the match of REGEXP with HDRCONT. All arguments are strings. The field can either be present or not. If the header field is present and already contains something, HDRCONT will be appended and if SEP is none nil it will be used as separator. I use this function to modify recipients in the TO-header. e.g. (vmpc-replace-or-add-in-header \"To\" \"[Rr]obert Fenk[^,]*\" \"Robert Fenk\" \", \"))" (if (eq vmpc-current-buffer 'composition) (let ((hdr (vmpc-get-current-header-contents hdrfield)) (old-point (point))) (if hdr (progn (vmpc-delete-header hdrfield) (if (string-match regexp hdr) (setq hdr (vm-replace-in-string hdr regexp hdrcont)) (setq hdr (if sep (concat hdr sep hdrcont) (concat hdr hdrcont)))) (vmpc-insert-header hdrfield hdr) (goto-char old-point)) )))) (defun vmpc-insert-signature (sig &optional pos) "Insert SIG at the end of `vmpc-sig-exerlay'. SIG is a string. If it is the name of a file, its contents is inserted -- otherwise the string itself is inserted. Optional parameter POS means insert the signature at POS if `vmpc-sig-exerlay' is detached." (if (eq vmpc-current-buffer 'composition) (progn (let ((end (or (vmpc-exerlay-end vmpc-sig-exerlay) pos))) (save-excursion (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay nil t) (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay nil) (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay nil) (unless end (setq end (point-max)) (vmpc-move-exerlay vmpc-sig-exerlay end end)) (if (and pos (not (vmpc-exerlay-end vmpc-sig-exerlay))) (vmpc-move-exerlay vmpc-sig-exerlay pos pos)) (goto-char end) (insert "\n-- \n") (if (and (file-exists-p sig) (file-readable-p sig) (not (equal sig ""))) (insert-file-contents sig) (insert sig))) (vmpc-set-exerlay-intangible-property vmpc-sig-exerlay vmpc-intangible-sig) (vmpc-set-exerlay-detachable-property vmpc-sig-exerlay t) (vmpc-set-exerlay-insertion-types 'vmpc-sig-exerlay t nil))))) (defun vmpc-delete-signature () "Deletes the contents of `vmpc-sig-exerlay'." (when (and (eq vmpc-current-buffer 'composition) ;; make sure it's not detached first: (vmpc-exerlay-start vmpc-sig-exerlay)) (delete-region (vmpc-exerlay-start vmpc-sig-exerlay) (vmpc-exerlay-end vmpc-sig-exerlay)) (vmpc-forcefully-detach-exerlay vmpc-sig-exerlay))) (defun vmpc-signature (sig) "Remove a current signature if present, and replace it with SIG. If the string SIG is the name of a readable file, its contents are inserted as the signature; otherwise SIG is inserted literally. If SIG is the empty string (\"\"), the current signature is deleted if present, and that's all." (if (eq vmpc-current-buffer 'composition) (let ((pos (vmpc-exerlay-start vmpc-sig-exerlay))) (save-excursion (vmpc-delete-signature) (if (not (equal sig "")) (vmpc-insert-signature sig pos)))))) (defun vmpc-insert-pre-signature (pre-sig &optional pos) "Insert PRE-SIG at the end of `vmpc-pre-sig-exerlay'. PRE-SIG is a string. If it's the name of a file, the file's contents are inserted; otherwise the string itself is inserted. Optional parameter POS means insert the pre-signature at position POS if `vmpc-pre-sig-exerlay' is detached." (if (eq vmpc-current-buffer 'composition) (progn (let ((end (or (vmpc-exerlay-end vmpc-pre-sig-exerlay) pos)) (sigstart (vmpc-exerlay-start vmpc-sig-exerlay))) (save-excursion (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay nil t) (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay nil) (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay nil) (unless end (if sigstart (setq end sigstart) (setq end (point-max))) (vmpc-move-exerlay vmpc-pre-sig-exerlay end end)) (if (and pos (not (vmpc-exerlay-end vmpc-pre-sig-exerlay))) (vmpc-move-exerlay vmpc-pre-sig-exerlay pos pos)) (goto-char end) (insert "\n") (if (and (file-exists-p pre-sig) (file-readable-p pre-sig) (not (equal pre-sig ""))) (insert-file-contents pre-sig) (insert pre-sig)))) (vmpc-set-exerlay-intangible-property vmpc-pre-sig-exerlay vmpc-intangible-pre-sig) (vmpc-set-exerlay-detachable-property vmpc-pre-sig-exerlay t) (vmpc-set-exerlay-insertion-types 'vmpc-pre-sig-exerlay t nil)))) (defun vmpc-delete-pre-signature () "Deletes the contents of `vmpc-pre-sig-exerlay'." ;; make sure it's not detached first: (if (eq vmpc-current-buffer 'composition) (if (vmpc-exerlay-start vmpc-pre-sig-exerlay) (progn (delete-region (vmpc-exerlay-start vmpc-pre-sig-exerlay) (vmpc-exerlay-end vmpc-pre-sig-exerlay)) (vmpc-forcefully-detach-exerlay vmpc-pre-sig-exerlay))))) (defun vmpc-pre-signature (pre-sig) "Insert PRE-SIG at the end of `vmpc-pre-sig-exerlay' removing last pre-sig." (if (eq vmpc-current-buffer 'composition) (let ((pos (vmpc-exerlay-start vmpc-pre-sig-exerlay))) (save-excursion (vmpc-delete-pre-signature) (if (not (equal pre-sig "")) (vmpc-insert-pre-signature pre-sig pos)))))) (defun vmpc-gregorian-days () "Return the number of days elapsed since December 31, 1 B.C." ;; this code stolen from gnus-util.el :) (let ((tim (decode-time (current-time)))) (timezone-absolute-from-gregorian (nth 4 tim) (nth 3 tim) (nth 5 tim)))) (defun vmpc-load-auto-profiles () "Initialise `vmpc-auto-profiles' from `vmpc-auto-profiles-file'." (interactive) (setq vmpc-auto-profiles nil) (if (eq vmpc-auto-profiles-file 'BBDB) (let ((records (bbdb-with-db-buffer bbdb-records)) profile rec nets) (while records (setq rec (car records) profile (bbdb-get-field rec 'vmpc-profile)) (when (and profile (> (length profile) 0)) (setq nets (bbdb-record-net rec)) (while nets (setq vmpc-auto-profiles (cons (cons (car nets) (read profile)) vmpc-auto-profiles) nets (cdr nets)))) (setq records (cdr records))) (setq vmpc-auto-profiles (reverse vmpc-auto-profiles))) (when (and (file-exists-p vmpc-auto-profiles-file) ; (file-readable-p vmpc-auto-profiles-file)) (save-excursion (set-buffer (get-buffer-create "*pcrisis-temp*")) (buffer-disable-undo (current-buffer)) (erase-buffer) (insert-file-contents vmpc-auto-profiles-file) (goto-char (point-min)) (setq vmpc-auto-profiles (read (current-buffer))) (kill-buffer (current-buffer)))))) (defun vmpc-save-auto-profiles () "Save `vmpc-auto-profiles' to `vmpc-auto-profiles-file'." (when (not (eq vmpc-auto-profiles-file 'BBDB)) (if (not (file-writable-p vmpc-auto-profiles-file)) ;; if file is not writable, signal an error: (error "Error: P-Crisis could not write to file %s" vmpc-auto-profiles-file)) (save-excursion (set-buffer (get-buffer-create "*pcrisis-temp*")) (buffer-disable-undo (current-buffer)) (erase-buffer) (goto-char (point-min)) ; (prin1 vmpc-auto-profiles (current-buffer)) (pp vmpc-auto-profiles (current-buffer)) (write-region (point-min) (point-max) vmpc-auto-profiles-file nil 'quietly) (kill-buffer (current-buffer))))) (defun vmpc-fix-auto-profiles-file () "Change `vmpc-auto-profiles-file' to the format used by v0.82+." (interactive) (vmpc-load-auto-profiles) (let ((len (length vmpc-auto-profiles)) (i 0) (day)) (while (< i len) (setq day (cddr (nth i vmpc-auto-profiles))) (if (consp day) (setcdr (cdr (nth i vmpc-auto-profiles)) (car day))) (setq i (1+ i)))) (vmpc-save-auto-profiles) (setq vmpc-auto-profiles ())) (defun vmpc-migrate-profiles-to-BBDB () "Migrate the profiles stored in `vmpc-auto-profiles-file' to the BBDB. This will automatically create records if they do not exist and add the new field `vmpc-profile' to the records which is a sexp not meant to be edited." (interactive) (if (eq vmpc-auto-profiles-file 'BBDB) (error "`vmpc-auto-profiles-file' has been migrated already.")) (unless vmpc-auto-profiles (vmpc-load-auto-profiles)) ;; create a BBDB backup (bbdb-save-db) (copy-file (expand-file-name bbdb-file) (concat (expand-file-name bbdb-file) "-vmpc-profile-migration-backup")) ;; now migrate the profiles (let ((profiles vmpc-auto-profiles) (records (bbdb-with-db-buffer bbdb-records)) p addr rec) (while profiles (setq p (car profiles) addr (car p) rec (car (bbdb-search records nil nil addr))) (when (not rec) (setq rec (bbdb-create-internal "?" nil addr nil nil nil))) (bbdb-record-putprop rec 'vmpc-profile (format "%S" (cdr p))) (setq profiles (cdr profiles)))) ;; move old profiles file out of the way (rename-file vmpc-auto-profiles-file (concat vmpc-auto-profiles-file "-migrated-to-BBDB")) ;; switch to BBDB mode (customize-save-variable 'vmpc-auto-profiles-file 'BBDB) (message "`vmpc-auto-profiles-file' has been set to 'BBDB")) (defun vmpc-get-profile-for-address (addr) "Return profile for ADDR." (unless vmpc-auto-profiles (vmpc-load-auto-profiles)) ;; TODO: BBDB "normalizes" email addresses, i.e. before we had a one-to-one ;; mapping of address=>actions, now multiple actions may point to the same ;; list of actions. So either we should update vmpc-auto-profiles upon ;; storing a new profile or directly search BBDB for it, which might be ;; slower! (let ((prof (cadr (assoc addr vmpc-auto-profiles)))) (when prof ;; we found a profile for this address and we are still ;; using it -- so "touch" the record to ensure it stays ;; newer than vmpc-auto-profiles-expunge-days (setcdr (cdr (assoc addr vmpc-auto-profiles)) (vmpc-gregorian-days)) (vmpc-save-auto-profiles)) prof)) (defun vmpc-save-profile-for-address (addr actions) "Save the association ADDR => ACTIONS." (let ((today (vmpc-gregorian-days)) (old-association (assoc addr vmpc-auto-profiles)) profile) ;; we store the actions list and the durrent date (setq profile (append (list addr actions) today)) ;; remove old profile (when old-association ;; now possibly delete it from the BBDB (setq vmpc-auto-profiles (delete old-association vmpc-auto-profiles)) (when (and (eq vmpc-auto-profiles-file 'BBDB) (not actions)) (let ((records (bbdb-with-db-buffer bbdb-records)) rec) (setq rec (bbdb-search records nil nil addr)) (when rec (bbdb-record-putprop (car rec) 'vmpc-profile nil))))) ;; add new profile (when actions (setq vmpc-auto-profiles (cons profile vmpc-auto-profiles)) ;; now possibly add it to the BBDB (when (eq vmpc-auto-profiles-file 'BBDB) (let ((records (bbdb-with-db-buffer bbdb-records)) rec) (setq rec (car (bbdb-search records nil nil addr))) (when (not rec) (setq rec (bbdb-create-internal "?" nil addr nil nil nil))) (bbdb-record-putprop rec 'vmpc-profile (format "%S" (cdr profile)))))) ;; expunge old stuff from the list: (when vmpc-auto-profiles-expunge-days (setq vmpc-auto-profiles (mapcar (lambda (p) (if (> (- today (cddr p)) vmpc-auto-profiles-expunge-days) nil p)) vmpc-auto-profiles)) (setq vmpc-auto-profiles (delete nil vmpc-auto-profiles))) ;; save the file (vmpc-save-auto-profiles))) (defun vmpc-string-extract-address (str) "Find the first email address in the string STR and return it. If no email address in found in STR, returns nil." (if (string-match "[^ \t,<]+@[^ \t,>]+" str) (match-string 0 str))) (defun vmpc-split (string separators) "Return a list by splitting STRING at SEPARATORS and trimming all whitespace." (let (result (not-separators (concat "^" separators))) (save-excursion (set-buffer (get-buffer-create " *split*")) (erase-buffer) (insert string) (goto-char (point-min)) (while (progn (skip-chars-forward separators) (skip-chars-forward " \t\n\r") (not (eobp))) (let ((begin (point)) p) (skip-chars-forward not-separators) (setq p (point)) (skip-chars-backward " \t\n\r") (setq result (cons (buffer-substring begin (point)) result)) (goto-char p))) (erase-buffer)) (nreverse result))) (defun vmpc-read-actions (prompt &optional default) "Read a list of actions to run and store it in `vmpc-actions-to-run'. The special action \"none\" will result in an empty action list." (interactive (list "VMPC actions%s: ")) (let ((actions ()) (read-count 0) a) (setq actions (vm-read-string (format prompt (if default (format " %s" default) "")) (append '(("none")) vmpc-actions) t)) (if (string= actions "none") (setq actions nil) (if (string= actions "") (setq actions default) (setq actions (vmpc-split actions " ")) (setq actions (reverse actions)))) (when (vm-interactive-p) (setq vmpc-actions-to-run actions) (message "VMPC actions to run: %S" actions)) actions)) (defcustom vmpc-prompt-for-profile-headers '((composition ("To" "CC" "BCC")) (default ("From" "Sender" "Reply-To" "From" "Resent-From"))) "*List of headers to check for email addresses. `vmpc-prompt-for-profile' will scan the given headers in the given order." :type '(repeat (list (choice (const default) (const composition) (const reply) (const forward) (const resent) (const newmail)) (repeat (string :tag "Header")))) :group 'vmpc) (defvar vmpc-profiles-history nil "History of profiles prompted for.") (defun vmpc-read-profile (&optional require-match initial-contents default) "Read a profile and return it." (unless default (setq default (car vmpc-profiles-history))) (completing-read (format "VMPC profile%s: " (if vmpc-profiles-history (concat " (" default ")") "")) vmpc-auto-profiles nil require-match initial-contents 'vmpc-profiles-history default)) (defun vmpc-prompt-for-profile (&optional remember prompt) "Find a profile or prompt for it and add its actions to the list of actions. A profile is an association between a recipient address and a set of the actions named in `vmpc-actions'. When entering the list of actions, one has to press ENTER after each action and finish adding action by pressing ENTER without an action. The association is stored in `vmpc-auto-profiles-file' and in the future the stored actions will automatically run for messages to that address. REMEMBER can be set to t or 'prompt. When set to 'prompt you will be asked if you want to store the association. When set to t a new profile will be stored without asking. Set PROMPT to t and you will be prompted each time, i.e. not only for unknown profiles. If you want to change the profile only explicitly, then omit the PROMPT argument and call this function interactively in the composition buffer." (interactive (progn (setq vmpc-current-state 'automorph) (list 'prompt t))) (if (or (and (eq vmpc-current-buffer 'none) (not (eq vmpc-current-state 'automorph))) (eq vmpc-current-state 'automorph)) (let ((headers (or (assoc vmpc-current-buffer vmpc-prompt-for-profile-headers) (assoc vmpc-current-state vmpc-prompt-for-profile-headers) (assoc 'default vmpc-prompt-for-profile-headers))) addrs a old-actions actions dest) (setq headers (cadr headers)) ;; search also other headers for known addresses (while (and headers (not actions)) (setq addrs (vmpc-get-header-contents (car headers))) (if addrs (setq addrs (vmpc-split addrs ","))) (while addrs (setq a (vmpc-string-extract-address (car addrs))) (if (vm-ignored-reply-to a) (setq a nil)) (setq actions (append (vmpc-get-profile-for-address a) actions)) (if (not dest) (setq dest a)) (setq addrs (cdr addrs))) (setq headers (cdr headers))) (setq dest (or dest vmpc-default-profile (if prompt (vmpc-read-profile)))) (unless actions (setq actions (vmpc-get-profile-for-address dest))) ;; save action to detect a change (setq old-actions actions) (when dest ;; figure out which actions to run (when (or prompt (not actions)) (setq actions (vmpc-read-actions (format "Actions for \"%s\"%%s: " dest) actions))) ;; fixed old style format where there was only a single action (unless (listp actions) (setq remember t) (setq actions (list actions))) ;; save the association of this profile with these actions ;; if applicable (if (and (not (equal old-actions actions)) (or (eq remember t) (and (eq remember 'prompt) (if actions (y-or-n-p (format "Always run %s for \"%s\"? " actions dest)) (if (vmpc-get-profile-for-address dest) (yes-or-no-p (format "Delete profile for \"%s\"? " dest))))))) (vmpc-save-profile-for-address dest actions)) ;; TODO: understand when vmpc-prompt-for-profile has to run actions ;; if we are in automorph (actually being called from within ;; an action) (if (eq vmpc-current-state 'automorph) (let ((vmpc-actions-to-run actions)) (vmpc-run-actions)) ;; otherwise add the actions to the end of the list as a ;; side effect (setq vmpc-actions-to-run (append vmpc-actions-to-run actions))) ;; return the actions, which makes the condition true if a ;; profile exists actions)))) ;; ------------------------------------------------------------------- ;; Functions for vmpc-conditions: ;; ------------------------------------------------------------------- (defun vmpc-none-true-yet (&optional &rest exceptions) "True if none of the previous evaluated conditions was true. This is a condition that can appear in `vmpc-conditions'. If EXCEPTIONS are specified, it means none were true except those. For example, if you wanted to check whether no conditions had yet matched with the exception of the two conditions named \"default\" and \"blah\", you would make the call like this: (vmpc-none-true-yet \"default\" \"blah\") Then it will return true regardless of whether \"default\" and \"blah\" had matched." (let ((lenex (length exceptions)) (lentc (length vmpc-true-conditions))) (cond ((> lentc lenex) 'nil) ((<= lentc lenex) (let ((i 0) (j 0) (k 0)) (while (< i lenex) (setq k 0) (while (< k lentc) (if (equal (nth i exceptions) (nth k vmpc-true-conditions)) (setq j (1+ j))) (setq k (1+ k))) (setq i (1+ i))) (if (equal j lentc) 't 'nil)))))) (defun vmpc-other-cond (condition) "Return true if the specified CONDITION in `vmpc-conditions' matched. CONDITION can only be the name of a condition specified earlier in `vmpc-conditions' -- that is to say, any conditions which follow the one containing `vmpc-other-cond' will show up as not having matched, because they haven't yet been checked when this one is checked." (member condition vmpc-true-conditions)) (defun vmpc-folder-match (regexp) "Return true if the current folder name matches REGEXP." (string-match regexp (buffer-name))) (defun vmpc-folder-account-match (account-regexp) "Return true if the current folder's POP/IMAP account name matches REGEXP." (let ((account (cond ((eq vm-folder-access-method 'imap) (vm-imap-account-name-for-spec (vm-folder-imap-maildrop-spec))) ((eq vm-folder-access-method 'pop) (vm-pop-find-name-for-spec (vm-folder-pop-maildrop-spec))) (t "") ))) (string-match account-regexp account))) (defun vmpc-header-match (hdrfield regexp &optional clump-sep num) "Return true if the contents of specified header HDRFIELD match REGEXP. For automorph, this means the header in your message, when replying it means the header in the message being replied to. CLUMP-SEP is specified, treat HDRFIELD as a regular expression and return the contents of all header fields which match that regexp, separated from each other by CLUMP-SEP. If NUM is specified return the match string NUM." (cond ((memq vmpc-current-state '(reply forward resend)) (let ((hdr (vmpc-get-replied-header-contents hdrfield clump-sep))) (and hdr (string-match regexp hdr) (if num (match-string num hdr) t)))) ((eq vmpc-current-state 'automorph) (let ((hdr (vmpc-get-current-header-contents hdrfield clump-sep))) (and (string-match regexp hdr) (if num (match-string num hdr) t)))))) (defun vmpc-only-from-match (hdrfield regexp &optional clump-sep) "Return non-nil if all emails from the given HDRFIELD are matched by REGEXP." (let* ((content (vmpc-get-header-contents hdrfield clump-sep)) (case-fold-search t) (pos 0) (len (length content)) (only-from (not (null content)))) (while (and only-from (< pos len) (setq pos (string-match "[a-z0-9._-]+@[a-z0-9._-]+" content pos))) (if (not (string-match regexp (match-string 0 content))) (setq only-from nil)) (setq pos (1+ pos))) only-from)) (defun vmpc-body-match (regexp) "Return non-nil if the contents of the message body match REGEXP. For automorph, this means the body of your message; when replying it means the body of the message being replied to." (cond ((and (memq vmpc-current-state '(reply forward resend)) (eq vmpc-current-buffer 'none)) (string-match regexp (vmpc-get-replied-body-text))) ((eq vmpc-current-state 'automorph) (string-match regexp (vmpc-get-current-body-text))))) (defun vmpc-xor (&rest args) "Return true if one and only one argument in ARGS is true." (= 1 (length (delete nil args)))) ;; ------------------------------------------------------------------- ;; Support functions for the advices: ;; ------------------------------------------------------------------- (defun vmpc-true-conditions () "Return a list of all true conditions. Run this function in order to test/check your conditions." (interactive) (let (vmpc-true-conditions vmpc-current-state vmpc-current-buffer) (if (eq major-mode 'vm-mail-mode) (setq vmpc-current-state 'automorph vmpc-current-buffer 'composition) (setq vmpc-current-state (intern (completing-read "VMPC state (default is 'reply): " '(("reply") ("forward") ("resend") ("newmail") ("automorph")) nil t nil nil "reply")) vmpc-current-buffer 'none)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vmpc-build-true-conditions-list) (message "VMPC true conditions: %S" vmpc-true-conditions) vmpc-true-conditions)) (defun vmpc-build-true-conditions-list () "Build list of true conditions and store it in the variable `vmpc-true-conditions'." (interactive) (setq vmpc-true-conditions nil) (mapc (lambda (c) (if (save-excursion (eval (cons 'progn (cdr c)))) (setq vmpc-true-conditions (cons (car c) vmpc-true-conditions)))) vmpc-conditions) (setq vmpc-true-conditions (reverse vmpc-true-conditions))) (defun vmpc-build-actions-to-run-list () "Build a list of the actions to run. These are the true conditions mapped to actions. Duplicates will be eliminated. You may run it in a composition buffer in order to see what actions will be run." (interactive) (if (and (vm-interactive-p) (not (member major-mode '(vm-mail-mode mail-mode)))) (error "Run `vmpc-build-actions-to-run-list' in a composition buffer!")) (let ((alist (or (symbol-value (intern (format "vmpc-%s-alist" vmpc-current-state))) vmpc-actions-alist)) (old-vmpc-actions-to-run vmpc-actions-to-run) actions) (setq vmpc-actions-to-run nil) (mapc (lambda (c) (setq actions (cdr (assoc c alist))) ;; TODO: warn about unbound conditions? (while actions (if (not (member (car actions) vmpc-actions-to-run)) (setq vmpc-actions-to-run (cons (car actions) vmpc-actions-to-run))) (setq actions (cdr actions)))) vmpc-true-conditions) (setq vmpc-actions-to-run (reverse vmpc-actions-to-run)) (setq vmpc-actions-to-run (append vmpc-actions-to-run old-vmpc-actions-to-run))) (if (vm-interactive-p) (message "VMPC actions to run: %S" vmpc-actions-to-run)) vmpc-actions-to-run) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vmpc-run-action (&optional action-regexp) "Run all actions with names matching the ACTION-REGEXP. If called interactivly it promts for the regexp. You may also use completion." (interactive) (let ((action-names (mapcar (lambda (a) (list (regexp-quote (car a)) 1)) vmpc-actions))) (if (not action-regexp) (setq action-regexp (completing-read "VMPC action-regexp: " action-names))) (mapcar (lambda (action) (if (string-match action-regexp (car action)) (mapcar (lambda (action-command) (eval action-command)) (cdr action)))) vmpc-actions))) (defun vmpc-run-actions (&optional actions verbose) "Run the argument actions, or the actions stored in `vmpc-actions-to-run'. If verbose is supplied, it should be a STRING, indicating the name of a buffer to which to write diagnostic output." (interactive) (if (and (not vmpc-actions-to-run) (not actions) (vm-interactive-p)) (setq vmpc-actions-to-run (vmpc-read-actions "Actions: "))) (let ((actions (or actions vmpc-actions-to-run)) form) (while actions (setq form (or (assoc (car actions) vmpc-actions) (error "Action %S does not exist!" (car actions))) actions (cdr actions)) (let ((form (cons 'progn (cdr form))) (results (eval (cons 'progn (cdr form))))) (when verbose (save-excursion (set-buffer verbose) (insert (format "Action form is:\n%S\nResults are:\n%S\n" form results)))))))) ;; ------------------------------------------------------------------------ ;; The main functions and advices -- these are the entry points to pcrisis: ;; ------------------------------------------------------------------------ (defun vmpc-init-vars (&optional state buffer) "Initialize pcrisis variables and optionally set STATE and BUFFER." (setq vmpc-saved-headers-alist nil vmpc-actions-to-run nil vmpc-true-conditions nil vmpc-current-state state vmpc-current-buffer (or buffer 'none))) (defun vmpc-make-vars-local () "Make the pcrisis vars buffer local. When the vars are first set they cannot be made buffer local as we are not in the composition buffer then. Unfortunately making them buffer local while they are bound by a `let' does not work, see the info for `make-local-variable'. So we are using the global ones and make them buffer local when in the composition buffer. At least for `saved-headers-alist' this should fix the bug that another composition overwrites the stored headers for subsequent morphs. The current solution is not reentrant save, but there also should be no recursion nor concurrent calls." ;; make the variables buffer local (let ((tc vmpc-true-conditions) (sha vmpc-saved-headers-alist) (atr vmpc-actions-to-run) (cs vmpc-current-state)) (make-local-variable 'vmpc-true-conditions) (make-local-variable 'vmpc-saved-headers-alist) (make-local-variable 'vmpc-actions-to-run) (make-local-variable 'vmpc-current-state) (make-local-variable 'vmpc-current-buffer) ;; now set them again to make sure the contain the right value (setq vmpc-true-conditions tc) (setq vmpc-saved-headers-alist sha) (setq vmpc-actions-to-run atr) (setq vmpc-current-state cs)) ;; mark, that we are in the composition buffer now (setq vmpc-current-buffer 'composition) ;; BUGME why is the global value resurrected after making the variable ;; buffer local? Is this related to defadvice? I have no idea what is ;; going on here! Thus we clear it afterwards now! (save-excursion (set-buffer (get-buffer-create " *vmpc-cleanup*")) (vmpc-init-vars) (setq vmpc-current-buffer nil))) (defadvice vm-do-reply (around vmpc-reply activate) "*Reply to a message with pcrisis voodoo." (vmpc-init-vars 'reply) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defadvice vm-mail (around vmpc-newmail activate) "*Start a new message with pcrisis voodoo." (vmpc-init-vars 'newmail) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defadvice vm-compose-mail (around vmpc-compose-newmail activate) "*Start a new message with pcrisis voodoo." (vmpc-init-vars 'newmail) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defadvice vm-forward-message (around vmpc-forward activate) "*Forward a message with pcrisis voodoo." ;; this stuff is already done when replying, but not here: (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) ;; the rest is almost exactly the same as replying: (vmpc-init-vars 'forward) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defadvice vm-forward-message-plain (around vmpc-forward activate) "*Forward a message in plain text with pcrisis voodoo." ;; this stuff is already done when replying, but not here: (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) ;; the rest is almost exactly the same as replying: (vmpc-init-vars 'forward) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defadvice vm-resend-message (around vmpc-resend activate) "*Resent a message with pcrisis voodoo." ;; this stuff is already done when replying, but not here: (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) ;; the rest is almost exactly the same as replying: (vmpc-init-vars 'resend) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions) ad-do-it (vmpc-create-sig-and-pre-sig-exerlays) (vmpc-make-vars-local) (vmpc-run-actions)) (defvar vmpc-no-automorph nil "When true automorphing will be disabled.") (make-variable-buffer-local 'vmpc-no-automorph) ;;;###autoload (defun vmpc-toggle-no-automorph () "Disable automorph for the current buffer. When automorph is not doing the right thing and you want to disable it for the current composition, then call this function." (interactive) (setq vmpc-no-automorph (not vmpc-no-automorph)) (message (if vmpc-no-automorph "Automorphing has been enabled" "Automorphing has been disabled"))) ;;;###autoload (defun vmpc-automorph () "*Change contents of the current mail message based on its own headers. Unless `vmpc-current-state' is 'no-automorph, headers and signatures can be changed; pre-signatures added; functions called. Call `vmpc-no-automorph' to disable it for the current buffer." (interactive) (unless vmpc-no-automorph (vmpc-make-vars-local) (vmpc-init-vars 'automorph 'composition) (vmpc-build-true-conditions-list) (vmpc-build-actions-to-run-list) (vmpc-run-actions))) ;;; vm-pcrisis.el ends here vm-8.2.0b/lisp/vm-search.el0000755000175000017500000001244611676442160015756 0ustar srivastasrivasta;;; vm-search.el --- Incremental search through a mail folder ;; ;; This file is part of VM ;; ;; Copyright (C) 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-search) (eval-and-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-undo) (require 'vm-startup) (require 'vm-motion) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) ) ;;;###autoload (defun vm-isearch-forward (&optional arg) "Incrementally search forward through the current folder's messages. Usage is identical to the standard Emacs incremental search. When the search terminates the message containing point will be selected. If the variable vm-search-using-regexps is non-nil, regular expressions are understood; nil means the search will be for the input string taken literally. Specifying a prefix ARG interactively toggles the value of vm-search-using-regexps for this search." (interactive "P") (let ((vm-search-using-regexps (if arg (not vm-search-using-regexps) vm-search-using-regexps))) (vm-isearch t))) ;;;###autoload (defun vm-isearch-backward (&optional arg) "Incrementally search backward through the current folder's messages. Usage is identical to the standard Emacs incremental search. When the search terminates the message containing point will be selected. If the variable vm-search-using-regexps is non-nil, regular expressions are understood; nil means the search will be for the input string taken literally. Specifying a prefix ARG interactively toggles the value of vm-search-using-regexps for this search." (interactive "P") (let ((vm-search-using-regexps (if arg (not vm-search-using-regexps) vm-search-using-regexps))) (vm-isearch nil))) (defun vm-isearch (forward) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-virtual-folder) (vm-display (current-buffer) t '(vm-isearch-forward vm-isearch-backward) (list this-command 'searching-message)) (let ((clip-head (point-min)) (clip-tail (point-max)) (old-vm-message-pointer vm-message-pointer)) (unwind-protect (progn (select-window (vm-get-visible-buffer-window (current-buffer))) (widen) (add-hook 'pre-command-hook 'vm-isearch-widen) ;; order is significant, we want to narrow after ;; the update (add-hook 'post-command-hook 'vm-isearch-narrow) (add-hook 'post-command-hook 'vm-isearch-update) (isearch-mode forward vm-search-using-regexps nil t) (vm-isearch-update) (if (not (eq vm-message-pointer old-vm-message-pointer)) (progn (vm-record-and-change-message-pointer old-vm-message-pointer vm-message-pointer) (vm-update-summary-and-mode-line) ;; vm-show-current-message only adjusts (point-max), ;; it doesn't change (point-min). (widen) (narrow-to-region (if (< (point) (vm-vheaders-of (car vm-message-pointer))) (vm-start-of (car vm-message-pointer)) (vm-vheaders-of (car vm-message-pointer))) (vm-text-end-of (car vm-message-pointer))) (save-excursion (vm-energize-urls)) (vm-display nil nil '(vm-isearch-forward vm-isearch-backward) '(reading-message)) ;; turn the unwinds into a noop (setq old-vm-message-pointer vm-message-pointer) (setq clip-head (point-min)) (setq clip-tail (point-max))))) (remove-hook 'pre-command-hook 'vm-isearch-widen) (remove-hook 'post-command-hook 'vm-isearch-update) (remove-hook 'post-command-hook 'vm-isearch-narrow) (narrow-to-region clip-head clip-tail) (setq vm-message-pointer old-vm-message-pointer)))) (defun vm-isearch-widen () (if (eq major-mode 'vm-mode) (widen))) ;;;###autoload (defun vm-isearch-narrow () (if (eq major-mode 'vm-mode) (narrow-to-region (if (< (point) (vm-vheaders-of (car vm-message-pointer))) (vm-start-of (car vm-message-pointer)) (vm-vheaders-of (car vm-message-pointer))) (vm-text-end-of (car vm-message-pointer))))) ;;;###autoload (defun vm-isearch-update () (if (eq major-mode 'vm-mode) (if (and (>= (point) (vm-start-of (car vm-message-pointer))) (<= (point) (vm-end-of (car vm-message-pointer)))) nil (let ((mp vm-message-list) (point (point))) (while mp (if (and (>= point (vm-start-of (car mp))) (<= point (vm-end-of (car mp)))) (setq vm-message-pointer mp mp nil) (setq mp (cdr mp)))) (setq vm-need-summary-pointer-update t) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line))))) ;;; vm-search.el ends here vm-8.2.0b/lisp/vm-summary-faces.el0000755000175000017500000001450511676442160017263 0ustar srivastasrivasta;;; vm-summary-faces.el --- faces support for VM summary buffers ;; ;; This file is part of VM ;; ;; Copyright (C) 2001 Robert Fenk ;; Copyright (C) 2010 Uday S Reddy ;; ;; Author: Robert Fenk ;; Status: Tested with XEmacs 21.4.15 & VM 7.18 ;; Keywords: VM ;; X-URL: http://www.robf.de/Hacking/elisp ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; ;; to use this add the following line to your ~/.vm file ;; ;; (add-hook 'vm-summary-mode-hook 'vm-summary-faces-mode) ;; ;;; Code (provide 'vm-summary-faces) (eval-when-compile (require 'vm-misc)) (eval-and-compile (require 'vm-summary) (require 'vm-virtual)) ;; (eval-and-compile ;; (if vm-xemacs-p (require 'overlay))) (declare-function vm-extent-property "vm-misc.el" (overlay prop) t) (declare-function vm-set-extent-property "vm-misc.el" (overlay prop value) t) (eval-and-compile (if (fboundp 'mapcar-extents) (defun vm-summary-faces-list-extents () (mapcar-extents 'identity)) (defun vm-summary-faces-list-extents () (let ((o (overlay-lists))) (nconc (car o) (cdr o)))))) (defvar vm-summary-faces-hide nil "Last face hidden by `vm-summary-faces-hide'.") ;;;###autoload (defun vm-summary-faces-hide (&optional prop) "Toggle visibility of a particular vm-summary-face. By default, the deleted face is toggled (with the effect that all deleted messages will be hidden or unhidden). With a prefix argument, the property name identifying the face is queried interactively. The property is a keyword such as edited, collapsed or outgoing which has an associated face such as vm-summary-edited. See `vm-summary-faces-alist' for a list of available face names." (interactive "P") (if (and (listp prop) (numberp (car prop))) (setq prop (completing-read "Face name: " (mapcar (lambda (f) (list (format "%s" (cadr f)))) vm-summary-faces-alist) nil t "vm-summary-deleted"))) (setq prop (or prop vm-summary-faces-hide "vm-summary-deleted")) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-summarize) (set-buffer vm-summary-buffer) (let ((extents (vm-summary-faces-list-extents)) (hidden-face (intern prop)) x faces) (while extents (setq x (car extents)) (setq faces (vm-extent-property x 'face)) (unless (listp faces) (setq faces (list faces))) (when (memq hidden-face faces) (vm-set-extent-property x 'invisible (not (vm-extent-property x 'invisible)))) (setq extents (cdr extents))))) ;;;###autoload (defun vm-summary-faces-add (msg) "Add a face to a summary entry according to `vm-summary-faces-alist'." (let ((faces vm-summary-faces-alist) (x (or (vm-su-summary-mouse-track-overlay-of msg) (vm-extent-at (vm-su-start-of msg)) (vm-extent-at (vm-su-end-of msg))))) (while faces (when (apply 'vm-vs-or msg (list (caar faces))) (cond ((vm-collapsed-root-p msg) (vm-set-extent-property x 'face (list (cadar faces) 'vm-summary-collapsed))) ((vm-expanded-root-p msg) (vm-set-extent-property x 'face (list (cadar faces) 'vm-summary-expanded))) (t (vm-set-extent-property x 'face (list (cadar faces))))) (setq faces nil)) (setq faces (cdr faces))))) (defun vm-summary-faces-destroy () "Removes the face from all summary entries." (let ((extents (vm-summary-faces-list-extents)) x) (while extents (setq x (car extents)) (vm-set-extent-property x 'face nil) (setq extents (cdr extents))))) ;;;###autoload (defun vm-summary-faces-mode (&optional arg) "Toggle `vm-summary-faces-mode'. Optional argument ARG should be 0 or 1, indicating whether the summary faces should be off or on. When it is on, the VM summary buffers are decorated with faces, i.e., fonts and colors, for easy recogniton of the message status." (interactive "P") (if (null arg) (setq vm-summary-enable-faces (not vm-summary-enable-faces)) (if (> (prefix-numeric-value arg) 0) (setq vm-summary-enable-faces t) (setq vm-summary-enable-faces nil))) (when (vm-interactive-p) (vm-inform 1 "VM summary faces mode is %s" (if vm-summary-enable-faces "on" "off"))) (if (memq major-mode '(vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode)) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-summarize) (set-buffer vm-summary-buffer) (if vm-summary-enable-faces (progn (mapc 'vm-summary-faces-add vm-message-list) (if vm-summary-overlay (vm-set-extent-property vm-summary-overlay 'face 'vm-summary-selected))) (vm-summary-faces-destroy) (if vm-summary-overlay (vm-set-extent-property vm-summary-overlay 'face vm-summary-highlight-face)))))) ;; No need for advice because the code has been integrated into ;; VM. USR, 2010-08-01 ;; (defadvice vm-mouse-set-mouse-track-highlight ;; (after vm-summary-faces activate) ;; (when (and vm-summary-enable-faces ;; (eq major-mode 'vm-summary-mode) ;; (boundp 'm) ;; m) ;; ;; FIXME there is a warning about a free variable here, sorry! ;; (vm-summary-faces-add m))) (defun vm-summary-faces-fix-pointer () (if vm-summary-overlay (vm-set-extent-property vm-summary-overlay 'face (if vm-summary-enable-faces 'vm-summary-selected vm-summary-highlight-face)))) (add-hook 'vm-summary-pointer-update-hook 'vm-summary-faces-fix-pointer) vm-8.2.0b/lisp/vm-startup.el0000755000175000017500000000014711676442161016207 0ustar srivastasrivasta;; This file is only here for compatibility with older VM versions (require 'vm) (provide 'vm-startup) vm-8.2.0b/lisp/vm-autoload.el0000755000175000017500000000020711676442161016312 0ustar srivastasrivasta;; only for compatibility with older BBDB and others (if (not (featurep 'xemacs)) (require 'vm-autoloads)) (provide 'vm-autoload) vm-8.2.0b/lisp/vm-build.el0000755000175000017500000000757111676442160015613 0ustar srivastasrivasta;; Add the current dir to the load-path (setq load-path (cons default-directory load-path)) ;(setq debug-on-error t) ;(setq debug-ignored-errors nil) ;(message "load-path: %S" load-path) (defun vm-fix-cygwin-path (path) "If PATH does not exist, try the DOS path instead. This handles EmacsW32 path problems when building on cygwin." (if (file-exists-p path) path (let ((dos-path (cond ((functionp 'mswindows-cygwin-to-win32-path) (mswindows-cygwin-to-win32-path path)) ((and (locate-library "cygwin-mount") (require 'cygwin-mount)) (cygwin-mount-activate) (cygwin-mount-convert-file-name path)) ((string-match "^/cygdrive/\\([a-z]\\)" path) (replace-match (format "%s:" (match-string 1 path)) t t path))))) (if (and dos-path (file-exists-p dos-path)) dos-path path)))) ;; Add additional dirs to the load-path (condition-case err (when (getenv "OTHERDIRS") (let ((otherdirs (read (format "%s" (getenv "OTHERDIRS")))) dir) (while otherdirs (setq dir (car otherdirs)) (if (not (file-exists-p dir)) (error "Extra `load-path' directory %S does not exist!" dir)) ;; (print (format "Adding %S" dir)) (setq load-path (cons dir load-path) otherdirs (cdr otherdirs))))) ((end-of-file) nil) ((invalid-read-syntax) (message "OTHERDIRS=%S rejected by `read': %s" (getenv "OTHERDIRS") ;(error-message-string err) err ))) ;; Load byte compile (require 'bytecomp) ;; Current public setting ;; Check for undefined functions, ignore save-excursion problems (setq byte-compile-warnings '(not suspicious)) ;; Old permissive setting ;; (setq byte-compile-warnings '(free-vars)) (put 'inhibit-local-variables 'byte-obsolete-variable nil) ;; Preload these to get macros right (require 'cl) (require 'sendmail) ;; now add VM source dirs to load-path and preload some (setq load-path (append '("." "./lisp") load-path)) (require 'vm-macro) (require 'vm-version) (require 'vm-message) (require 'vm-vars) (defun vm-custom-make-dependencies () (if (load-library "cus-dep") (if (functionp 'Custom-make-dependencies) (Custom-make-dependencies) (let ((generated-custom-dependencies-file "vm-cus-load.el")) (custom-make-dependencies))) (error "Failed to load 'cus-dep'"))) (defun vm-built-autoloads (&optional autoloads-file source-dir) (let ((autoloads-file (or autoloads-file (vm-fix-cygwin-path (car command-line-args-left)))) (source-dir (or source-dir (vm-fix-cygwin-path (car (cdr command-line-args-left))))) (debug-on-error t) (enable-local-eval nil)) (if (not (file-exists-p source-dir)) (error "Built directory %S does not exist!" source-dir)) (message "Building autoloads file %S\nin directory %S." autoloads-file source-dir) (load-library "autoload") (set-buffer (find-file-noselect autoloads-file)) (erase-buffer) (setq generated-autoload-file autoloads-file) (setq autoload-package-name "vm") (setq make-backup-files nil) (if (featurep 'xemacs) (progn (update-autoloads-from-directory source-dir) (fixup-autoload-buffer (concat (if autoload-package-name autoload-package-name (file-name-nondirectory defdir)) "-autoloads")) (save-some-buffers t)) ;; GNU Emacs 21 wants some content, but 22 does not like it ... (insert ";;; vm-autoloads.el --- automatically extracted autoloads\n") (insert ";;\n") (insert ";;; Code:\n") (cond ((>= emacs-major-version 22) (update-directory-autoloads source-dir)) ((>= emacs-major-version 21) (update-autoloads-from-directories source-dir)) (t (error "Do not know how to generate autoloads")))))) (provide 'vm-build) vm-8.2.0b/lisp/vm-message-history.el0000755000175000017500000002147711676442160017640 0ustar srivastasrivasta;;; vm-message-history.el --- Move backward & forward through selected messages ;; -*-unibyte: t; coding: iso-8859-1;-*- ;; ;; This file is an add-on for VM ;; Copyright © 2003 Kevin Rodgers, 2008 Robert Widhopf-Fenk ;; Author: Kevin Rodgers ;; Created: 6 Oct 2003 ;; Keywords: mail, history ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation; either version 2 of ;; the License, or (at your option) any later version. ;; This program is distributed in the hope that it will be ;; useful, but WITHOUT ANY WARRANTY; without even the implied ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. See the GNU General Public License for more details. ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, ;; MA 02111-1307 USA ;;; Commentary: ;; VM defines the `vm-goto-message-last-seen' command (bound to TAB) to ;; toggle between 2 messages, but doesn't provide a general history ;; mechanism. This library allows the user to move backward and forward ;; through the messages that have already been selected in each folder. ;; It mimics a web browser in that selecting a message causes more ;; recently selected messages in the history list to be forgotten ;; (except when using `vm-goto-message-last-seen' or one of the ;; vm-message-history.el commands). ;;; Usage: ;; ;; Add the follwoing line to your ~/.vm ;; ;; (require 'vm-message-history) ;; ;; Visit a folder, move around and the use the key bindings or menu items for ;; the moving and browsing the history. ;; C-c p, Motion -> Backward in History ;; C-c n, Motion -> Forward in History ;; C-c b, Motion -> Browse History ;;; TODO: Handle Expunged messages in the history list? ;;; Code: (provide 'vm-message-history) (eval-and-compile (require 'easymenu) (require 'vm-menu) (require 'vm-misc) (require 'vm-summary) (require 'vm-page) (require 'vm-window) (require 'vm-motion) ) (defgroup vm-message-history nil "Message history for VM folders." :group 'vm-ext) (defcustom vm-message-history-max 32 "The number of read or previewed messages in each folder's history." :type 'integer :group 'vm-message-history) (defvar vm-message-history nil "A list of messages in the current folder.") (make-variable-buffer-local 'vm-message-history) (defvar vm-message-history-pointer nil "The cons in `vm-message-history' whose car is the current message.") (make-variable-buffer-local 'vm-message-history-pointer) (define-key vm-mode-map "\C-cp" 'vm-message-history-backward) (define-key vm-mode-map "\C-cn" 'vm-message-history-forward) (define-key vm-mode-map "\C-cb" 'vm-message-history-browse) (setq vm-menu-motion-menu (append vm-menu-motion-menu '(["Backward in History" vm-message-history-backward t] ["Forward in History" vm-message-history-forward t] ["Browse History" vm-message-history-browse :active (save-excursion (vm-select-folder-buffer) vm-message-history)]))) ;;;###autoload (defun vm-message-history-add () "Add the selected message to `vm-message-history'. \(Unless the message was selected via \\[vm-message-history-backward] or \\[vm-message-history-forward].)" (when (not (memq this-command '(vm-goto-message-last-seen vm-message-history-backward vm-message-history-forward vm-message-history-browse-select))) ;; remove message if it was there already (when (memq (car vm-message-pointer) vm-message-history) (setq vm-message-history (delq (car vm-message-pointer) vm-message-history) vm-message-history-pointer vm-message-history)) ;; add new message to head (setq vm-message-history-pointer ;; Discard messages selected after the current message: (setq vm-message-history (cons (car vm-message-pointer) vm-message-history-pointer))) ;; Discard oldest messages: (setcdr (or (nthcdr (1- vm-message-history-max) vm-message-history) '(t)) ; hack! nil))) ;;;###autoload (defun vm-message-history-backward (&optional arg) "Select the previous message in the current folder's history. With prefix ARG, select the ARG'th previous message." (interactive "p") (or arg (setq arg 1)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (or vm-message-history (error "No message history")) (cond ((> arg 0) (setq vm-message-history-pointer (or (nthcdr arg vm-message-history-pointer) ;; wrap around to newest message: vm-message-history))) ((< arg 0) (let ((pointer vm-message-history)) (while (and pointer (not (eq (nthcdr (- arg) pointer) vm-message-history-pointer))) (setq pointer (cdr pointer))) (setq vm-message-history-pointer (or pointer ;; wrap around to oldest message: (if (fboundp 'last) (last vm-message-history) ; Emacs 21, or cl.el (progn (setq pointer vm-message-history) (while (consp (cdr pointer)) (setq pointer (cdr pointer))) pointer))))))) (if (eq (car vm-message-pointer) (car vm-message-history-pointer)) (vm-present-current-message) (vm-record-and-change-message-pointer vm-message-pointer (vm-message-position (car vm-message-history-pointer))) (vm-present-current-message)) (vm-message-history-browse)) ;;;###autoload (defun vm-message-history-forward (&optional arg) "Select the next message in the current folder's history. With prefix ARG, select the ARG'th next message." (interactive "p") (vm-message-history-backward (- arg))) (defvar vm-message-history-menu nil "A popup menu of messages, generated from `vm-message-history'.") (defun vm-message-history-browse-select () "Select the message below the cursor." (interactive) (let ((mp (get-text-property (point) 'vm-message-pointer))) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-record-and-change-message-pointer vm-message-pointer mp) (vm-present-current-message) (vm-display nil nil '(vm-goto-message-last-seen) '(vm-goto-message-last-seen)) (vm-message-history-browse))) (defvar vm-message-history-browse-mode-map (let ((map (make-sparse-keymap))) (define-key map "\r" 'vm-message-history-browse-select) (define-key map "=" 'vm-summarize) (define-key map "q" 'bury-buffer) (define-key map "p" 'vm-message-history-backward) (define-key map "n" 'vm-message-history-forward) map)) ;;;###autoload (defun vm-message-history-browse () "Select a message from a popup menu of the current folder's history." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (or vm-message-history (error "No message history")) (let ((history vm-message-history) (folder (current-buffer)) (selected-message (car vm-message-pointer)) (buf (get-buffer-create (concat (buffer-name) " Message History"))) mp) ;; replace summary window if possible (let ((window (get-buffer-window vm-summary-buffer))) (if window (select-window window))) ;; or existing one (let ((window (get-buffer-window buf))) (if window (select-window window))) ;; now switch to new buffer and set it up (switch-to-buffer buf) (let ((buffer-read-only nil)) (erase-buffer)) (abbrev-mode 0) (auto-fill-mode 0) (vm-fsfemacs-nonmule-display-8bit-chars) (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (setq vm-mail-buffer folder mode-name "VM Message History" major-mode 'vm-message-history-mode mode-line-format vm-mode-line-format buffer-read-only t truncate-lines t) (use-local-map vm-message-history-browse-mode-map) ;; fill in the entries for each item (let ((buffer-read-only nil) (selected (point-min)) start) (while history (setq mp (car history) start (point)) (if (not (eq mp selected-message)) (insert vm-summary-no-=>) (setq selected (point)) (insert vm-summary-=>)) (vm-tokenized-summary-insert mp (vm-su-summary mp)) (set-text-properties start (point) (list 'vm-message-pointer history)) (setq history (cdr history))) ;; jump to selected message or last. (goto-char selected)))) (add-hook 'vm-select-message-hook 'vm-message-history-add) ;;; vm-message-history.el ends here vm-8.2.0b/lisp/vm-avirtual.el0000755000175000017500000013233411676442160016337 0ustar srivastasrivasta;;; vm-avirtual.el --- additional functions for virtual folder selectors ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 2000-2006 Robert Widhopf-Fenk ;; ;; Author: Robert Widhopf-Fenk ;; Status: Tested with XEmacs 21.4.19 & VM 7.19 ;; Keywords: VM, virtual folders ;; X-URL: http://www.robf.de/Hacking/elisp ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; ;; Virtual folders are one of the greatest features offered by VM, however ;; sometimes I do not want to visit a virtual folder in order to do something ;; on messages. E.g. I have a virtual folder selector for spam messages and I ;; want VM to mark those messages matching the selector for deletion when ;; retrieving new messages. This can be done with a trick described in ;; the VM-FAQ, however this created two new buffers polluting my buffer space. ;; So this package provides a function `vm-auto-delete-messages' for this ;; purpose without drawbacks. ;; ;; Then after I realized I was maintaining three different variables for ;; actually the same things. They were `vm-auto-folder-alist' for automatic ;; selection of folders when saving messages, `vm-virtual-folder-alist' for my ;; loved virtual folders and `vmpc-conditions' in order to solve the handling ;; of my different email-addresses. ;; ;; This was kind of annoying, since virtual folder selectors offer the ;; best way of specifying conditions, but they only work on messages ;; within folders and not on messages which are currently being ;; composed. So I decided to extend virtual folder selectors also to ;; message composing, although not all of the selectors are meaningful ;; for `mail-mode'. ;; ;; I wrote functions which can replace (*) the existing ones and others that ;; add new (+) functionality. Finally I came up with the following ones: ;; * vm-virtual-auto-archive-messages ;; * vm-virtual-save-message ;; * vmpc-check-virtual-selector ;; + vm-virtual-auto-delete-messages ;; + vm-virtual-auto-delete-message ;; + vm-virtual-omit-message ;; + vm-virtual-update-folders ;; + vm-virtual-apply-function ;; and the following variables ;; vm-virtual-check-case-fold-search ;; vm-virtual-auto-delete-message-selector ;; vm-virtual-auto-folder-alist ;; vm-virtual-message ;; and a couple of new selectors ;; mail-mode if in mail-mode evals its `argument' else `nil' ;; vm-mode if in vm-mode evals its `arg' else `nil' ;; eval evaluates its `arg' (write own complex selectors) ;; ;; So by using theses new features I can maintain just one selector for ;; e.g. my private email-address and get the right folder for saving messages, ;; visiting the corresponding virtual folders, auto archiving, setting the FCC ;; header and setting up `vmpc-conditions'. Do you know a mailer than can ;; beat this? ;; ;; My default selector for spam messages: ;; ;; ("spam" ("received") ;; (vm-mode ;; (and (new) (undeleted) ;; (or ;; ;; kill all those where all authors/recipients ;; ;; are unknown to my BBDB, i.e. messages from ;; ;; strangers who are not recognized by me. ;; ;; (c't 12/2001) ;; (not (in-bbdb)) ;; ;; authors that I do not know ;; (and (not (in-bbdb authors)) ;; (or ;; ;; with bad content ;; (spam-word) ;; ;; they hide ID codes by long subjects ;; (subject " ") ;; ;; HTML only messages ;; (header "^Content-Type: text/html") ;; ;; for 8bit encoding "chinese" spam ;; (header "[¡-ÿ][¡-ÿ][¡-ÿ][¡-ÿ]") ;; ;; for qp-encoding "chinese" spam ;; (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]") ;; )))))) ;; ;;; Feel free to send me any comments or bug reports. ;; ;;; Code: (provide 'vm-avirtual) (require 'vm-virtual) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-save) (require 'vm-reply) (require 'vm-sort) (require 'vm-thread) ) (declare-function vm-get-folder-buffer "vm" (folder)) ;; The following function is erroneously called for fsfemacs as well (declare-function key-or-menu-binding "vm-xemacs" (key &optional menu-flag)) (declare-function bbdb-get-addresses "ext:bbdb-com" (only-first-address uninteresting-senders get-header-content-function &rest get-header-content-function-args)) (declare-function bbdb-search-simple "ext:bbdb" (name net)) ; group already defined in vm-vars ;(defgroup vm nil ; "VM" ; :group 'mail) (defgroup vm-avirtual nil "VM additional virtual folder selectors and functions." :group 'vm-ext) ;;---------------------------------------------------------------------------- (eval-when-compile (require 'cl)) (eval-and-compile (require 'advice) (require 'regexp-opt) (require 'time-date) (let ((feature-list '(bbdb bbdb-autoloads bbdb-com))) (while feature-list (condition-case nil (require (car feature-list)) (error (if (load (format "%s\n" (car feature-list)) t) (message "Library %s loaded!" (car feature-list)) (message "Could not load feature %S. Related functions may not work correctly!" (car feature-list)) (beep 1)))) (setq feature-list (cdr feature-list))))) (defvar bbdb-get-addresses-headers) ; dummy declaration ;;---------------------------------------------------------------------------- (defvar vm-mail-virtual-selector-function-alist '(;; standard selectors (and . vm-mail-vs-and) (or . vm-mail-vs-or) (not . vm-mail-vs-not) (any . vm-mail-vs-any) (header . vm-mail-vs-header) (text . vm-mail-vs-text) (header-or-text . vm-mail-vs-header-or-text) (recipient . vm-mail-vs-recipient) (author . vm-mail-vs-author) (author-or-recipient . vm-mail-vs-author-or-recipient) (subject . vm-mail-vs-subject) (sortable-subject . vm-mail-vs-sortable-subject) (more-chars-than . vm-mail-vs-more-chars-than) (less-chars-than . vm-mail-vs-less-chars-than) (more-lines-than . vm-mail-vs-more-lines-than) (less-lines-than . vm-mail-vs-less-lines-than) (replied . vm-mail-vs-replied) (answered . vm-mail-vs-answered) (forwarded . vm-mail-vs-forwarded) (redistributed . vm-mail-vs-redistributed) (unreplied . vm-mail-vs-unreplied) (unanswered . vm-mail-vs-unanswered) (unforwarded . vm-mail-vs-unforwarded) (unredistributed . vm-mail-vs-unredistributed) ;; unknown selectors which return always nil (new . vm-mail-vs-unknown) (unread . vm-mail-vs-unknown) (read . vm-mail-vs-unknown) (unseen . vm-mail-vs-unknown) (recent . vm-mail-vs-unknown) (deleted . vm-mail-vs-unknown) (filed . vm-mail-vs-unknown) (written . vm-mail-vs-unknown) (edited . vm-mail-vs-unknown) (marked . vm-mail-vs-unknown) (undeleted . vm-mail-vs-unknown) (unfiled . vm-mail-vs-unknown) (unwritten . vm-mail-vs-unknown) (unedited . vm-mail-vs-unknown) (unmarked . vm-mail-vs-unknown) (expanded . vm-mail-vs-unknown) (collapsed . vm-mail-vs-unknown) (virtual-folder-member . vm-mail-vs-unknown) (label . vm-mail-vs-unknown) (sent-before . vm-mail-vs-unknown) (sent-after . vm-mail-vs-unknown) ;; new selectors (mail-mode . vm-mail-vs-mail-mode) (vm-mode . vm-vs-vm-mode) (eval . vm-mail-vs-eval) (older-than . vm-mail-vs-older-than) (newer-than . vm-mail-vs-newer-than) (in-bbdb . vm-mail-vs-in-bbdb) )) ;;----------------------------------------------------------------------------- (defun vm-avirtual-add-selectors (selectors) (let ((alist 'vm-virtual-selector-function-alist) (sup-alist 'vm-supported-interactive-virtual-selectors) sel) (while selectors (setq sel (car selectors)) (add-to-list alist (cons sel (intern (format "vm-vs-%s" sel)))) (add-to-list sup-alist (list (format "%s" sel))) (setq selectors (cdr selectors))))) (vm-avirtual-add-selectors '(mail-mode vm-mode eval selected in-bbdb folder-name )) ;;----------------------------------------------------------------------------- ;; we redefine the basic selectors for some extra features ... (defcustom vm-virtual-check-case-fold-search t "Wheater to use case-fold-search or not when applying virtual selectors. I was really missing this!" :type 'boolean :group 'vm-avirtual) (defcustom vm-virtual-check-diagnostics nil "When set to nil we will display messages on matching selectors." :type 'boolean :group 'vm-avirtual) (defvar vm-virtual-check-level 0) (defun vm-vs-or (m &rest selectors) (let ((case-fold-search vm-virtual-check-case-fold-search) (vm-virtual-check-level (+ 2 vm-virtual-check-level)) (result nil) selector arglist function) (while selectors (setq selector (car (car selectors)) function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (setq arglist (cdr (car selectors)) arglist (cdr (car selectors)) result (apply function m arglist) selectors (if result nil (cdr selectors))) (if vm-virtual-check-diagnostics (princ (format "%sor: %s (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) ""))))) result)) (defun vm-vs-and (m &rest selectors) (let ((vm-virtual-check-level (+ 2 vm-virtual-check-level)) (result t) selector arglist function) (while selectors (setq selector (car (car selectors)) function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (setq arglist (cdr (car selectors)) result (apply function m arglist) selectors (if (null result) nil (cdr selectors))) (if vm-virtual-check-diagnostics (princ (format "%sand: %s (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) ""))))) result)) (defun vm-vs-not (m arg) (let ((vm-virtual-check-level (+ 2 vm-virtual-check-level)) (selector (car arg)) (arglist (cdr arg)) result function) (setq function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (setq result (apply function m arglist)) (if vm-virtual-check-diagnostics (princ (format "%snot: %s for (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) "")))) (not result))) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-avirtual-check-for-missing-selectors (&optional arg) "Check if there are selectors missing for either vm-mode or mail-mode." (interactive "P") (let ((a (if arg vm-mail-virtual-selector-function-alist vm-virtual-selector-function-alist)) (b (mapcar (lambda (s) (car s)) (if arg vm-virtual-selector-function-alist vm-mail-virtual-selector-function-alist))) l) (while a (if (not (memq (caar a) b)) (setq l (concat (format "%s" (caar a)) ", " l))) (setq a (cdr a))) (if l (message "Selectors %s are missing" l) (message "No selectors are missing")))) ;;--------------------------------------------------------------------------- ;; new virtual folder selectors (defvar vm-virtual-message nil "Set to the VM message vector when doing a `vm-vs-eval'.") (defun vm-vs-folder-name (m regexp) (setq m (vm-real-message-of m)) (string-match regexp (buffer-name (marker-buffer (vm-start-of m))))) (defun vm-vs-eval (&rest selectors) (let ((vm-virtual-message (car selectors))) (eval (cadr selectors)))) (defun vm-vs-vm-mode (&rest selectors) (if (not (equal major-mode 'mail-mode)) (apply 'vm-vs-or selectors) nil)) (defun vm-vs-selected (m) (save-excursion (vm-select-folder-buffer) (eq m (car vm-message-pointer)))) (defun vm-vs-in-bbdb (m &optional address-class only-first) "check if one of the email addresses from the mail is known." (let (bbdb-user-mail-names) (let* ((bbdb-get-only-first-address-p only-first) (bbdb-user-mail-names nil) (bbdb-get-addresses-headers (if address-class (or (list (assoc address-class bbdb-get-addresses-headers)) (error "no such address class")) bbdb-get-addresses-headers)) (addresses (bbdb-get-addresses nil nil 'bbdb/vm-get-header-content (vm-real-message-of m))) (done nil) addr) (while (and (not done) addresses) (setq addr (caddar addresses) addresses (cdr addresses)) (let ((name (car addr)) (net (cadr addr))) (setq done (or (bbdb-search-simple nil net) (bbdb-search-simple name nil))))) done))) (defun vm-mail-vs-in-bbdb (&optional address-class only-first) "check if one of the email addresses from the mail is known." (let (bbdb-user-mail-names) (let* ((bbdb-get-only-first-address-p only-first) (bbdb-user-mail-names nil) (bbdb-get-addresses-headers (if address-class (or (list (assoc address-class bbdb-get-addresses-headers)) (error "no such address class")) bbdb-get-addresses-headers)) (addresses (bbdb-get-addresses nil nil 'vm-mail-mode-get-header-contents)) (done nil) addr) (while (and (not done) addresses) (setq addr (caddar addresses) addresses (cdr addresses)) (let ((name (car addr)) (net (cadr addr))) (setq done (or (bbdb-search-simple nil net) (bbdb-search-simple name nil))))) done))) ;;;###autoload (defun vm-add-spam-word (word) "Add a new word to the list of spam words." (interactive (list (if (region-active-p) (buffer-substring (point) (mark)) (read-string "Spam word: ")))) (save-excursion (when (not (member word vm-spam-words)) (if (get-file-buffer vm-spam-words-file) (set-buffer (get-file-buffer vm-spam-words-file)) (set-buffer (find-file-noselect vm-spam-words-file))) (goto-char (point-max)) ;; if the last character is no newline, then append one! (if (and (not (= (point) (point-min))) (save-excursion (backward-char 1) (not (looking-at "\n")))) (insert "\n")) (insert word) (save-buffer) (setq vm-spam-words (cons word vm-spam-words)) (setq vm-spam-words-regexp (regexp-opt vm-spam-words))))) ;;;###autoload (defun vm-spam-words-rebuild () "Discharge the internal cached data about spam words." (interactive) (setq vm-spam-words nil vm-spam-words-regexp nil) (if (get-file-buffer vm-spam-words-file) (kill-buffer (get-file-buffer vm-spam-words-file))) (vm-vs-spam-word nil) (vm-inform 5 "%d spam words are installed" (length vm-spam-words))) ;;--------------------------------------------------------------------------- ;; new mail virtual folder selectors (defun vm-mail-vs-eval (&rest selectors) (eval (cadr selectors))) (defun vm-mail-vs-mail-mode (&rest selectors) (if (equal major-mode 'mail-mode) (apply 'vm-mail-vs-or selectors) nil)) (defalias 'vm-vs-mail-mode 'vm-mail-vs-mail-mode) (defun vm-mail-vs-or (&rest selectors) (let ((result nil) selector arglist (case-fold-search vm-virtual-check-case-fold-search)) (while selectors (setq selector (car (car selectors)) arglist (cdr (car selectors)) result (apply (cdr (assq selector vm-mail-virtual-selector-function-alist)) arglist) selectors (if result nil (cdr selectors))) (if vm-virtual-check-diagnostics (princ (format "%sor: %s (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) ""))))) result)) (defun vm-mail-vs-and (&rest selectors) (let ((result t) selector arglist) (while selectors (setq selector (car (car selectors)) arglist (cdr (car selectors)) result (apply (cdr (assq selector vm-mail-virtual-selector-function-alist)) arglist) selectors (if (null result) nil (cdr selectors))) (if vm-virtual-check-diagnostics (princ (format "%sand: %s (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) ""))))) result)) (defun vm-mail-vs-not (arg) (let ((selector (car arg)) (arglist (cdr arg)) result) (setq result (apply (cdr (assq selector vm-mail-virtual-selector-function-alist)) arglist)) (if vm-virtual-check-diagnostics (princ (format "%snot: %s for (%S%s)\n" (make-string vm-virtual-check-level ? ) (if result t nil) selector (if arglist (format " %S" arglist) "")))) (not result))) ;; return just nil for those selectors not known for mail-mode (defun vm-mail-vs-unknown (&optional arg) nil) (defun vm-mail-vs-any () t) (defun vm-mail-vs-author (arg) (let ((val (vm-mail-mode-get-header-contents "Sender\\|From:"))) (and val (string-match arg val)))) (defun vm-mail-vs-recipient (arg) (let (val) (or (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?To:")) (string-match arg val)) (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?CC:")) (string-match arg val)) (and (setq val (vm-mail-mode-get-header-contents "\\(Resent-\\)?BCC:")) (string-match arg val))))) (defun vm-mail-vs-author-or-recipient (arg) (or (vm-mail-vs-author arg) (vm-mail-vs-recipient arg))) (defun vm-mail-vs-subject (arg) (let ((val (vm-mail-mode-get-header-contents "Subject:"))) (and val (string-match arg val)))) (defun vm-mail-vs-sortable-subject (arg) (let ((case-fold-search t) (subject (vm-mail-mode-get-header-contents "Subject:"))) (when subject (if (and vm-subject-ignored-prefix (string-match vm-subject-ignored-prefix subject) (zerop (match-beginning 0))) (setq subject (substring subject (match-end 0)))) (if (and vm-subject-ignored-suffix (string-match vm-subject-ignored-suffix subject) (= (match-end 0) (length subject))) (setq subject (substring subject 0 (match-beginning 0)))) (setq subject (vm-with-string-as-temp-buffer subject (function vm-collapse-whitespace))) (if (and vm-subject-significant-chars (natnump vm-subject-significant-chars) (< vm-subject-significant-chars (length subject))) (setq subject (substring subject 0 vm-subject-significant-chars))) (string-match arg subject)))) (defun vm-mail-vs-header (arg) (save-excursion (let ((start (point-min)) end) (goto-char start) (search-forward (concat "\n" mail-header-separator "\n")) (setq end (match-beginning 0)) (goto-char start) (re-search-forward arg end t)))) (defun vm-mail-vs-text (arg) (save-excursion (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n")) (re-search-forward arg (point-max) t))) (defun vm-mail-vs-header-or-text (arg) (save-excursion (goto-char (point-min)) (re-search-forward arg (point-max) t))) (defun vm-mail-vs-more-chars-than (arg) (> (- (point-max) (point-min) (length mail-header-separator) 2) arg)) (defun vm-mail-vs-less-chars-than (arg) (< (- (point-max) (point-min) (length mail-header-separator) 2) arg)) (defun vm-mail-vs-more-lines-than (arg) (> (- (count-lines (point-min) (point-max)) 1) arg)) (defun vm-mail-vs-less-lines-than (arg) (< (- (count-lines (point-min) (point-max)) 1) arg)) (defun vm-mail-vs-replied () vm-reply-list) (fset 'vm-mail-vs-answered 'vm-mail-vs-replied) (defun vm-mail-vs-forwarded () vm-forward-list) (defun vm-mail-vs-redistributed () (vm-mail-mode-get-header-contents "Resent-[^:]+:")) (defun vm-mail-vs-unreplied () (not (vm-mail-vs-forwarded ))) (fset 'vm-mail-vs-unanswered 'vm-mail-vs-unreplied) (defun vm-mail-vs-unforwarded () (not (vm-mail-vs-forwarded ))) (defun vm-mail-vs-unredistributed () (not (vm-mail-vs-redistributed ))) (defun vm-mail-vs-older-than (arg) (let* ((date (vm-mail-mode-get-header-contents "Date:")) (days (and date (days-between (current-time-string) date)))) (and days (> days arg)))) (defun vm-mail-vs-newer-than (arg) (let* ((date (vm-mail-mode-get-header-contents "Date:")) (days (and date (days-between (current-time-string) date)))) (and days (<= days arg)))) ;;---------------------------------------------------------------------------- (defun vm-virtual-folder-member-p (name folder-list) "Checks if the VM folder with NAME, currently loaded, is among the folders listed in FOLDER-LIST." (let (buffer) (catch 'found (while folder-list (setq buffer (vm-get-folder-buffer (car folder-list))) (when (and buffer (buffer-name buffer) (string-match name (buffer-name buffer))) (throw 'found t)) (setq folder-list (cdr folder-list))) nil))) ;;;###autoload (defun vm-virtual-get-selector (vfolder &optional valid-folder-list) "Return the selector of virtual folder VFOLDER for VALID-FOLDER-LIST." (interactive (list (vm-read-string "Virtual folder: " vm-virtual-folder-alist) (if (equal major-mode 'mail-mode) nil (save-excursion (vm-select-folder-buffer) (list (buffer-name)))))) (let ((clauses (cadr (assoc vfolder vm-virtual-folder-alist))) (selector nil) (folders valid-folder-list)) (when clauses (if (null folders) (setq selector (append (cdr clauses) selector)) (while folders (when (vm-virtual-folder-member-p (car folders) (car clauses)) (setq selector (append (cdr clauses) selector))) (setq folders (cdr folders))))) selector)) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-check-selector (selector &optional msg virtual) "Return t if SELECTOR matches the message MSG. If VIRTUAL is true we check the current message and not the real one." (if msg (if virtual (apply 'vm-vs-or msg selector) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of msg))) (apply 'vm-vs-or msg selector))) (if (eq major-mode 'mail-mode) (apply 'vm-mail-vs-or selector)))) ;;;###autoload (defun vm-virtual-check-selector-interactive (selector &optional diagnostics) "Return t if SELECTOR matches the current message. Called with an prefix argument we display more diagnostics about the selector evaluation. Information is displayed in the order of evaluation and indented according to the level of recursion. The displayed information is has the format: FATHER-SELECTOR: RESULT CHILD-SELECTOR" (interactive (list (vm-read-string "Virtual folder: " vm-virtual-folder-alist) current-prefix-arg)) (save-excursion (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-follow-summary-cursor) (let ((msg (car vm-message-pointer)) (virtual (eq major-mode 'vm-virtual-mode)) (vm-virtual-check-diagnostics (or vm-virtual-check-diagnostics diagnostics))) (with-output-to-temp-buffer "*VM virtual-folder-check*" (save-excursion (set-buffer "*VM virtual-folder-check*") (toggle-truncate-lines t)) (princ (format "Checking %S on <%s> from %s\n\n" selector (vm-su-subject msg) (vm-su-from msg))) (princ (format "\nThe virtual folder selector `%s' is %s\n" selector (if (vm-virtual-check-selector (vm-virtual-get-selector selector) msg virtual) "true" "false"))))))) ;;---------------------------------------------------------------------------- (defvar vmpc-current-state nil) ;;;###autoload (defun vmpc-virtual-check-selector (selector &optional folder-list) "Checks SELECTOR based on the state of vmpc on the original or current." (setq selector (vm-virtual-get-selector selector folder-list)) (if (null selector) (error "no virtual folder %s!" selector)) (cond ((or (eq vmpc-current-state 'reply) (eq vmpc-current-state 'forward) (eq vmpc-current-state 'resend)) (vm-virtual-check-selector selector (car vm-message-pointer))) ((eq vmpc-current-state 'automorph) (vm-virtual-check-selector selector)))) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-apply-function (count &optional selector function) "Apply a FUNCTION to the next COUNT messages matching SELECTOR." (interactive "p") (when (vm-interactive-p) (vm-follow-summary-cursor) (setq selector (vm-virtual-get-selector (vm-read-string "Virtual folder: " vm-virtual-folder-alist))) (if vm-xemacs-p (setq function (key-or-menu-binding (read-key-sequence "VM command: "))) (setq function (key-binding (read-key-sequence "VM command: "))))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((mlist (vm-select-operable-messages (or count 1) (vm-interactive-p)"Apply to")) (count 0)) (while mlist (if (vm-virtual-check-selector selector (car mlist)) (progn (funcall function (car mlist)) (vm-increment count))) (setq mlist (cdr mlist))) count)) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-update-folders (&optional count message-list) "Updates all virtual folders. E.g. when creating a folder of all marked messages one can call this function in order to add newly marked messages to the virtual folder without recreating it." (interactive "p") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (let ((new-messages (or message-list (vm-select-operable-messages count (vm-interactive-p) "Update"))) b-list) (setq new-messages (copy-sequence new-messages)) (if (and new-messages vm-virtual-buffers) (save-excursion (setq b-list vm-virtual-buffers) (while b-list ;; buffer might be dead (if (buffer-name (car b-list)) (let (tail-cons) (set-buffer (car b-list)) (setq tail-cons (vm-last vm-message-list)) (vm-build-virtual-message-list new-messages) (if (or (null tail-cons) (cdr tail-cons)) (progn (setq vm-ml-sort-keys nil) (if vm-thread-obarray (vm-build-threads (cdr tail-cons))) (vm-set-summary-redo-start-point (or (cdr tail-cons) vm-message-list)) (vm-set-numbering-redo-start-point (or (cdr tail-cons) vm-message-list)) (if (null vm-message-pointer) (progn (setq vm-message-pointer vm-message-list vm-need-summary-pointer-update t) (if vm-message-pointer (vm-present-current-message)))) (setq vm-messages-needing-summary-update new-messages vm-need-summary-pointer-update t) (vm-update-summary-and-mode-line) (if vm-summary-show-threads (vm-sort-messages (or vm-ml-sort-keys "activity"))))))) (setq b-list (cdr b-list))))) new-messages)) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-omit-message (&optional count message-list) "Omits a meassage from a virtual folder. IMHO allowing it for real folders makes no sense. One rather should create a virtual folder of all messages." (interactive "p") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (eq major-mode 'vm-virtual-mode)) (error "This is no virtual folder.")) (let ((old-messages (or message-list (vm-select-operable-messages count (vm-interactive-p) "Omit"))) prev curr (mp vm-message-list)) (while mp (if (not (member (car mp) old-messages)) nil (setq prev (vm-reverse-link-of (car mp)) curr (or (cdr prev) vm-message-list)) (vm-set-numbering-redo-start-point (or prev t)) (vm-set-summary-redo-start-point (or prev t)) (if (eq vm-message-pointer curr) (setq vm-system-state nil vm-message-pointer (or prev (cdr curr)))) (if (eq vm-last-message-pointer curr) (setq vm-last-message-pointer nil)) (if (null prev) (progn (setq vm-message-list (cdr vm-message-list)) (and (cdr curr) (vm-set-reverse-link-of (car (cdr curr)) nil))) (setcdr prev (cdr curr)) (and (cdr curr) (vm-set-reverse-link-of (car (cdr curr)) prev)))) (setq mp (cdr mp))) (vm-update-summary-and-mode-line) (if vm-summary-show-threads (vm-sort-messages (or vm-ml-sort-keys "activity"))) old-messages)) ;;---------------------------------------------------------------------------- (defcustom vm-virtual-auto-delete-message-selector "spam" "*Name of virtual folder selector used for automatically deleting a message. Actually they are only marked for deletion." :group 'vm-avirtual :type 'string) (defcustom vm-virtual-auto-delete-message-folder nil "*When set to a folder name we save affected messages there." :group 'vm-avirtual :type '(choice (file :tag "VM folder" "spam") (const :tag "Disabled" nil))) (defcustom vm-virtual-auto-delete-message-expunge nil "*When true we expunge the affected right after marking and saving them." :group 'vm-avirtual :type 'boolean) ;;;###autoload (defun vm-virtual-auto-delete-message (&optional count selector) "*Mark messages matching a virtual folder selector for deletion. The virtual folder selector can be configured by the variable `vm-virtual-auto-delete-message-selector'. This function does not visit the virtual folder, but checks only the current message, therefore it is much faster and not so disturbing like the method described in the VM-FAQ. In order to automatically mark spam for deletion use the function `vm-virtual-auto-delete-messages'. See its documentation on how to hook it into VM!" (interactive "p") (setq selector (or selector (vm-virtual-get-selector vm-virtual-auto-delete-message-selector))) (let (spammlist) (setq count (vm-virtual-apply-function count selector (lambda (msg) (setq spammlist (cons msg spammlist)) (vm-set-labels msg (list vm-virtual-auto-delete-message-selector)) (vm-set-deleted-flag msg t) (vm-mark-for-summary-update msg t)))) (when spammlist (setq spammlist (reverse spammlist)) ;; save them (if vm-virtual-auto-delete-message-folder (let ((vm-arrived-messages-hook nil) (vm-arrived-message-hook nil) (mlist spammlist)) (while mlist (let ((vm-message-pointer mlist)) (vm-save-message vm-virtual-auto-delete-message-folder)) (setq mlist (cdr mlist))))) ;; expunge them (if vm-virtual-auto-delete-message-expunge (vm-expunge-folder :quiet t :just-these-messages spammlist))) (vm-display nil nil '(vm-delete-message vm-delete-message-backward) (list this-command)) (vm-update-summary-and-mode-line) (message "%s message%s %s" (if (> count 0) count "No") (if (= 1 count) "" "s") (concat (if vm-virtual-auto-delete-message-folder (format "saved to %s and " vm-virtual-auto-delete-message-folder) "") (if vm-virtual-auto-delete-message-expunge "expunged right away" "marked for deletion"))))) ;;;###autoload (defun vm-virtual-auto-delete-messages () "*Mark all messages from the current upto the last for (spam-)deletion. Add this to `vm-arrived-messages-hook'. See the function `vm-virtual-auto-delete-message' for details. (add-hook 'vm-arrived-messages-hook 'vm-virtual-auto-delete-messages) " (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-virtual-auto-delete-message (length vm-message-pointer))) ;;---------------------------------------------------------------------------- ;;;###autoload (defcustom vm-virtual-auto-folder-alist nil "*Non-nil value should be an alist that VM will use to choose a default folder name when messages are saved. The alist should be of the form ((VIRTUAL-FOLDER-NAME . FOLDER-NAME) ...) where VIRTUAL-FOLDER-NAME is a string, and FOLDER-NAME is a string or an s-expression that evaluates to a string. This allows you to extend `vm-virtual-auto-select-folder' to generate a folder name. Your function may use `folder' to get the currently choosen folder name and `mp' (a vm-message-pointer) to access the message. Example: (setq vm-virtual-auto-folder-alist '((\"spam\" (concat folder \"-\" (format-time-string \"%y%m\" (current-time)))))) This will return \"spam-0008\" as a folder name for messages matching the virtual folder selector of the virtual folder \"spam\" during August in year 2000." :type 'sexp :group 'vm-avirtual) ;;;###autoload (defun vm-virtual-auto-select-folder (&optional m avfolder-alist valid-folder-list not-to-history) "Return the first matching virtual folder. This is a more powerful replacement of `vm-auto-select-folder'. It is used by `vm-virtual-save-message' for finding the folder to save the current message. It may also be used for finding the right FCC for outgoing messages." (when (not m) (setq m (car vm-message-pointer)) (setq avfolder-alist vm-virtual-folder-alist) (setq valid-folder-list (cond ((eq major-mode 'mail-mode) nil) ((eq major-mode 'vm-mode) (save-excursion (vm-select-folder-buffer) (list (buffer-name)))) ((eq major-mode 'vm-virtual-mode) (list (buffer-name (vm-buffer-of (vm-real-message-of m)))))))) (let ((vfolders avfolder-alist) selector folder-list) (when t;(and m (aref m 0) (aref (aref m 0) 0) ; (marker-buffer (aref (aref m 0) 0))) (while vfolders (setq selector (vm-virtual-get-selector (caar vfolders) valid-folder-list)) (when (and selector (vm-virtual-check-selector selector m)) (setq folder-list (append (list (caar vfolders)) folder-list)) (if not-to-history (setq vfolders nil))) (setq vfolders (cdr vfolders))) (setq folder-list (reverse folder-list)) (setq folder-list (mapcar (lambda (f) (let ((rf (assoc f vm-virtual-auto-folder-alist))) (if rf (eval (cadr rf)) f))) folder-list)) (when (and (not not-to-history) folder-list) (let ((fl (cdr folder-list)) f) (while fl (setq f (vm-abbreviate-file-name (expand-file-name (car fl) vm-folder-directory)) vm-folder-history (delete f vm-folder-history) vm-folder-history (nconc (list f) vm-folder-history) fl (cdr fl))))) (car folder-list)))) ;;----------------------------------------------------------------------------- ;;;###autoload (defvar vm-sort-compare-auto-folder-cache nil) (add-to-list 'vm-supported-sort-keys "auto-folder") (defun vm-sort-compare-auto-folder (m1 m2) (let* ((folder-list (list (buffer-name))) s1 s2) (if (setq s1 (assoc m1 vm-sort-compare-auto-folder-cache)) (setq s1 (cdr s1)) (setq s1 (vm-virtual-auto-select-folder m1 vm-virtual-folder-alist folder-list)) (add-to-list 'vm-sort-compare-auto-folder-cache (cons m1 s1))) (if (setq s2 (assoc m2 vm-sort-compare-auto-folder-cache)) (setq s2 (cdr s2)) (setq s2 (vm-virtual-auto-select-folder m2 vm-virtual-folder-alist folder-list)) (add-to-list 'vm-sort-compare-auto-folder-cache (cons m2 s2))) (cond ((or (and (null s1) s2) (and s1 s2 (string-lessp s1 s2))) t) ((or (and (null s1) (null s2)) (and s1 s2 (string-equal s1 s2))) '=) (t nil)))) ;;;###autoload (defun vm-sort-insert-auto-folder-names () (interactive) (if (vm-interactive-p) (vm-sort-messages "auto-folder")) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) ;; remove old descriptions (save-excursion (set-buffer vm-summary-buffer) (goto-char (point-min)) (let ((buffer-read-only nil) (s (point-min)) (p (point-min))) (while (setq p (next-single-property-change p 'vm-auto-folder)) (if (get-text-property (1+ p) 'vm-auto-folder) (setq s p) (delete-region s p)) (setq p (1+ p))))) ;; add new descriptions (let ((ml vm-message-list) (oldf "") m f) (while ml (setq m (car ml) f (cdr (assoc m vm-sort-compare-auto-folder-cache))) (when (not (equal oldf f)) (setq m (vm-su-start-of m)) (save-excursion (set-buffer (marker-buffer m)) (let ((buffer-read-only nil)) (goto-char m) (insert (format "%s\n" (or f "no default folder"))) (put-text-property m (point) 'vm-auto-folder t) (put-text-property m (point) 'face 'blue) ;; fix messages summary mark (set-marker m (point)))) (setq oldf f)) (setq ml (cdr ml)))))) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-save-message (&optional folder count) "Save the current message to a mail folder. Like `vm-save-message' but the default folder is guessed by `vm-virtual-auto-select-folder'." (interactive (list ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (vm-follow-summary-cursor) (let ((default (save-current-buffer (vm-select-folder-buffer) (or (vm-virtual-auto-select-folder) vm-last-save-folder))) (dir (or vm-folder-directory default-directory))) (cond ((and default (let ((default-directory dir)) (file-directory-p default))) (vm-read-file-name "Save in folder: " dir nil nil default 'vm-folder-history)) (default (vm-read-file-name (format "Save in folder: (default %s) " default) dir default nil nil 'vm-folder-history)) (t (vm-read-file-name "Save in folder: " dir nil))))) (prefix-numeric-value current-prefix-arg))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-save-message folder count)) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-auto-archive-messages (&optional prompt) "With a prefix ARG ask user before saving." (interactive "P") (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((auto-folder) (folder-list (list (buffer-name))) (archived 0)) (unwind-protect ;; Need separate (let ...) so vm-message-pointer can ;; revert back in time for ;; (vm-update-summary-and-mode-line). ;; vm-last-save-folder is tucked away here since archives ;; shouldn't affect its value. (let ((vm-message-pointer (if (eq last-command 'vm-next-command-uses-marks) (vm-select-operable-messages 0 (vm-interactive-p) "Archive"))) (done nil) stop-point (vm-last-save-folder vm-last-save-folder) (vm-move-after-deleting nil)) ;; Double check if the user really wants to archive (unless (or prompt vm-message-pointer (y-or-n-p "Auto archive the entire folder? ")) (error "Aborted")) (setq vm-message-pointer (or vm-message-pointer vm-message-list)) (vm-inform 5 "Archiving...") ;; mark the place where we should stop. otherwise if any ;; messages in this folder are archived to this folder ;; we would file messages into this folder forever. (setq stop-point (vm-last vm-message-pointer)) (while (not done) (and (not (vm-filed-flag (car vm-message-pointer))) ;; don't archive deleted messages (not (vm-deleted-flag (car vm-message-pointer))) (setq auto-folder (vm-virtual-auto-select-folder (car vm-message-pointer) vm-virtual-folder-alist folder-list)) ;; Don't let user archive into the same folder ;; that they are visiting. (not (eq (vm-get-file-buffer auto-folder) (current-buffer))) (or (null prompt) (y-or-n-p (format "Save message %s in folder %s? " (vm-number-of (car vm-message-pointer)) auto-folder))) (let ((vm-delete-after-saving vm-delete-after-archiving)) (vm-save-message auto-folder) (vm-increment archived) (vm-inform 6 "%d archived, still working..." archived))) (setq done (eq vm-message-pointer stop-point) vm-message-pointer (cdr vm-message-pointer)))) ;; fix mode line (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line)) (if (zerop archived) (vm-inform 5 "No messages were archived") (vm-inform 5 "%d message%s archived" archived (if (= 1 archived) "" "s"))))) ;;---------------------------------------------------------------------------- ;;;###autoload (defun vm-virtual-make-folder-persistent () "Save all messages of current virtual folder in the real folder with the same name." (interactive) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (eq major-mode 'vm-virtual-mode) (let ((file (substring (buffer-name) 1 -1))) (vm-goto-message 0) (vm-save-message file (length vm-message-list)) (vm-inform 5 "Saved virtual folder in file \"%s\"" file)) (error "This is not a virtual folder")))) ;;---------------------------------------------------------------------------- ;;; vm-avirtual.el ends here vm-8.2.0b/lisp/vm.el0000755000175000017500000015456411676442160014523 0ustar srivastasrivasta;;; vm.el --- Entry points for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1994-1998, 2003 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; History: ;; ;; This file was vm-startup.el! ;;; Code: (provide 'vm) (require 'vm-version) (defvar enable-multibyte-characters) ;; For function declarations (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-toolbar) (require 'vm-mouse) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-crypto) (require 'vm-mime) (require 'vm-virtual) (require 'vm-pop) (require 'vm-imap) (require 'vm-sort) (require 'vm-reply) ) ;; vm-xemacs.el is a non-existent file to fool the Emacs 23 compiler (declare-function vm-xemacs-set-face-foreground "vm-xemacs.el" (face color &optional locale tag-set how-to-add)) (declare-function vm-xemacs-set-face-background "vm-xemacs.el" (face color &optional locale tag-set how-to-add)) (declare-function get-coding-system "vm-xemacs.el" (name)) (declare-function find-face "vm-xemacs.el" (face-or-name)) (declare-function vm-rfaddons-infect-vm "vm-rfaddons.el" (&optional sit-for option-list exclude-option-list)) (declare-function vm-summary-faces-mode "vm-summary-faces.el" (&optional arg)) ;; Ensure that vm-autoloads is loaded in case the user is using VM 7.x ;; autoloads (eval-when (load) (if (not (featurep 'xemacs)) (require 'vm-autoloads))) ;;;###autoload (defun* vm (&optional folder &key (read-only nil) (access-method nil) (reload nil) (revisit nil)) "Read mail under Emacs. Optional first arg FOLDER specifies the folder to visit. It can be the path name of a local folder or the maildrop specification of a POP or IMAP folder. It defaults to the value of `vm-primary-inbox'. The folder is visited in a VM buffer is put into VM mode, a major mode for reading mail. (See `vm-mode'.) Prefix arg or optional second arg READ-ONLY non-nil indicates that the folder should be considered read only. No attribute changes, message additions or deletions will be allowed in the visited folder. Visiting a folder normally causes any contents of its spool files to be moved and appended to the folder buffer. You can disable this automatic fetching of mail by setting `vm-auto-get-new-mail' to nil. All the messages can be read by repeatedly pressing SPC. Use `n'ext and `p'revious to move about in the folder. Messages are marked for deletion with `d', and saved to another folder with `s'. Quitting VM with `q' saves the buffered folder to disk, but does not expunge deleted messages. Use `###' to expunge deleted messages." ;; Additional documentation for internal calls to vm: ;; *** Note that this function causes the folder buffer to become ;; *** the current-buffer. ;; Internally, this function may also be called with a buffer as the ;; FOLDER argument. In that case, the function sets up the buffer ;; as a folder buffer and turns on vm-mode. ;; ACCESS-METHOD, if non-nil, indicates that the FOLDER is the ;; maildrop spec of a remote server folder. Possible values for the ;; parameter are 'pop and 'imap. Or, if FOLDER is a buffer instead ;; of a name, it will be set up as a folder buffer using the ;; specified ACCESS-METHOD. ;; RELOAD, if non-nil, means that the folder should be reloaded into ;; an existing buffer. All initialisations must be performed but ;; some variables need to be preserved, e.g., vm-folder-access-data. ;; REVISIT, if non-nil, means that, if the folder has already been ;; visited, then it should be just selected. No further processing ;; should be done. ;; The functions find-name-for-spec and find-spec-for-name translate ;; between folder names and maildrop specs for the server folders. (interactive (list nil :read-only current-prefix-arg)) (vm-session-initialization) ;; recursive call to vm in order to allow defadvice on its first call (unless (boundp 'vm-session-beginning) (vm folder :read-only read-only :access-method access-method :reload reload :revisit revisit)) ;; set inhibit-local-variables non-nil to protect ;; against letter bombs. ;; set enable-local-variables to nil for newer Emacses (catch 'done ;; deduce the access method if none specified (if (null access-method) (let ((f (or folder vm-primary-inbox))) (cond ((bufferp f) ; may be unnecessary. USR, 2010-01 (setq access-method vm-folder-access-method)) ((and (stringp f) (vm-imap-folder-spec-p f)) (setq access-method 'imap folder f)) ((and (stringp f) (vm-pop-folder-spec-p f)) (setq access-method 'pop folder f))))) (let ((full-startup (and (not reload) (not (bufferp folder)))) ;; if we have been asked to visit a folder that is already ;; visited, then we don't do a full-startup unless we are ;; reloading. but what exactly do we do? - USR, 2011-04-24 (did-read-index-file nil) folder-buffer first-time totals-blurb folder-name account-name remote-spec preserve-auto-save-file) (cond ((and full-startup (eq access-method 'pop)) ;; (setq vm-last-visit-pop-folder folder) (setq remote-spec folder) (setq folder-name (or (vm-pop-find-name-for-spec folder) "POP")) (setq folder (vm-pop-find-cache-file-for-spec remote-spec))) ((and full-startup (eq access-method 'imap)) ;; (setq vm-last-visit-imap-folder folder) (setq remote-spec folder) (setq folder-name (or (nth 3 (vm-imap-parse-spec-to-list remote-spec)) folder)) (if (and vm-imap-refer-to-inbox-by-account-name (equal (downcase folder-name) "inbox") (setq account-name (vm-imap-account-name-for-spec remote-spec))) (setq folder-name account-name)) (setq folder (vm-imap-make-filename-for-spec remote-spec)))) (setq folder-buffer (if (bufferp folder) folder (vm-read-folder folder remote-spec folder-name))) (set-buffer folder-buffer) ;; Thunderbird folders (let ((msf (concat (buffer-file-name) ".msf"))) ;; notice the message summary file of Thunderbird (setq vm-folder-read-thunderbird-status (and (file-exists-p msf) vm-sync-thunderbird-status))) (if (and vm-fsfemacs-mule-p enable-multibyte-characters) (set-buffer-multibyte nil)) ; is this safe? ;; for MULE ;; ;; If the file coding system is not a no-conversion variant, ;; make it so by encoding all the text, then setting the ;; file coding system and decoding it. This situation is ;; only possible if a file is visited and then vm-mode is ;; run on it afterwards. ;; ;; There are separate code blocks for FSF Emacs and XEmacs ;; because the coding systems have different names. (defvar buffer-file-coding-system) (if (and (or vm-xemacs-mule-p vm-xemacs-file-coding-p) (not (eq (get-coding-system buffer-file-coding-system) (get-coding-system 'no-conversion-unix))) (not (eq (get-coding-system buffer-file-coding-system) (get-coding-system 'no-conversion-dos))) (not (eq (get-coding-system buffer-file-coding-system) (get-coding-system 'no-conversion-mac))) (not (eq (get-coding-system buffer-file-coding-system) (get-coding-system 'binary)))) (let ((buffer-read-only nil) (omodified (buffer-modified-p))) (unwind-protect (progn (encode-coding-region (point-min) (point-max) buffer-file-coding-system) (set-buffer-file-coding-system 'no-conversion nil) (decode-coding-region (point-min) (point-max) buffer-file-coding-system)) (set-buffer-modified-p omodified)))) (if (and vm-fsfemacs-mule-p (null buffer-file-coding-system)) (set-buffer-file-coding-system 'raw-text nil)) (if (and vm-fsfemacs-mule-p (not (eq (coding-system-base buffer-file-coding-system) (coding-system-base 'raw-text-unix))) (not (eq (coding-system-base buffer-file-coding-system) (coding-system-base 'raw-text-mac))) (not (eq (coding-system-base buffer-file-coding-system) (coding-system-base 'raw-text-dos))) (not (eq (coding-system-base buffer-file-coding-system) (coding-system-base 'no-conversion)))) (let ((buffer-read-only nil) (omodified (buffer-modified-p))) (unwind-protect (progn (encode-coding-region (point-min) (point-max) buffer-file-coding-system) (set-buffer-file-coding-system 'raw-text nil) (decode-coding-region (point-min) (point-max) buffer-file-coding-system)) (set-buffer-modified-p omodified)))) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) ;; If the buffer's not modified then we know that there can be no ;; messages in the folder that are not on disk. (unless (buffer-modified-p) (setq vm-messages-not-on-disk 0)) (setq first-time (not (eq major-mode 'vm-mode)) preserve-auto-save-file (and buffer-file-name (not (buffer-modified-p)) (file-newer-than-file-p (make-auto-save-file-name) buffer-file-name))) (setq vm-folder-read-only (or preserve-auto-save-file read-only (default-value 'vm-folder-read-only) (and first-time buffer-read-only))) ;; If this is not a VM mode buffer then some initialization ;; needs to be done (if first-time (progn (buffer-disable-undo (current-buffer)) (abbrev-mode 0) (auto-fill-mode 0) ;; If an 8-bit message arrives undeclared the 8-bit ;; characters in it should be displayed using the ;; user's default face charset, rather than as octal ;; escapes. (vm-fsfemacs-nonmule-display-8bit-chars) (vm-mode-internal access-method reload) (if full-startup (cond ((eq access-method 'pop) (vm-set-folder-pop-maildrop-spec remote-spec)) ((eq access-method 'imap) (vm-set-folder-imap-maildrop-spec remote-spec) (vm-register-folder-garbage 'vm-kill-folder-imap-session nil) ))) ;; If the buffer is modified we don't know if the ;; folder format has been changed to be different ;; from index file, so don't read the index file in ;; that case. (if (not (buffer-modified-p)) (setq did-read-index-file (vm-read-index-file-maybe))))) ;; builds message list, reads attributes if they weren't ;; read from an index file. ;; but that is not what the code is doing! - USR, 2011-04-24 (unless revisit (vm-assimilate-new-messages :read-attributes t :gobble-order (not did-read-index-file) :run-hooks nil)) (if (and first-time (not did-read-index-file)) (progn (vm-gobble-visible-header-variables) (vm-gobble-bookmark) (vm-gobble-pop-retrieved) (vm-gobble-imap-retrieved) (vm-gobble-summary) (vm-gobble-labels))) ;; Recall the UID VALIDITY value stored in the cache folder (cond ((eq access-method 'imap) (if vm-imap-retrieved-messages (vm-set-folder-imap-uid-validity (vm-imap-recorded-uid-validity)))) ((eq access-method 'pop) ;; FIXME yet to be filled in )) (if first-time (vm-start-itimers-if-needed)) ;; make a new frame if the user wants one. reuse an ;; existing frame that is showing this folder. (if (and full-startup ;; this so that "emacs -f vm" doesn't create a frame. this-command) (apply 'vm-goto-new-folder-frame-maybe (if folder '(folder) '(primary-folder folder)))) ;; raise frame if requested and apply startup window ;; configuration. (if full-startup (let ((buffer-to-display (or vm-summary-buffer vm-presentation-buffer (current-buffer)))) (vm-display buffer-to-display buffer-to-display (list this-command) (list (or this-command 'vm) 'startup)) (if vm-raise-frame-at-startup (vm-raise-frame)))) ;; if the folder is being revisited, nothing more to be done (if (and revisit (not first-time)) (throw 'done t)) ;; say this NOW, before the non-previewers read a message, ;; alter the new message count and confuse themselves. (when full-startup ;; save blurb so we can repeat it later as necessary. (setq totals-blurb (vm-emit-totals-blurb)) (if buffer-file-name (vm-store-folder-totals buffer-file-name (cdr vm-totals)))) (vm-thoughtfully-select-message) (vm-update-summary-and-mode-line) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (vm-toolbar-install-or-uninstall-toolbar) (when (and vm-use-menus (vm-menu-support-possible-p)) (vm-menu-install-visited-folders-menu)) (when full-startup (if (and (vm-should-generate-summary) ;; don't generate a summary if recover-file is ;; likely to happen, since recover-file does ;; not work in a summary buffer. (not preserve-auto-save-file)) (vm-summarize t nil)) ;; raise the summary frame if the user wants frames ;; raised and if there is a summary frame. (if (and vm-summary-buffer vm-mutable-frame-configuration vm-frame-per-summary vm-raise-frame-at-startup) (vm-raise-frame)) ;; if vm-mutable-window-configuration is nil, the startup ;; configuration can't be applied, so do ;; something to get a VM buffer on the screen (if vm-mutable-window-configuration (vm-display nil nil (list this-command) (list (or this-command 'vm) 'startup)) (save-excursion (switch-to-buffer (or vm-summary-buffer vm-presentation-buffer (current-buffer)))))) (if vm-message-list ;; don't decode MIME if recover-file is ;; likely to happen, since recover-file does ;; not work in a presentation buffer. (let ((vm-auto-decode-mime-messages (and vm-auto-decode-mime-messages (not preserve-auto-save-file)))) (vm-present-current-message))) (run-hooks 'vm-visit-folder-hook) ;; Warn user about auto save file, if appropriate. (if preserve-auto-save-file (vm-inform 0 (substitute-command-keys (concat "Auto save file is newer; consider \\[vm-recover-folder]. " "FOLDER IS READ ONLY.")))) ;; if we're not doing a full startup or if doing more would ;; trash the auto save file that we need to preserve, ;; stop here. (if (or (not full-startup) preserve-auto-save-file) (throw 'done t)) (if (vm-interactive-p) (vm-inform 5 totals-blurb)) (if (and vm-auto-get-new-mail (not vm-block-new-mail) (not vm-folder-read-only)) (progn (vm-inform 6 "Checking for new mail for %s..." (or buffer-file-name (buffer-name))) (if (vm-get-spooled-mail nil) ; automatic is non-interactive! (progn (setq totals-blurb (vm-emit-totals-blurb)) (if (vm-thoughtfully-select-message) (vm-present-current-message) (vm-update-summary-and-mode-line)))) (vm-inform 5 totals-blurb))) ;; Display copyright and copying info. (when (and (vm-interactive-p) (not vm-startup-message-displayed)) (vm-display-startup-message) (if (not (input-pending-p)) (vm-inform 5 totals-blurb)))))) ;;;###autoload (defun vm-other-frame (&optional folder read-only) "Like vm, but run in a newly created frame." (interactive (list nil current-prefix-arg)) (vm-session-initialization) (if (vm-multiple-frames-possible-p) (if folder (vm-goto-new-frame 'folder) (vm-goto-new-frame 'primary-folder 'folder))) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm folder :read-only read-only)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-other-window (&optional folder read-only) "Like vm, but run in a different window." (interactive (list nil current-prefix-arg)) (vm-session-initialization) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm folder :read-only read-only))) (put 'vm-mode 'mode-class 'special) ;;;###autoload (defun vm-mode (&optional read-only) "Major mode for reading mail. This is VM. Use M-x vm-submit-bug-report to submit a bug report. Commands: \\{vm-mode-map} Customize VM by setting variables and store them in the `vm-init-file'." (interactive "P") (vm (current-buffer) :read-only read-only) (vm-display nil nil '(vm-mode) '(vm-mode))) ;;;###autoload (defun vm-visit-folder (folder &optional read-only revisit) "Visit a mail file. VM will parse and present its messages to you in the usual way. First arg FOLDER specifies the mail file to visit. When this command is called interactively the file name is read from the minibuffer. Prefix arg or optional second arg READ-ONLY non-nil indicates that the folder should be considered read only. No attribute changes, messages additions or deletions will be allowed in the visited folder. The optional third arg REVISIT (not available interactively) says that, if the folder is already visited, then it should be merely selected without doing further processing (such as moving the message-pointer or getting new mail)." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (let ((default-directory (if vm-folder-directory (expand-file-name vm-folder-directory) default-directory)) (default (or vm-last-visit-folder vm-last-save-folder)) (this-command this-command) (last-command last-command)) (list (vm-read-file-name (format "Visit%s folder:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) default-directory default nil nil 'vm-folder-history) current-prefix-arg)))) (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (setq vm-last-visit-folder folder) (let ((access-method nil) foo) (cond ((and (vm-pop-folder-spec-p folder) (setq foo (vm-pop-find-name-for-spec folder))) (setq folder foo access-method 'pop vm-last-visit-pop-folder folder)) ((and (vm-imap-folder-spec-p folder) ;;(setq foo (vm-imap-find-name-for-spec folder)) ) (setq ;; folder foo access-method 'imap vm-last-visit-imap-folder folder)) (t (let ((default-directory (or vm-folder-directory default-directory))) (setq folder (expand-file-name folder) vm-last-visit-folder folder)))) (vm folder :read-only read-only :access-method access-method :revisit revisit))) ;;;###autoload (defun vm-visit-folder-other-frame (folder &optional read-only) "Like vm-visit-folder, but run in a newly created frame." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (let ((default-directory (if vm-folder-directory (expand-file-name vm-folder-directory) default-directory)) (default (or vm-last-visit-folder vm-last-save-folder)) (this-command this-command) (last-command last-command)) (list (vm-read-file-name (format "Visit%s folder in other frame:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) default-directory default nil nil 'vm-folder-history) current-prefix-arg)))) (vm-session-initialization) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'folder)) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-folder folder read-only)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-visit-folder-other-window (folder &optional read-only) "Like vm-visit-folder, but run in a different window." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (let ((default-directory (if vm-folder-directory (expand-file-name vm-folder-directory) default-directory)) (default (or vm-last-visit-folder vm-last-save-folder)) (this-command this-command) (last-command last-command)) (list (vm-read-file-name (format "Visit%s folder in other window:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) default-directory default nil nil 'vm-folder-history) current-prefix-arg)))) (vm-session-initialization) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-folder folder read-only))) ;;;###autoload (defun vm-visit-thunderbird-folder (folder &optional read-only) "Visit a mail file maintained by Thunderbird. VM will parse and present its messages to you in the usual way. First arg FOLDER specifies the mail file to visit. When this command is called interactively the file name is read from the minibuffer. Prefix arg or optional second arg READ-ONLY non-nil indicates that the folder should be considered read only. No attribute changes, messages additions or deletions will be allowed in the visited folder. This function differs from `vm-visit-folder' in that it remembers that the folder is a foreign folder maintained by Thunderbird. Saving of messages is carried out preferentially to other Thunderbird folders." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (let ((default-directory (if vm-thunderbird-folder-directory (expand-file-name vm-thunderbird-folder-directory) default-directory)) (default (or vm-last-visit-folder vm-last-save-folder)) (this-command this-command) (last-command last-command)) (list (vm-read-file-name (format "Visit%s folder:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) default-directory default nil nil 'vm-folder-history) current-prefix-arg)))) (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (setq vm-last-visit-folder folder) (let ((default-directory (or vm-thunderbird-folder-directory default-directory))) (setq folder (expand-file-name folder) vm-last-visit-folder folder)) (vm folder :read-only read-only) (set (make-local-variable 'vm-foreign-folder-directory) vm-thunderbird-folder-directory) ) ;;;###autoload (defun vm-visit-pop-folder (folder &optional read-only) "Visit a POP mailbox. VM will present its messages to you in the usual way. Messages found in the POP mailbox will be downloaded and stored in a local cache. If you expunge messages from the cache, the corresponding messages will be expunged from the POP mailbox. First arg FOLDER specifies the name of the POP mailbox to visit. You can only visit mailboxes that are specified in `vm-pop-folder-alist'. When this command is called interactively the mailbox name is read from the minibuffer. Prefix arg or optional second arg READ-ONLY non-nil indicates that the folder should be considered read only. No attribute changes, messages additions or deletions will be allowed in the visited folder." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-pop) (let ((completion-list (mapcar (function (lambda (x) (nth 1 x))) vm-pop-folder-alist)) (default vm-last-visit-pop-folder) (this-command this-command) (last-command last-command)) (list (vm-read-string (format "Visit%s POP folder:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) completion-list) current-prefix-arg)))) (let (remote-spec) (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (if (and (equal folder "") (stringp vm-last-visit-pop-folder)) (setq folder vm-last-visit-pop-folder)) (setq vm-last-visit-pop-folder folder) (setq remote-spec (vm-pop-find-spec-for-name folder)) (if (null remote-spec) (error "No such POP folder: %s" folder)) (vm remote-spec :read-only read-only :access-method 'pop))) ;;;###autoload (defun vm-visit-pop-folder-other-frame (folder &optional read-only) "Like vm-visit-pop-folder, but run in a newly created frame." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-pop) (let ((completion-list (mapcar (function (lambda (x) (nth 1 x))) vm-pop-folder-alist)) (default vm-last-visit-pop-folder) (this-command this-command) (last-command last-command)) (list (vm-read-string (format "Visit%s POP folder:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) completion-list) current-prefix-arg)))) (vm-session-initialization) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'folder)) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-pop-folder folder read-only)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-visit-pop-folder-other-window (folder &optional read-only) "Like vm-visit-pop-folder, but run in a different window." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-pop) (let ((completion-list (mapcar (function (lambda (x) (nth 1 x))) vm-pop-folder-alist)) (default vm-last-visit-pop-folder) (this-command this-command) (last-command last-command)) (list (vm-read-string (format "Visit%s POP folder:%s " (if current-prefix-arg " read only" "") (if default (format " (default %s)" default) "")) completion-list) current-prefix-arg)))) (vm-session-initialization) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-pop-folder folder read-only))) ;;;###autoload (defun vm-visit-imap-folder (folder &optional read-only) "Visit a IMAP mailbox. VM will present its messages to you in the usual way. Messages found in the IMAP mailbox will be downloaded and stored in a local cache. If you expunge messages from the cache, the corresponding messages will be expunged from the IMAP mailbox when the folder is saved. When this command is called interactively, the FOLDER name will be read from the minibuffer in the format \"account-name:folder-name\", where account-name is the short name of an IMAP account listed in `vm-imap-account-alist' and folder-name is a folder in this account. Prefix arg or optional second arg READ-ONLY non-nil indicates that the folder should be considered read only. No attribute changes, messages additions or deletions will be allowed in the visited folder." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-imap) (let ((this-command this-command) (last-command last-command)) (if (null vm-imap-account-alist) (setq vm-imap-account-alist (mapcar 'reverse (with-no-warnings (vm-imap-spec-list-to-host-alist vm-imap-server-list))))) (list (vm-read-imap-folder-name (format "Visit%s IMAP folder: " (if current-prefix-arg " read only" "")) t nil vm-last-visit-imap-folder) current-prefix-arg)))) (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (setq vm-last-visit-imap-folder folder) (vm folder :read-only read-only :access-method 'imap)) ;;;###autoload (defun vm-visit-imap-folder-other-frame (folder &optional read-only) "Like vm-visit-imap-folder, but run in a newly created frame." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-imap) (let ((this-command this-command) (last-command last-command)) (list (vm-read-imap-folder-name (format "Visit%s IMAP folder: " (if current-prefix-arg " read only" "")) nil nil vm-last-visit-imap-folder) current-prefix-arg)))) (vm-session-initialization) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'folder)) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-imap-folder folder read-only)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-visit-imap-folder-other-window (folder &optional read-only) "Like vm-visit-imap-folder, but run in a different window." (interactive (save-current-buffer (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (require 'vm-imap) (let ((this-command this-command) (last-command last-command)) (list (vm-read-imap-folder-name (format "Visit%s IMAP folder: " (if current-prefix-arg " read only" "")) nil nil vm-last-visit-imap-folder) current-prefix-arg)))) (vm-session-initialization) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-imap-folder folder read-only))) ;;;###autoload (defun vm-folder-buffers (&optional non-virtual) "Return the list of buffer names that are currently visiting VM folders. The optional argument NON-VIRTUAL says that only non-virtual folders should be returned." (save-excursion (let ((buffers (buffer-list)) (modes (if non-virtual '(vm-mode) '(vm-mode vm-virtual-mode))) folders) (while buffers (set-buffer (car buffers)) (if (member major-mode modes) (setq folders (cons (buffer-name) folders))) (setq buffers (cdr buffers))) folders))) (defalias 'vm-folder-list 'vm-folder-buffers) ;; The following function is from vm-rfaddons.el. USR, 2011-02-28 ;;;###autoload (defun vm-switch-to-folder (folder-name) "Switch to another opened VM folder and rearrange windows as with a scroll." (interactive (list (let* ((buffers (vm-folder-buffers)) (history vm-switch-to-folder-history) pos default) (if (member major-mode '(vm-mode vm-presentation-mode vm-summary-mode)) (save-excursion (vm-select-folder-buffer) (setq buffers (delete (buffer-name) buffers)))) (setq pos (vm-find history (lambda (f) (member f buffers)))) (if pos (setq default (nth pos history))) (completing-read (format "Foldername%s: " (if default (format " (%s)" default) "")) (mapcar (lambda (b) (list b)) (vm-folder-buffers)) nil t nil 'vm-switch-to-folder-history default)))) (switch-to-buffer folder-name) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-summarize) (let ((this-command 'vm-scroll-backward)) (vm-display nil nil '(vm-scroll-forward vm-scroll-backward) (list this-command 'reading-message)) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-get-folder-buffer (folder) "Returns the buffer visiting FOLDER if it exists, nil otherwise." (let ((buffers (vm-folder-buffers)) pos) (setq pos (vm-find buffers (lambda (b) (with-current-buffer b (equal folder (vm-folder-name)))))) (and pos (get-buffer (nth pos buffers))))) (put 'vm-virtual-mode 'mode-class 'special) (defun vm-virtual-mode (&rest ignored) "Mode for reading multiple mail folders as one folder. The commands available are the same commands that are found in vm-mode, except that a few of them are not applicable to virtual folders. vm-virtual-mode is not a normal major mode. If you run it, it will not do anything. The entry point to vm-virtual-mode is vm-visit-virtual-folder.") (defvar scroll-in-place) ;;;###autoload (defun vm-visit-virtual-folder (folder-name &optional read-only bookmark) (interactive (let ((last-command last-command) (this-command this-command)) (vm-session-initialization) (list (vm-read-string (format "Visit%s virtual folder: " (if current-prefix-arg " read only" "")) vm-virtual-folder-alist) current-prefix-arg))) (vm-session-initialization) (require 'vm-virtual) (unless (assoc folder-name vm-virtual-folder-alist) (error "No such virtual folder, %s" folder-name)) (let ((buffer-name (concat "(" folder-name ")")) first-time blurb) (set-buffer (get-buffer-create buffer-name)) (setq first-time (not (eq major-mode 'vm-virtual-mode))) (when first-time (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (abbrev-mode 0) (auto-fill-mode 0) (vm-fsfemacs-nonmule-display-8bit-chars) (setq mode-name "VM Virtual" mode-line-format vm-mode-line-format buffer-read-only t vm-folder-read-only read-only vm-label-obarray (make-vector 29 0) vm-virtual-folder-definition (assoc folder-name vm-virtual-folder-alist)) ;; scroll in place messes with scroll-up and this loses (make-local-variable 'scroll-in-place) (setq scroll-in-place nil) (vm-build-virtual-message-list nil) (use-local-map vm-mode-map) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) ;; save this for last in case the user interrupts. ;; an interrupt anywhere before this point will cause ;; everything to be redone next revisit. (setq major-mode 'vm-virtual-mode) (run-hooks 'vm-virtual-mode-hook) ;; must come after the setting of major-mode (setq mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu))) (setq blurb (vm-emit-totals-blurb)) (when vm-summary-show-threads (vm-sort-messages "activity")) (if bookmark (let ((mp vm-message-list)) (while mp (if (eq bookmark (vm-real-message-of (car mp))) (progn (vm-record-and-change-message-pointer vm-message-pointer mp) (vm-present-current-message) (setq mp nil)) (setq mp (cdr mp)))))) (unless vm-message-pointer (if (vm-thoughtfully-select-message) (vm-present-current-message) (vm-update-summary-and-mode-line))) (vm-inform 5 blurb)) ;; make a new frame if the user wants one. reuse an ;; existing frame that is showing this folder. (vm-goto-new-folder-frame-maybe 'folder) (if vm-raise-frame-at-startup (vm-raise-frame)) (vm-display nil nil (list this-command) (list this-command 'startup)) (vm-toolbar-install-or-uninstall-toolbar) (when first-time (when (vm-should-generate-summary) (vm-summarize t nil) (vm-inform 5 blurb)) ;; raise the summary frame if the user wants frames ;; raised and if there is a summary frame. (when (and vm-summary-buffer vm-mutable-frame-configuration vm-frame-per-summary vm-raise-frame-at-startup) (vm-raise-frame)) ;; if vm-mutable-window-configuration is nil, the startup ;; configuration can't be applied, so do ;; something to get a VM buffer on the screen (if vm-mutable-window-configuration (vm-display nil nil (list this-command) (list (or this-command 'vm) 'startup)) (save-excursion (switch-to-buffer (or vm-summary-buffer vm-presentation-buffer (current-buffer)))))) ;; check interactive-p so as not to bog the user down if they ;; run this function from within another function. (when (and (vm-interactive-p) (not vm-startup-message-displayed)) (vm-display-startup-message) (vm-inform 5 blurb)))) ;;;###autoload (defun vm-visit-virtual-folder-other-frame (folder-name &optional read-only) "Like vm-visit-virtual-folder, but run in a newly created frame." (interactive (let ((last-command last-command) (this-command this-command)) (vm-session-initialization) (list (vm-read-string (format "Visit%s virtual folder in other frame: " (if current-prefix-arg " read only" "")) vm-virtual-folder-alist) current-prefix-arg))) (vm-session-initialization) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'folder)) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-virtual-folder folder-name read-only)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-visit-virtual-folder-other-window (folder-name &optional read-only) "Like vm-visit-virtual-folder, but run in a different window." (interactive (let ((last-command last-command) (this-command this-command)) (vm-session-initialization) (list (vm-read-string (format "Visit%s virtual folder in other window: " (if current-prefix-arg " read only" "")) vm-virtual-folder-alist) current-prefix-arg))) (vm-session-initialization) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-folder nil) (vm-search-other-frames nil)) (vm-visit-virtual-folder folder-name read-only))) ;;;###autoload (defun vm-mail (&optional to subject) "Send a mail message from within VM, or from without. Optional argument TO is a string that should contain a comma separated recipient list." (interactive) (vm-session-initialization) (vm-check-for-killed-folder) (let ((guess (when (null to) (vm-select-recipient-from-sender)))) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (vm-mail-internal :to to :guessed-to guess :subject subject) (run-hooks 'vm-mail-hook) (run-hooks 'vm-mail-mode-hook))) ;;;###autoload (defun vm-mail-other-frame (&optional to) "Like vm-mail, but run in a newly created frame. Optional argument TO is a string that should contain a comma separated recipient list." (interactive) (vm-session-initialization) (when (null to) (setq to (vm-select-recipient-from-sender))) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-mail to)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-mail-other-window (&optional to) "Like vm-mail, but run in a different window. Optional argument TO is a string that should contain a comma separated recipient list." (interactive) (vm-session-initialization) (when (null to) (setq to (vm-select-recipient-from-sender))) (if (one-window-p t) (split-window)) (other-window 1) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-mail to))) (fset 'vm-folders-summary-mode 'vm-mode) (put 'vm-folders-summary-mode 'mode-class 'special) ;;;###autoload (defun vm-folders-summarize (&optional display raise) "Generate a summary of the folders in your folder directories. Set `vm-folders-summary-directories' to specify the folder directories. Press RETURN or click mouse button 2 on an entry in the folders summary buffer to select a folder." (interactive "p\np") (vm-session-initialization) (vm-check-for-killed-summary) (if (not (featurep 'berkeley-db)) (error "Berkeley DB support needed to run this command")) (if (null vm-folders-summary-database) (error "'vm-folders-summary-database' must be non-nil to run this command")) (if (null vm-folders-summary-buffer) (let ((folder-buffer (and (eq major-mode 'vm-mode) (current-buffer))) (summary-buffer-name "VM Folders Summary")) (setq vm-folders-summary-buffer (or (get-buffer summary-buffer-name) (vm-generate-new-multibyte-buffer summary-buffer-name))) (save-excursion (set-buffer vm-folders-summary-buffer) (abbrev-mode 0) (auto-fill-mode 0) (vm-fsfemacs-nonmule-display-8bit-chars) (if (fboundp 'buffer-disable-undo) (buffer-disable-undo (current-buffer)) ;; obfuscation to make the v19 compiler not whine ;; about obsolete functions. (let ((x 'buffer-flush-undo)) (funcall x (current-buffer)))) (vm-folders-summary-mode-internal)) (vm-make-folders-summary-associative-hashes) (vm-do-folders-summary))) ;; if this command was run from a VM related buffer, select ;; the folder buffer in the folders summary, but only if that ;; folder has an entry there. (and vm-mail-buffer (vm-check-for-killed-folder)) (save-excursion (and vm-mail-buffer (vm-select-folder-buffer-and-validate 0 (vm-interactive-p))) (vm-check-for-killed-summary) (let ((folder-buffer (and (eq major-mode 'vm-mode) (current-buffer))) fs ) (if (or (null vm-folders-summary-hash) (null folder-buffer) (null buffer-file-name)) nil (setq fs (symbol-value (intern-soft (vm-make-folders-summary-key buffer-file-name) vm-folders-summary-hash))) (if (null fs) nil (vm-mark-for-folders-summary-update buffer-file-name) (set-buffer vm-folders-summary-buffer) (setq vm-mail-buffer folder-buffer))))) (if display (save-excursion (vm-goto-new-folders-summary-frame-maybe) (vm-display vm-folders-summary-buffer t '(vm-folders-summarize) (list this-command) (not raise)) ;; need to do this after any frame creation because the ;; toolbar sets frame-specific height and width specifiers. (set-buffer vm-folders-summary-buffer) (vm-toolbar-install-or-uninstall-toolbar)) (vm-display nil nil '(vm-folders-summarize) (list this-command))) (vm-update-summary-and-mode-line)) (defvar mail-reply-action) (defvar mail-send-actions) (defvar mail-return-action) ;;;###autoload (defun vm-compose-mail (&optional to subject other-headers continue switch-function yank-action send-actions return-action &rest ignored) (interactive) (vm-session-initialization) (if continue (vm-continue-composing-message) (let ((buffer (vm-mail-internal :buffer-name (if to (format "message to %s" (vm-truncate-roman-string to 20)) nil) :to to :subject subject))) (goto-char (point-min)) (re-search-forward (concat "^" mail-header-separator "$")) (beginning-of-line) (while other-headers (insert (car (car other-headers))) (while (eq (char-syntax (char-before (point))) ?\ ) (delete-char -1)) (while (eq (char-before (point)) ?:) (delete-char -1)) (insert ": " (cdr (car other-headers))) (if (not (eq (char-before (point)) ?\n)) (insert "\n")) (setq other-headers (cdr other-headers))) (cond ((null to) (mail-position-on-field "To")) ((null subject) (mail-position-on-field "Subject")) (t (mail-text))) (funcall (or switch-function (function switch-to-buffer)) (current-buffer)) (if yank-action (save-excursion (mail-text) (apply (car yank-action) (cdr yank-action)) (push-mark (point)) (mail-text) (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) (mail-yank-hooks (run-hooks 'mail-yank-hooks)) (t (vm-mail-yank-default))))) (make-local-variable 'mail-send-actions) (setq mail-send-actions send-actions) (make-local-variable 'mail-return-action) (setq mail-return-action return-action)))) ;;;###autoload (defun vm-submit-bug-report (&optional pre-hooks post-hooks) "Submit a bug report, with pertinent information to the VM bug list." (interactive) (require 'reporter) (vm-session-initialization) ;; Use VM to send the bug report. Could be trouble if vm-mail ;; is what the user wants to complain about. But most of the ;; time we'll be fine and users like to use MIME to attach ;; stuff to the reports. (let ((reporter-mailer '(vm-mail)) (mail-user-agent 'vm-user-agent) varlist (errors 0)) (setq varlist (apropos-internal "^\\(vm\\|vmpc\\)-" 'user-variable-p) varlist (sort varlist (lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2))))) (when (and (eq vm-mime-text/html-handler 'emacs-w3m) (boundp 'emacs-w3m-version)) (nconc varlist (list 'emacs-w3m-version 'w3m-version 'w3m-goto-article-function))) (let ((fill-column (1- (window-width))) ; turn off auto-fill (mail-user-agent 'message-user-agent) ; use the default ; mail-user-agent for bug reports (vars-to-delete '(vm-auto-folder-alist ; a bit private vm-mail-folder-alist ; ditto vm-virtual-folder-alist ; ditto ;; vm-mail-fcc-default - is this private? vmpc-actions vmpc-conditions vmpc-actions-alist vmpc-reply-alist vmpc-forward-alist vmpc-resend-alist vmpc-newmail-alist vmpc-automorph-alist ;; email addresses vm-mail-header-from vm-mail-return-receipt-to vm-summary-uninteresting-senders ;; obsolete-variables vm-imap-server-list )) ;; delete any passwords stored in maildrop strings (vm-spool-files (condition-case nil (if (listp (car vm-spool-files)) (vm-mapcar (lambda (elem-xyz) (vm-mapcar (function vm-maildrop-sans-personal-info) elem-xyz))) (vm-mapcar (function vm-maildrop-sans-personal-info) vm-spool-files)) (error (vm-increment errors) vm-spool-files))) (vm-pop-folder-alist (condition-case nil (vm-maildrop-alist-sans-personal-info vm-pop-folder-alist) (error (vm-increment errors) vm-pop-folder-alist))) ;; (vm-imap-server-list ;; (with-no-warnings ;; (condition-case nil ;; (vm-mapcar (function vm-maildrop-sans-personal-info) ;; vm-imap-server-list) ;; (error (vm-increment errors) vm-imap-server-list)))) (vm-imap-account-alist (condition-case nil (vm-maildrop-alist-sans-personal-info vm-imap-account-alist) (error (vm-increment errors) vm-imap-account-alist))) (vm-pop-auto-expunge-alist (condition-case nil (vm-maildrop-alist-sans-personal-info vm-pop-auto-expunge-alist) (error (vm-increment errors) vm-pop-auto-expunge-alist))) (vm-imap-auto-expunge-alist (condition-case nil (vm-maildrop-alist-sans-personal-info vm-imap-auto-expunge-alist) (error (vm-increment errors) vm-imap-auto-expunge-alist)))) (while vars-to-delete (setq varlist (delete (car vars-to-delete) varlist) vars-to-delete (cdr vars-to-delete))) ;; see what the user had loaded (setq varlist (append (list 'features) varlist)) (delete-other-windows) (reporter-submit-bug-report vm-maintainer-address ; address (concat "VM " (vm-version)) ; pkgname varlist ; varlist pre-hooks ; pre-hooks post-hooks ; post-hooks (concat ; salutation "INSTRUCTIONS: - Please change the Subject header to a concise bug description. - In this report, remember to cover the basics, that is, what you expected to happen and what in fact did happen and how to reproduce it. - You may attach sample messages or attachments that can be used to reproduce the problem. - Mail sent to viewmail-bugs@nongnu.org is only viewed by VM maintainers and it is not made public. - You may remove these instructions and other stuff which is unrelated to the bug from your message. " (if (> errors 0) " - The raw definitions for some of the mail configurations are included below because there were errors in cleaning them. Please replace any sensitive information by xxxx.")) ) (goto-char (point-min)) (mail-position-on-field "Subject")))) (defun vm-edit-init-file () "Edit the `vm-init-file'." (interactive) (find-file-other-frame vm-init-file)) (defun vm-check-emacs-version () "Checks the version of Emacs and gives an error if it is unsupported." (cond ((and vm-xemacs-p (< emacs-major-version 21)) (error "VM %s must be run on XEmacs 21 or a later version." (vm-version))) ((and vm-fsfemacs-p (< emacs-major-version 21)) (error "VM %s must be run on GNU Emacs 21 or a later version." (vm-version))))) ;; This function is now defunct. USR, 2011-11-12 ;; (defun vm-set-debug-flags () ;; (or stack-trace-on-error ;; debug-on-error ;; (setq stack-trace-on-error ;; '( ;; wrong-type-argument ;; wrong-number-of-arguments ;; args-out-of-range ;; void-function ;; void-variable ;; invalid-function ;; )))) (defun vm-toggle-thread-operations () "Toggle the variable `vm-enable-thread-operations'. If enabled, VM operations on root messages of collapsed threads will apply to all the messages in the threads. If disabled, VM operations only apply to individual messages. \"Operations\" in this context include deleting, saving, setting attributes, adding/deleting labels etc." (interactive) (setq vm-enable-thread-operations (not vm-enable-thread-operations)) (if vm-enable-thread-operations (vm-inform 5 "Thread operations enabled") (vm-inform 5 "Thread operations disabled"))) (defvar vm-postponed-folder) (defvar vm-drafts-exist nil) (defvar vm-ml-draft-count "" "The current number of drafts in the `vm-postponed-folder'.") (defvar vm-postponed-folder) ;;;###autoload (defun vm-update-draft-count () "Check number of postponed messages in folder `vm-postponed-folder'." (let ((f (expand-file-name vm-postponed-folder vm-folder-directory))) (if (or (not (file-exists-p f)) (= (nth 7 (file-attributes f)) 0)) (setq vm-drafts-exist nil) (let ((mtime (nth 5 (file-attributes f)))) (when (not (equal vm-drafts-exist mtime)) (setq vm-drafts-exist mtime) (setq vm-ml-draft-count (format "%d postponed" (vm-count-messages-in-file f)))))))) ;;;###autoload (defun vm-session-initialization () "If this is the first time VM has been run in this Emacs session, do some necessary preparations. Otherwise, update the count of draft messages." ;; (vm-set-debug-flags) (if (or (not (boundp 'vm-session-beginning)) vm-session-beginning) (progn (vm-check-emacs-version) (require 'vm-macro) (require 'vm-vars) (require 'vm-misc) (require 'vm-message) (require 'vm-minibuf) (require 'vm-motion) (require 'vm-page) (require 'vm-mouse) (require 'vm-summary) (require 'vm-summary-faces) (require 'vm-undo) (require 'vm-mime) (require 'vm-folder) (require 'vm-toolbar) (require 'vm-window) (require 'vm-menu) (require 'vm-rfaddons) ;; The default loading of vm-pgg is disabled because it is an ;; add-on. If and when it is integrated into VM, without advices ;; and other add-on features, then it can be loaded by ;; default. USR, 2010-01-14 ;; (if (locate-library "pgg") ;; (require 'vm-pgg) ;; (message "vm-pgg disabled since pgg is missing!")) (add-hook 'kill-emacs-hook 'vm-garbage-collect-global) (vm-load-init-file) (when vm-enable-addons (vm-rfaddons-infect-vm 0 vm-enable-addons)) (if (not vm-window-configuration-file) (setq vm-window-configurations vm-default-window-configuration) (or (vm-load-window-configurations vm-window-configuration-file) (setq vm-window-configurations vm-default-window-configuration))) (setq vm-buffers-needing-display-update (make-vector 29 0)) (setq vm-buffers-needing-undo-boundaries (make-vector 29 0)) (add-hook 'post-command-hook 'vm-add-undo-boundaries) (if (if vm-xemacs-p (find-face 'vm-monochrome-image) (facep 'vm-monochrome-image)) nil (make-face 'vm-monochrome-image) (set-face-background 'vm-monochrome-image "white") (set-face-foreground 'vm-monochrome-image "black")) (if (or (not vm-fsfemacs-p) ;; don't need this face under Emacs 21. (fboundp 'image-type-available-p) (facep 'vm-image-placeholder)) nil (make-face 'vm-image-placeholder) (if (fboundp 'set-face-stipple) (set-face-stipple 'vm-image-placeholder (list 16 16 (concat "UU\377\377UU\377\377UU\377\377" "UU\377\377UU\377\377UU\377\377" "UU\377\377UU\377\377"))))) (and (vm-mouse-support-possible-p) (vm-mouse-install-mouse)) (and (vm-menu-support-possible-p) vm-use-menus (vm-menu-fsfemacs-menus-p) (vm-menu-initialize-vm-mode-menu-map)) (setq vm-session-beginning nil))) ;; check for postponed messages (vm-update-draft-count)) ;;;###autoload (if (fboundp 'define-mail-user-agent) (define-mail-user-agent 'vm-user-agent (function vm-compose-mail) ; compose function (function vm-mail-send-and-exit) ; send function nil ; abort function (kill-buffer) nil) ; hook variable (mail-send-hook) ) (autoload 'reporter-submit-bug-report "reporter") (autoload 'timezone-make-date-sortable "timezone") (autoload 'rfc822-addresses "rfc822") (autoload 'mail-strip-quoted-names "mail-utils") (autoload 'mail-fetch-field "mail-utils") (autoload 'mail-position-on-field "mail-utils") (autoload 'mail-send "sendmail") (autoload 'mail-mode "sendmail") (autoload 'mail-extract-address-components "mail-extr") (autoload 'set-tapestry "tapestry") (autoload 'tapestry "tapestry") (autoload 'tapestry-replace-tapestry-element "tapestry") (autoload 'tapestry-nullify-tapestry-elements "tapestry") (autoload 'tapestry-remove-frame-parameters "tapestry") ;;; vm.el ends here vm-8.2.0b/lisp/vm-grepmail.el0000755000175000017500000002215511676442160016307 0ustar srivastasrivasta;;; vm-grepmail.el --- VM interface for grepmail ;; ;; This file is part of VM ;; ;; Copyright (C) 2001-2005 Robert Widhopf-Fenk ;; ;; Author: Robert Widhopf-Fenk ;; Status: Tested with XEmacs 21.4.15 & VM 7.19 ;; Keywords: VM helpers ;; X-URL: http://www.robf.de/Hacking/elisp ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; ;; Add the following line to your .vm ;; (require 'vm-grepmail) ;; ;;; Bugs: ;; ;; Somehow/sometimes the parsing stuff might create a corrupted folder but ;; sofar I have not been able to reproduce this problem! ;; ;; I would be thankful if you could provide me with an testing example. ;; ;;; Code: (provide 'vm-grepmail) (eval-and-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-undo) (require 'vm-startup) (require 'vm-motion) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; group already defined in vm-vars.el ;(defgroup vm nil ; "VM" ; :group 'mail) (defgroup vm-grepmail nil "The VM grepmail lib" :group 'vm) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defcustom vm-grepmail-command "grepmail" "*Path to the program." :group 'vm-grepmail :type 'file) ;;;###autoload (defcustom vm-grepmail-arguments (list "-q" "-m" "-R" "-e" (format "%S" user-full-name)) "*Arguments for grepmail program." :group 'vm-grepmail :type '(repeat (string))) (defvar vm-grepmail-arguments-history nil "*History of previously used grepmail parameters.") (defvar vm-grepmail-folders-history nil "*History for folders/directories for grepmail program.") (defvar vm-grepmail-folder-buffer nil) (if vm-fsfemacs-p ;; For sixth arg of read-file-name in Emacs 21. cf vm-folder-history. (defun vm-grepmail-folders-history (&rest ignored) t)) ;;;###autoload (defun vm-grepmail (arguments folders) "A not so excellent interface to grepmail. Grepmail is a fast perl-script for finding mails which got lost in the folder jungle. End your input or folders and directories with an empty sting or the default folder. ARGUMENTS the command line aruments to grepmail. FOLDERS should be a list of files/directories to search in." (interactive (list (split-string (read-string "grepmail arguments: " (mapconcat 'identity vm-grepmail-arguments " ") 'vm-grepmail-arguments-history)) (let ((default (or vm-folder-directory "~/Mail")) fd folders) (while (or (not (string= fd (expand-file-name default))) (string= fd "")) (setq fd (vm-read-file-name (format "Search folder/directory %s%s: " (if (not folders) "[end list with RET]" "") (if folders (concat "(" (mapconcat 'identity folders ", ") ")") "")) default default t nil 'vm-grepmail-folders-history) fd (expand-file-name fd)) (if (not (string= fd (expand-file-name default))) (setq folders (add-to-list 'folders fd)))) (if (null folders) (setq folders (add-to-list 'folders fd))) folders))) (setq vm-grepmail-arguments arguments) (setq vm-grepmail-folders-history (append folders vm-grepmail-folders-history)) (let ((folder-buffer (format "* VM folder: grepmail %s %s *" arguments folders)) (process-buffer (get-buffer-create (format "* grepmail %s %s *" arguments folders))) (vm-folder-directory (or vm-folder-directory "~/Mail")) process) (when (get-buffer folder-buffer) (set-buffer folder-buffer) (if vm-summary-buffer (kill-buffer vm-summary-buffer)) (if vm-presentation-buffer (kill-buffer vm-presentation-buffer)) (kill-buffer folder-buffer)) (setq folder-buffer (get-buffer-create folder-buffer)) (set-buffer folder-buffer) (setq default-directory (expand-file-name vm-folder-directory)) (setq buffer-read-only nil) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'folder)) (switch-to-buffer folder-buffer) (set-buffer-modified-p nil) (vm-mode) (font-lock-mode -1) (vm-update-summary-and-mode-line) (vm-display (current-buffer) t '(vm-scroll-forward vm-scroll-backward) '(reading-message)) (vm-summarize t t) (vm-display (current-buffer) nil nil '(reading-message)) (vm-display (current-buffer) t nil '(vm-next-message reading-message)) (save-excursion (set-buffer process-buffer) (setq default-directory (expand-file-name vm-folder-directory)) (erase-buffer) (switch-to-buffer process-buffer) (make-local-variable 'vm-grepmail-folder-buffer) (setq vm-grepmail-folder-buffer folder-buffer) (setq process (apply 'start-process-shell-command "grepmail" process-buffer vm-grepmail-command (append arguments folders))) (if (null process) (error "Cannot start grepmail")) ;; set the send-filter (if vm-fsfemacs-p (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix)) (set-process-filter process 'vm-grepmail-process-filter) (set-process-sentinel process 'vm-grepmail-process-done) process))) (defun vm-grepmail-process-filter (process output) "The PROCESS insert OUTPUT into an folder biuffer." (condition-case nil ;err (progn (set-buffer (process-buffer process)) (goto-char (point-max)) (insert output) (let (end) (goto-char (1+ (point-min))) (when (and (string-match "^\nFrom " output) (setq end (and (re-search-forward "^\nFrom " (point-max) t) (match-beginning 0)))) (vm-grepmail-grab-message (current-buffer) (point-min) end) (delete-region (point-min) end))) (sit-for 0)) (error nil ;; TODO: there are some problems here but we ignore them ; (message "%S" err) ; (backtrace) )) ) (defun vm-grepmail-process-done (process state) "Called when the grepmail PROCESS is finished returning STATE." (message "grepmail cleanup.") (setq state (process-status process)) (if (not (or (eq state 'exit) (eq state 'finished) (not (= (process-exit-status process) 0)))) (error "Grepmail terminated abnormally with %S %d" state (process-exit-status process))) ;; grab the last message (set-buffer (process-buffer process)) (goto-char (point-max)) (beginning-of-line) (vm-grepmail-grab-message (current-buffer) (point-min) (point)) ;; cleanup (let ((folder-buffer vm-grepmail-folder-buffer)) (kill-this-buffer) (set-buffer folder-buffer) (vm-next-message 1) (vm-clear-modification-flag-undos) (set-buffer-modified-p nil) (setq major-mode 'vm-virtual-mode) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) (message "grepmail is finished.")) (defun vm-grepmail-grab-message (message-buffer start end) "Assimilates a message after it is complete. MESSAGE-BUFFER is the buffer of the message. START the start position in the process output buffer. END the end position in the process output buffer." (save-excursion (set-buffer vm-grepmail-folder-buffer) (let ((buffer-read-only nil)) (vm-save-restriction (widen) (goto-char (point-max)) (insert-buffer-substring message-buffer start end) (cond ((eq major-mode 'vm-mode) (vm-clear-modification-flag-undos))) (vm-check-for-killed-summary) (vm-assimilate-new-messages) (vm-update-summary-and-mode-line) (set-buffer-modified-p nil)))) (sit-for 0)) ;;; vm-grepmail.el ends here vm-8.2.0b/lisp/vm-message.el0000755000175000017500000006054211676442160016135 0ustar srivastasrivasta;;; vm-message.el --- Macros and functions dealing with accessing VM ;; message struct fields ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-message) (declare-function vm-mime-encode-words-in-string "vm-mime" (string)) (declare-function vm-reencode-mime-encoded-words-in-string "vm-mime" (string)) (declare-function vm-reencode-mime-encoded-words-in-tokenized-summary "vm-mime" (summary)) (declare-function vm-mark-for-summary-update "vm-folder" (m &optional dont-kill-cache)) (declare-function vm-stuff-virtual-message-data "vm-folder" (message)) (declare-function vm-reorder-message-headers "vm-folder" (message &optional keep-list discard-regexp)) (declare-function vm-mark-folder-modified-p "vm-folder" (buffer)) (declare-function vm-clear-modification-flag-undos "vm-undo" ()) (declare-function vm-build-threads "vm-undo" (message-list)) (declare-function vm-unthread-message "vm-thread" (message &key message-changing)) (declare-function vm-present-current-message "vm-page" ()) (declare-function vm-zip-vectors "vm-misc" (v1 v2)) (declare-function vm-zip-lists "vm-misc.el" (list1 list2) t) ;; current message (defsubst vm-current-message () "Returns the currently selected message in the VM folder. It works in all VM buffers." (with-current-buffer (or vm-mail-buffer (current-buffer)) (car vm-message-pointer))) ;; message struct (defconst vm-location-data-vector-length 6) (defconst vm-message-fields [:location-data :softdata :attributes :cached-data :mirror-data]) (defsubst vm-location-data-of (message) (aref message 0)) (defsubst vm-softdata-of (message) (aref message 1)) (defsubst vm-attributes-of (message) (aref message 2)) (defsubst vm-cached-data-of (message) (aref message 3)) (defsubst vm-mirror-data-of (message) (aref message 4)) (defsubst vm-set-location-data-of (message vdata) (aset message 0 vdata)) (defsubst vm-set-softdata-of (message data) (aset message 1 data)) (defsubst vm-set-attributes-of (message attrs) (aset message 2 attrs)) (defsubst vm-set-cached-data-of (message cache) (aset message 3 cache)) (defsubst vm-set-mirror-data-of (message data) (aset message 4 data)) ;; data that is always shared with virtual folders (defconst vm-location-data-fields [:start :headers :vheaders :text :text-end :end]) ;; where message begins starting at the message separator in the folder (defsubst vm-start-of (message) (aref (aref message 0) 0)) ;; where headers start (From_ line) (defsubst vm-headers-of (message) (aref (aref message 0) 1)) ;; where visible headers start (defun vm-vheaders-of (message) (or (aref (aref message 0) 2) (progn (vm-reorder-message-headers message) (aref (aref message 0) 2)))) ;; where text section starts (defsubst vm-text-of (message) (or (aref (aref message 0) 3) (progn (vm-find-and-set-text-of message) (aref (aref message 0) 3)))) ;; where text portion of message ends (defsubst vm-text-end-of (message) (aref (aref message 0) 4)) ;; where message ends (defsubst vm-end-of (message) (aref (aref message 0) 5)) ;; soft data vector (defconst vm-softdata-vector-length 23) (defconst vm-softdata-fields [:number :padded-number :mark :su-start :su-end :real-message-sym :reverse-link-sym :message-type :message-id-number :buffer :thread-indentation :thread-list :babyl-frob-flag :saved-virtual-attributes :saved-virtual-mirror-data :virtual-summary :mime-layout :mime-encoded-header-flag :su-summary-mouse-track-overlay :message-access-method :thread-subtree :mirrored-message-sym :thread-indentation-offset]) (defsubst vm-number-of (message) (aref (aref message 1) 0)) (defsubst vm-padded-number-of (message) (aref (aref message 1) 1)) (defsubst vm-mark-of (message) (aref (aref message 1) 2)) ;; start of summary line (defsubst vm-su-start-of (message) (aref (aref message 1) 3)) ;; end of summary line (defsubst vm-su-end-of (message) (aref (aref message 1) 4)) ;; symbol whose value is the real message. (defsubst vm-real-message-sym-of (message) (aref (aref message 1) 5)) ;; real message (defsubst vm-real-message-of (message) (symbol-value (aref (aref message 1) 5))) ;; link to previous message in the message list (defsubst vm-reverse-link-of (message) (symbol-value (aref (aref message 1) 6))) ;; message type (defsubst vm-message-type-of (message) (aref (aref message 1) 7)) ;; number that uniquely identifies each message ;; this is for the set handling stuff (defsubst vm-message-id-number-of (message) (aref (aref message 1) 8)) ;; folder buffer of this message (defsubst vm-buffer-of (message) (aref (aref message 1) 9)) ;; cache thread indentation value (defsubst vm-thread-indentation-of (message) (aref (aref message 1) 10)) ;; list of symbols from vm-thread-obarray that give this message's lineage (defsubst vm-thread-list-of (message) (aref (aref message 1) 11)) ;; babyl header frob flag (0 or 1 at beginning of message) (defsubst vm-babyl-frob-flag-of (message) (aref (aref message 1) 12)) ;; saved attributes, if message was switched from unmirrored to mirrored (defsubst vm-saved-virtual-attributes-of (message) (aref (aref message 1) 13)) ;; saved mirror data, if message was switched from unmirrored to mirrored (defsubst vm-saved-virtual-mirror-data-of (message) (aref (aref message 1) 14)) ;; summary for unmirrored virtual message (defsubst vm-virtual-summary-of (message) (aref (aref message 1) 15)) ;; MIME layout information; types, ids, positions, etc. of all MIME entities (defsubst vm-mime-layout-of (message) (aref (aref message 1) 16)) (defsubst vm-mime-encoded-header-flag-of (message) (aref (aref message 1) 17)) (defsubst vm-su-summary-mouse-track-overlay-of (message) (aref (aref message 1) 18)) (defsubst vm-message-access-method-of (message) (aref (aref message 1) 19)) (defsubst vm-thread-subtree-of (message) (aref (aref message 1) 20)) (defsubst vm-mirrored-message-sym-of (message) (aref (aref message 1) 21)) (defsubst vm-mirrored-message-of (message) (symbol-value (aref (aref message 1) 21))) (defsubst vm-thread-indentation-offset-of (message) (aref (aref message 1) 22)) ;; message attribute vector (defconst vm-attributes-vector-length 16) (defconst vm-attributes-fields [:new-flag :unread-flag :deleted-flag :filed-flag :replied-flag :written-flag :forwarded-flag :edited-flag :redistributed-flag :flagged-flag :folded-flag :watched-flag :ignored-flag :read-receipt-flag :read-receipt-sent-flag :attachments-flag]) (defsubst vm-new-flag (message) (aref (aref message 2) 0)) (defsubst vm-unread-flag (message) (aref (aref message 2) 1)) (defsubst vm-deleted-flag (message) (aref (aref message 2) 2)) (defsubst vm-filed-flag (message) (aref (aref message 2) 3)) (defsubst vm-replied-flag (message) (aref (aref message 2) 4)) (defsubst vm-written-flag (message) (aref (aref message 2) 5)) (defsubst vm-forwarded-flag (message) (aref (aref message 2) 6)) (defsubst vm-edited-flag (message) (aref (aref message 2) 7)) (defsubst vm-redistributed-flag (message) (aref (aref message 2) 8)) (defsubst vm-flagged-flag (message) (aref (aref message 2) 9)) (defsubst vm-folded-flag (message) (aref (aref message 2) 10)) (defsubst vm-watched-flag (message) (aref (aref message 2) 11)) (defsubst vm-ignored-flag (message) (aref (aref message 2) 12)) (defsubst vm-read-receipt-flag (message) (aref (aref message 2) 13)) (defsubst vm-read-receipt-sent-flag (message) (aref (aref message 2) 14)) (defsubst vm-attachments-flag (message) (aref (aref message 2) 15)) ;; message cached data (defconst vm-cached-data-vector-length 26) (defconst vm-cached-data-fields [:byte-count :weekday :monthday :month :year :hour :zone :full-name :from :message-id :line-count :subject :vheaders-regexp :to :to-names :month-number :sortable-datestring :sortable-subject :summary :parent :references :body-to-be-discarded :body-to-be-retrieved :uid :imap-uid-validity :spam-score]) ;; message size in bytes (as a string) (defsubst vm-byte-count-of (message) (aref (aref message 3) 0)) ;; weekday sent (defsubst vm-weekday-of (message) (aref (aref message 3) 1)) ;; month day (defsubst vm-monthday-of (message) (aref (aref message 3) 2)) ;; month sent (defsubst vm-month-of (message) (aref (aref message 3) 3)) ;; year sent (defsubst vm-year-of (message) (aref (aref message 3) 4)) ;; hour sent (defsubst vm-hour-of (message) (aref (aref message 3) 5)) ;; timezone (defsubst vm-zone-of (message) (aref (aref message 3) 6)) ;; message author's full name (Full-Name: or gouged from From:) (defsubst vm-full-name-of (message) (aref (aref message 3) 7)) ;; message author address (gouged from From:) (defsubst vm-from-of (message) (aref (aref message 3) 8)) ;; message ID (Message-Id:) (defsubst vm-message-id-of (message) (aref (aref message 3) 9)) ;; number of lines in message (as a string) (defsubst vm-line-count-of (message) (aref (aref message 3) 10)) ;; message subject (Subject:) (defsubst vm-subject-of (message) (aref (aref message 3) 11)) ;; Regexp that can be used to find the start of the already ordered headers. (defsubst vm-vheaders-regexp-of (message) (aref (aref message 3) 12)) ;; Addresses of recipients in a comma separated list (defsubst vm-to-of (message) (aref (aref message 3) 13)) ;; Full names of recipients in a comma separated list. Addresses if ;; full names not available. (defsubst vm-to-names-of (message) (aref (aref message 3) 14)) ;; numeric month sent (defsubst vm-month-number-of (message) (aref (aref message 3) 15)) ;; sortable date string (used for easy sorting, naturally) (defsubst vm-sortable-datestring-of (message) (aref (aref message 3) 16)) ;; sortable subject, re: garbage removed (defsubst vm-sortable-subject-of (message) (aref (aref message 3) 17)) ;; tokenized summary entry (defsubst vm-summary-of (message) (aref (aref message 3) 18)) ;; parent of this message, as determined by threading (defsubst vm-parent-of (message) (aref (aref message 3) 19)) ;; message IDs parsed from References header (defsubst vm-references-of (message) (aref (aref message 3) 20)) ;; have we retrieved the headers of this message? ;; only valid for remote folder access methods ;; USR: changed the name to vm-headers-to-be-retrieved-of because all the ;; VM folders in the world already have nil's written in this field. ;; USR: changed it again to vm-body-to-be-discarded-of to allow for ;; fetched messages to be discarded before save. 2010-06-08 (defsubst vm-headers-to-be-retrieved-of (message) nil) (defsubst vm-body-to-be-discarded-of (message) (aref (aref message 3) 21)) ;; have we retrieved the body of this message? ;; only valid for remote folder access methods ;; USR: changed the name to vm-body-to-be-retrieved-of because all the ;; VM folders in the world already have nil's written in this field. (defsubst vm-body-to-be-retrieved-of (message) (aref (aref message 3) 22)) (defsubst vm-body-retrieved-of (message) (null (aref (aref message 3) 22))) ;; pop UIDL value for message (defsubst vm-pop-uidl-of (message) (aref (aref message 3) 23)) ;; imap UID value for message (shares same slot as pop-uidl-of) (defsubst vm-imap-uid-of (message) (aref (aref message 3) 23)) ;; imap UIDVALIDITY value for message (defsubst vm-imap-uid-validity-of (message) (aref (aref message 3) 24)) (defsubst vm-spam-score-of (message) (aref (aref message 3) 25)) ;; extra data shared by virtual messages if vm-virtual-mirror is non-nil (defconst vm-mirror-data-vector-length 6) (defconst vm-mirror-data-fields [:edit-buffer :virtual-messages-sym :stuff-flag :labels :label-string :attribute-modflag]) ;; if message is being edited, this is the buffer being used. (defsubst vm-edit-buffer-of (message) (aref (aref message 4) 0)) ;; list of virtual messages mirroring the underlying real message (defsubst vm-virtual-messages-of (message) (symbol-value (aref (aref message 4) 1))) ;; nil if all attribute changes have been stuffed into the folder buffer (defsubst vm-stuff-flag-of (message) (aref (aref message 4) 2)) ;; list of labels attached to this message (defsubst vm-labels-of (message) (aref (aref message 4) 3)) ;; comma list of labels (defsubst vm-label-string-of (message) (aref (aref message 4) 4)) ;; attribute modification flag for this message ;; non-nil if attributes need to be saved (defsubst vm-attribute-modflag-of (message) (aref (aref message 4) 5)) (defsubst vm-set-start-of (message start) (aset (aref message 0) 0 start)) (defsubst vm-set-headers-of (message h) (aset (aref message 0) 1 h)) (defsubst vm-set-vheaders-of (message vh) (aset (aref message 0) 2 vh)) (defsubst vm-set-text-of (message text) (aset (aref message 0) 3 text)) (defsubst vm-set-text-end-of (message text) (aset (aref message 0) 4 text)) (defsubst vm-set-end-of (message end) (aset (aref message 0) 5 end)) (defsubst vm-set-number-of (message n) (aset (aref message 1) 0 n)) (defsubst vm-set-padded-number-of (message n) (aset (aref message 1) 1 n)) (defsubst vm-set-mark-of (message val) (aset (aref message 1) 2 val)) (defsubst vm-set-su-start-of (message pos) (aset (aref message 1) 3 pos)) (defsubst vm-set-su-end-of (message pos) (aset (aref message 1) 4 pos)) (defsubst vm-set-real-message-sym-of (message sym) (aset (aref message 1) 5 sym)) (defsubst vm-set-reverse-link-of (message link) (set (aref (aref message 1) 6) link)) (defsubst vm-set-reverse-link-sym-of (message sym) (aset (aref message 1) 6 sym)) (defsubst vm-set-message-type-of (message type) (aset (aref message 1) 7 type)) (defsubst vm-set-message-id-number-of (message number) (aset (aref message 1) 8 number)) (defsubst vm-set-buffer-of (message buffer) (aset (aref message 1) 9 buffer)) (defsubst vm-set-thread-indentation-of (message val) (aset (aref message 1) 10 val)) (defsubst vm-set-thread-list-of (message list) (aset (aref message 1) 11 list)) (defsubst vm-set-babyl-frob-flag-of (message flag) (aset (aref message 1) 12 flag)) (defsubst vm-set-saved-virtual-attributes-of (message attrs) (aset (aref message 1) 13 attrs)) (defsubst vm-set-saved-virtual-mirror-data-of (message data) (aset (aref message 1) 14 data)) (defsubst vm-set-virtual-summary-of (message summ) (aset (aref message 1) 15 summ)) (defsubst vm-set-mime-layout-of (message layout) (aset (aref message 1) 16 layout)) (defsubst vm-set-mime-encoded-header-flag-of (message flag) (aset (aref message 1) 17 flag)) (defsubst vm-set-su-summary-mouse-track-overlay-of (message overlay) (aset (aref message 1) 18 overlay)) (defsubst vm-set-message-access-method-of (message method) (aset (aref message 1) 19 method)) (defsubst vm-set-thread-subtree-of (message list) (aset (aref message 1) 20 list)) (defsubst vm-set-mirrored-message-sym-of (message sym) (aset (aref message 1) 21 sym)) (defsubst vm-set-thread-indentation-offset-of (message offset) (aset (aref message 1) 22 offset)) ;; The other routines in attributes group are part of the undo system. (defun vm-set-edited-flag-of (message flag) (aset (aref message 2) 7 flag) (vm-mark-for-summary-update message) (if (eq vm-flush-interval t) (vm-stuff-virtual-message-data message) (vm-set-stuff-flag-of message t)) (unless (buffer-modified-p) (vm-mark-folder-modified-p (current-buffer))) (vm-clear-modification-flag-undos)) (defsubst vm-set-byte-count-of (message count) (aset (aref message 3) 0 count)) (defsubst vm-set-weekday-of (message val) (aset (aref message 3) 1 val)) (defsubst vm-set-monthday-of (message val) (aset (aref message 3) 2 val)) (defsubst vm-set-month-of (message val) (aset (aref message 3) 3 val)) (defsubst vm-set-year-of (message val) (aset (aref message 3) 4 val)) (defsubst vm-set-hour-of (message val) (aset (aref message 3) 5 val)) (defsubst vm-set-zone-of (message val) (aset (aref message 3) 6 val)) (defsubst vm-set-full-name-of (message author) (aset (aref message 3) 7 author)) (defsubst vm-set-from-of (message author) (aset (aref message 3) 8 author)) (defsubst vm-set-message-id-of (message id) (aset (aref message 3) 9 id)) (defsubst vm-set-line-count-of (message count) (aset (aref message 3) 10 count)) (defsubst vm-set-subject-of (message subject) (aset (aref message 3) 11 subject)) (defsubst vm-set-vheaders-regexp-of (message regexp) (aset (aref message 3) 12 regexp)) (defsubst vm-set-to-of (message recips) (aset (aref message 3) 13 recips)) (defsubst vm-set-to-names-of (message recips) (aset (aref message 3) 14 recips)) (defsubst vm-set-month-number-of (message val) (aset (aref message 3) 15 val)) (defsubst vm-set-sortable-datestring-of (message val) (aset (aref message 3) 16 val)) (defsubst vm-set-sortable-subject-of (message val) (aset (aref message 3) 17 val)) (defsubst vm-set-summary-of (message val) (aset (aref message 3) 18 val)) (defsubst vm-set-parent-of (message val) (aset (aref message 3) 19 val)) (defsubst vm-set-references-of (message val) (aset (aref message 3) 20 val)) (defsubst vm-set-headers-to-be-retrieved-of (message val) nil) (defsubst vm-set-body-to-be-discarded-of (message val) (aset (aref message 3) 21 val)) (defsubst vm-set-body-to-be-retrieved-of (message val) (aset (aref message 3) 22 val)) (defsubst vm-set-pop-uidl-of (message val) (aset (aref message 3) 23 val)) (defsubst vm-set-imap-uid-of (message val) (aset (aref message 3) 23 val)) (defsubst vm-set-imap-uid-validity-of (message val) (aset (aref message 3) 24 val)) (defsubst vm-set-spam-score-of (message val) (aset (aref message 3) 25 val)) (defsubst vm-set-edit-buffer-of (message buf) (aset (aref message 4) 0 buf)) (defsubst vm-set-virtual-messages-of (message list) (set (aref (aref message 4) 1) list)) (defsubst vm-set-virtual-messages-sym-of (message sym) (aset (aref message 4) 1 sym)) (defsubst vm-set-stuff-flag-of (message val) (aset (aref message 4) 2 val)) (defsubst vm-set-labels-of (message labels) (aset (aref message 4) 3 labels)) (defsubst vm-set-label-string-of (message string) (aset (aref message 4) 4 string)) (defsubst vm-set-attribute-modflag-of (message flag) (aset (aref message 4) 5 flag)) (defun vm-mime-encode-words-in-cache-vector (vector) (let ((new-vector (make-vector vm-cached-data-vector-length nil))) ;; Encode the fields of the original cache-vector as necessary. ;; Some of the fields have been mime-decoded with text properties. ;; And, some haven't. ;; This is a mess. ;; Others probably don't need any mime-encoding, but we encode ;; them anyway for safety. ;; byte-count (aset new-vector 0 (aref vector 0)) ;; weekday (aset new-vector 1 (vm-mime-encode-words-in-string (aref vector 1))) ;; monthday (aset new-vector 2 (vm-mime-encode-words-in-string (aref vector 2))) ;; month (aset new-vector 3 (vm-mime-encode-words-in-string (aref vector 3))) ;; year (aset new-vector 4 (vm-mime-encode-words-in-string (aref vector 4))) ;; hour (aset new-vector 5 (vm-mime-encode-words-in-string (aref vector 5))) ;; zone (aset new-vector 6 (vm-mime-encode-words-in-string (aref vector 6))) ;; full-name (aset new-vector 7 (vm-reencode-mime-encoded-words-in-string (aref vector 7))) ;; from (aset new-vector 8 (vm-reencode-mime-encoded-words-in-string (aref vector 8))) ;; message-id (aset new-vector 9 (vm-reencode-mime-encoded-words-in-string (aref vector 9))) ;; line-count (aset new-vector 10 (vm-mime-encode-words-in-string (aref vector 10))) ;; subject (aset new-vector 11 (vm-reencode-mime-encoded-words-in-string (aref vector 11))) ;; vheaders-regexp (aset new-vector 12 (vm-mime-encode-words-in-string (aref vector 12))) ;; to (aset new-vector 13 (vm-reencode-mime-encoded-words-in-string (aref vector 13))) ;; to-names (aset new-vector 14 (vm-reencode-mime-encoded-words-in-string (aref vector 14))) ;; month-number (aset new-vector 15 (vm-mime-encode-words-in-string (aref vector 15))) ;; sortable-date-string (aset new-vector 16 (vm-reencode-mime-encoded-words-in-string (aref vector 16))) ;; sortable-subject (aset new-vector 17 (vm-reencode-mime-encoded-words-in-string (aref vector 17))) ;; summary (aset new-vector 18 (vm-reencode-mime-encoded-words-in-tokenized-summary (aref vector 18))) ;; parent (aset new-vector 19 (vm-reencode-mime-encoded-words-in-string (aref vector 19))) ;; references (aset new-vector 20 (mapcar (function vm-reencode-mime-encoded-words-in-string) (aref vector 20))) ;; body-to-be-discarded (formerly headers-to-be-retrieved) (aset new-vector 21 (aref vector 21)) ;; body-to-be-retrieved (aset new-vector 22 (aref vector 22)) ;; pop-uidl or imap-uid (aset new-vector 23 (vm-mime-encode-words-in-string (aref vector 23))) ;; imap-uid-validity (aset new-vector 24 (vm-mime-encode-words-in-string (aref vector 24))) ;; spam-score is a number. nothing to do new-vector)) (defun vm-make-message () "Create a new blank message struct." (let ((mvec (make-vector 5 nil)) sym) (vm-set-softdata-of mvec (make-vector vm-softdata-vector-length nil)) (vm-set-location-data-of mvec (make-vector vm-location-data-vector-length nil)) (vm-set-mirror-data-of mvec (make-vector vm-mirror-data-vector-length nil)) (vm-set-message-id-number-of mvec (int-to-string vm-message-id-number)) (vm-increment vm-message-id-number) (vm-set-buffer-of mvec (current-buffer)) ;; We use an uninterned symbol here as a level of indirection ;; from a purely self-referential structure. This is ;; necessary so that Emacs debugger can be used on this ;; program. (setq sym (make-symbol "<<>>")) (set sym mvec) (vm-set-real-message-sym-of mvec sym) (vm-set-mirrored-message-sym-of mvec sym) ;; Another uninterned symbol for the virtual messages list. (setq sym (make-symbol "")) (set sym nil) (vm-set-virtual-messages-sym-of mvec sym) ;; Another uninterned symbol for the reverse link ;; into the message list. (setq sym (make-symbol "<--")) (vm-set-reverse-link-sym-of mvec sym) mvec )) (defun vm-find-and-set-text-of (m) (save-excursion (set-buffer (vm-buffer-of m)) (save-restriction (widen) (goto-char (vm-headers-of m)) (search-forward "\n\n" (vm-text-end-of m) 0) (vm-set-text-of m (point-marker))))) (defsubst vm-virtual-message-p (m) (not (eq m (vm-real-message-of m)))) (defun* vm-update-virtual-messages (m &key message-changing) "Update all the virtual messages of M to reflect the changes made to the headers/body of M." (save-excursion (mapc (lambda (v-m) (vm-set-mime-layout-of v-m nil) (vm-set-mime-encoded-header-flag-of v-m nil) (vm-set-line-count-of v-m nil) (when (buffer-name (vm-buffer-of v-m)) (set-buffer (vm-buffer-of v-m)) (if (and vm-presentation-buffer (eq (car vm-message-pointer) v-m)) (save-excursion (vm-present-current-message))) (when (vectorp vm-thread-obarray) ;; this was changed from v-m to m in revision 1148, but it ;; doesn't make sense. USR, 2011-04-28 (vm-unthread-message v-m :message-changing message-changing) (vm-build-threads (list v-m))) ;; (if vm-summary-show-threads ;; (intern (buffer-name) buffers-needing-thread-sort)) )) (vm-virtual-messages-of m)))) (defun vm-pp-message (m) (pp (vector ':location-data (vm-zip-vectors vm-location-data-fields (vm-location-data-of m)) ':softdata (vm-zip-vectors vm-softdata-fields (vm-softdata-of m)) ':attributes (vm-zip-vectors vm-attributes-fields (vm-attributes-of m)) ':cached-data (vm-zip-vectors vm-cached-data-fields (vm-cached-data-of m)) ':mirror-data (vm-zip-vectors vm-mirror-data-fields (vm-mirror-data-of m)))) nil) ;;; vm-message.el ends here vm-8.2.0b/lisp/vm-misc.el0000755000175000017500000016175611676442160015455 0ustar srivastasrivasta;;; vm-misc.el --- Miscellaneous functions for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-misc) ;; (eval-when-compile ;; (require 'vm-misc)) ;; vm-xemacs.el is a fake file to fool the Emacs 23 compiler (declare-function find-coding-system "vm-xemacs" (coding-system-or-name)) ;; Aliases for xemacs functions (declare-function xemacs-abbreviate-file-name "vm-misc.el" (filename &optional hack-homedir)) (declare-function xemacs-insert-char "vm-misc.el" (char &optional count ignored buffer)) ;; Aliases for xemacs/fsfemacs functions with different arguments (declare-function emacs-find-file-name-handler "vm-misc.el" (filename &optional operation)) (declare-function emacs-focus-frame "vm-misc.el" (&rest ignore)) (declare-function emacs-get-buffer-window "vm-misc.el" (&optional buffer-or-name frame devices)) (declare-function vm-interactive-p "vm-misc.el" ()) (declare-function vm-device-type "vm-misc.el" (&optional device)) (declare-function vm-buffer-substring-no-properties "vm-misc.el" (start end)) (declare-function substring-no-properties "vm-misc.el" (string from &optional to)) (declare-function vm-extent-property "vm-misc.el" (overlay prop) t) (declare-function vm-extent-object "vm-misc.el" (overlay) t) (declare-function vm-set-extent-property "vm-misc.el" (overlay prop value) t) (declare-function vm-set-extent-endpoints "vm-misc.el" (overlay beg end &optional buffer) t) (declare-function vm-make-extent "vm-misc.el" (beg end &optional buffer front-advance rear-advance) t) (declare-function vm-extent-end-position "vm-misc.el" (overlay) t) (declare-function vm-extent-start-position "vm-misc.el" (overlay) t) (declare-function vm-detach-extent "vm-misc.el" (overlay) t) (declare-function vm-delete-extent "vm-misc.el" (overlay) t) (declare-function vm-disable-extents "vm-misc.el" (&optional beg end name val) t) (declare-function vm-extent-properties "vm-misc.el" (overlay) t) (declare-function timezone-make-date-sortable "ext:timezone" (date &optional local timezone)) (declare-function longlines-decode-region "ext:longlines" (start end)) (declare-function longlines-wrap-region "ext:longlines" (start end)) (declare-function vm-decode-mime-encoded-words "vm-mime" ()) (declare-function vm-decode-mime-encoded-words-in-string "vm-mime" (string)) (declare-function vm-su-subject "vm-summary" (message)) ;; This file contains various low-level operations that address ;; incomaptibilities between Gnu and XEmacs. Expect compiler warnings. ;; messages in the minibuffer ;; the chattiness levels are: ;; 0 - extremely quiet ;; 5 - medium ;; 7 - normal level ;; 10 - heavy debugging info (defun vm-inform (level &rest args) (when (<= level vm-verbosity) (apply 'message args))) (defun vm-warn (l secs &rest args) "Give a warning at level L and display it for SECS seconds. The remaining arguments are passed to `message' to generate the warning message." (when (<= l vm-verbosity) (apply 'message args) (sleep-for secs))) ;; garbage-collector result (defconst gc-fields '(:conses :syms :miscs :chars :vector :floats :intervals :strings)) (defsubst vm-garbage-collect () (pp (vm-zip-lists gc-fields (garbage-collect)))) ;; Make sure that interprogram-cut-function is defined (unless (boundp 'interprogram-cut-function) (defvar interprogram-cut-function nil)) (defun vm-substring (string from &optional to) (let ((work-buffer nil)) (set-buffer work-buffer) (unwind-protect (with-current-buffer work-buffer (insert string) (if (null to) (setq to (length string)) (if (< to 0) (setq to (+ (length string) to)))) ;; string indices start at 0, buffers start at 1. (setq from (1+ from) to (1+ to)) (if (> from (point-min)) (delete-region (point-min) from)) (if (< to (point-max)) (delete-region to (point-max))) (buffer-string)) (when work-buffer (kill-buffer work-buffer))))) ;; Taken from XEmacs as GNU Emacs is missing `replace-in-string' and defining ;; it may cause clashes with other packages defining it differently, in fact ;; we could also call the function `replace-regexp-in-string' as Roland ;; Winkler pointed out. (defun vm-replace-in-string (str regexp newtext &optional literal) "Replace all matches in STR for REGEXP with NEWTEXT string, and returns the new string. Optional LITERAL non-nil means do a literal replacement. Otherwise treat `\\' in NEWTEXT as special: `\\&' in NEWTEXT means substitute original matched text. `\\N' means substitute what matched the Nth `\\(...\\)'. If Nth parens didn't match, substitute nothing. `\\\\' means insert one `\\'. `\\u' means upcase the next character. `\\l' means downcase the next character. `\\U' means begin upcasing all following characters. `\\L' means begin downcasing all following characters. `\\E' means terminate the effect of any `\\U' or `\\L'." (if (> (length str) 50) (let ((cfs case-fold-search)) (with-temp-buffer (setq case-fold-search cfs) (insert str) (goto-char 1) (while (re-search-forward regexp nil t) (replace-match newtext t literal)) (buffer-string))) (let ((start 0) newstr) (while (string-match regexp str start) (setq newstr (replace-match newtext t literal str) start (+ (match-end 0) (- (length newstr) (length str))) str newstr)) str))) (defun vm-delete-non-matching-strings (regexp list &optional destructively) "Delete strings matching REGEXP from LIST. Optional third arg non-nil means to destructively alter LIST, instead of working on a copy. The new version of the list, minus the deleted strings, is returned." (or destructively (setq list (copy-sequence list))) (let ((curr list) (prev nil)) (while curr (if (string-match regexp (car curr)) (setq prev curr curr (cdr curr)) (if (null prev) (setq list (cdr list) curr list) (setcdr prev (cdr curr)) (setq curr (cdr curr))))) list )) (defun vm-parse (string regexp &optional matchn matches) "Returns list of string by splitting STRING with REGEXP matches. REGEXP must match one item and MATCHN can be used to select a match group (default is 1). MATCHES is the number of time the match is applied (default until it does not match anymore). This function is similar to a spring-split, but a bit more complex and flexible." (or matchn (setq matchn 1)) (let (list tem) (store-match-data nil) (while (and (not (eq matches 0)) (not (eq (match-end 0) (length string))) (string-match regexp string (match-end 0))) (and (integerp matches) (setq matches (1- matches))) (if (not (consp matchn)) (setq list (cons (substring string (match-beginning matchn) (match-end matchn)) list)) (setq tem matchn) (while tem (if (match-beginning (car tem)) (setq list (cons (substring string (match-beginning (car tem)) (match-end (car tem))) list) tem nil) (setq tem (cdr tem)))))) (if (and (integerp matches) (match-end 0) (not (eq (match-end 0) (length string)))) (setq list (cons (substring string (match-end 0) (length string)) list))) (nreverse list))) (defun vm-parse-addresses (string) "Given a STRING containing email addresses extracted from a header field, parse it and return a list of individual email addresses." (if (null string) () (let ((work-buffer (vm-make-multibyte-work-buffer))) (with-current-buffer work-buffer (unwind-protect (let (list start s char) (insert string) (goto-char (point-min)) ;; Remove useless white space TX (while (re-search-forward "[\t\f\n\r]\\{1,\\}" nil t) (replace-match " ")) (goto-char (point-min)) (skip-chars-forward " \t\f\n\r") (setq start (point)) (while (not (eobp)) (skip-chars-forward "^\"\\\\,(") (setq char (following-char)) (cond ((= char ?\\) (forward-char 1) (if (not (eobp)) (forward-char 1))) ((= char ?,) (setq s (buffer-substring start (point))) (if (or (null (string-match "^[ \t\f\n\r]+$" s)) (not (string= s ""))) (setq list (cons s list))) (skip-chars-forward ", \t\f\n\r") (setq start (point))) ((= char ?\") (re-search-forward "[^\\\\]\"" nil 0)) ((= char ?\() (let ((parens 1)) (forward-char 1) (while (and (not (eobp)) (not (zerop parens))) (re-search-forward "[()]" nil 0) (cond ((or (eobp) (= (char-after (- (point) 2)) ?\\))) ((= (preceding-char) ?\() (setq parens (1+ parens))) (t (setq parens (1- parens))))))))) (setq s (buffer-substring start (point))) (if (and (null (string-match "^[ \t\f\n\r]+$" s)) (not (string= s ""))) (setq list (cons s list))) (mapcar 'vm-fix-quoted-address (reverse list))) (and work-buffer (kill-buffer work-buffer))))))) (defun vm-fix-quoted-address (a) "Sometimes there are qp-encoded addresses not quoted by \" and thus we need to add quotes or leave them undecoded. RWF" (let ((da (vm-decode-mime-encoded-words-in-string a))) (if (string= da a) a (if (or (string-match "^\\s-*\\([^\"']*,[^\"']*\\)\\b\\s-*\\(<.*\\)" da) (string-match "^\\s-*\"'\\([^\"']+\\)'\"\\(.*\\)" da)) (concat "\"" (match-string 1 da) "\" " (match-string 2 da)) da)))) (make-obsolete 'vmrf-fix-quoted-address 'vm-quoted-address "8.2.0") (defun vm-parse-structured-header (string &optional sepchar keep-quotes) (if (null string) () (let ((work-buffer (vm-make-work-buffer))) (buffer-disable-undo work-buffer) (with-current-buffer work-buffer (unwind-protect (let ((list nil) (nonspecials "^\"\\\\( \t\n\r\f") start s char sp+sepchar) (if sepchar (setq nonspecials (concat nonspecials (list sepchar)) sp+sepchar (concat "\t\f\n\r " (list sepchar)))) (insert string) (goto-char (point-min)) (skip-chars-forward "\t\f\n\r ") (setq start (point)) (while (not (eobp)) (skip-chars-forward nonspecials) (setq char (following-char)) (cond ((looking-at "[ \t\n\r\f]") (delete-char 1)) ((= char ?\\) (forward-char 1) (if (not (eobp)) (forward-char 1))) ((and sepchar (= char sepchar)) (setq s (buffer-substring start (point))) (if (or (null (string-match "^[\t\f\n\r ]+$" s)) (not (string= s ""))) (setq list (cons s list))) (skip-chars-forward sp+sepchar) (setq start (point))) ((looking-at " \t\n\r\f") (skip-chars-forward " \t\n\r\f")) ((= char ?\") (let ((done nil)) (if keep-quotes (forward-char 1) (delete-char 1)) (while (not done) (if (null (re-search-forward "[\\\\\"]" nil t)) (setq done t) (setq char (char-after (1- (point)))) (cond ((char-equal char ?\\) (delete-char -1) (if (eobp) (setq done t) (forward-char 1))) (t (if (not keep-quotes) (delete-char -1)) (setq done t))))))) ((= char ?\() (let ((done nil) (pos (point)) (parens 1)) (forward-char 1) (while (not done) (if (null (re-search-forward "[\\\\()]" nil t)) (setq done t) (setq char (char-after (1- (point)))) (cond ((char-equal char ?\\) (if (eobp) (setq done t) (forward-char 1))) ((char-equal char ?\() (setq parens (1+ parens))) (t (setq parens (1- parens) done (zerop parens)))))) (delete-region pos (point)))))) (setq s (buffer-substring start (point))) (if (and (null (string-match "^[\t\f\n\r ]+$" s)) (not (string= s ""))) (setq list (cons s list))) (nreverse list)) (and work-buffer (kill-buffer work-buffer))))))) (defvar buffer-file-type) (defun vm-write-string (where string) (if (bufferp where) (vm-save-buffer-excursion (set-buffer where) (goto-char (point-max)) (let ((buffer-read-only nil)) (insert string))) (let ((temp-buffer (generate-new-buffer "*vm-work*"))) (unwind-protect (with-current-buffer temp-buffer (setq selective-display nil) (insert string) ;; correct for VM's uses of this function--- ;; writing out message separators (setq buffer-file-type nil) (write-region (point-min) (point-max) where t 'quiet)) (and temp-buffer (kill-buffer temp-buffer)))))) (defun vm-check-for-killed-summary () "If the current folder's summary buffer has been killed, reset the vm-summary-buffer variable and all the summary markers in the folder so that it remains a valid folder. Take care of vm-folders-summary-buffer in a similar way." (and (bufferp vm-summary-buffer) (null (buffer-name vm-summary-buffer)) (let ((mp vm-message-list)) (setq vm-summary-buffer nil) (while mp (vm-set-su-start-of (car mp) nil) (vm-set-su-end-of (car mp) nil) (setq mp (cdr mp))))) (and (bufferp vm-folders-summary-buffer) (null (buffer-name vm-folders-summary-buffer)) (setq vm-folders-summary-buffer nil))) (defun vm-check-for-killed-presentation () "If the current folder's Presentation buffer has been killed, reset the vm-presentation-buffer variable." (and (bufferp vm-presentation-buffer-handle) (null (buffer-name vm-presentation-buffer-handle)) (progn (setq vm-presentation-buffer-handle nil vm-presentation-buffer nil)))) ;;;###autoload (defun vm-check-for-killed-folder () "If the current buffer's Folder buffer has been killed, reset the vm-mail-buffer variable." (and (bufferp vm-mail-buffer) (null (buffer-name vm-mail-buffer)) (setq vm-mail-buffer nil))) (put 'folder-read-only 'error-conditions '(folder-read-only error)) (put 'folder-read-only 'error-message "Folder is read-only") (defun vm-abs (n) (if (< n 0) (- n) n)) (defun vm-last (list) "Return the last cons-cell of LIST." (while (cdr-safe list) (setq list (cdr list))) list) (defun vm-last-elem (list) "Return the last element of LIST." (while (cdr-safe list) (setq list (cdr list))) (car list)) (defun vm-vector-to-list (vector) (let ((i (1- (length vector))) list) (while (>= i 0) (setq list (cons (aref vector i) list)) (vm-decrement i)) list )) (defun vm-extend-vector (vector length &optional fill) (let ((vlength (length vector))) (if (< vlength length) (apply 'vector (nconc (vm-vector-to-list vector) (make-list (- length vlength) fill))) vector ))) (defun vm-obarray-to-string-list (blobarray) (let ((list nil)) (mapatoms (function (lambda (s) (setq list (cons (symbol-name s) list)))) blobarray) list )) (defun vm-zip-vectors (v1 v2) (if (= (length v1) (length v2)) (let ((l1 (append v1 nil)) (l2 (append v2 nil))) (vconcat (vm-zip-lists l1 l2))) (error "Attempt to zip vectors of differing length: %s and %s" (length v1) (length v2)))) (defun vm-zip-lists (l1 l2) (cond ((or (null l1) (null l2)) (if (and (null l1) (null l2)) nil (error "Attempt to zip lists of differing length"))) (t (cons (car l1) (cons (car l2) (vm-zip-lists (cdr l1) (cdr l2))))) )) (defun vm-mapvector (proc vec) (let ((new-vec (make-vector (length vec) nil)) (i 0) (n (length vec))) (while (< i n) (aset new-vec i (apply proc (aref vec i) nil)) (setq i (1+ i))) new-vec)) (defun vm-mapcar (function &rest lists) "Apply function to all the curresponding elements of the remaining argument lists. The results are gathered into a list and returned. All the argument lists should be of the same length for this to be well-behaved." (let (arglist result) (while (car lists) (setq arglist (mapcar 'car lists)) (setq result (cons (apply function arglist) result)) (setq lists (mapcar 'cdr lists))) (nreverse result))) (defun vm-mapc (proc &rest lists) "Apply PROC to all the corresponding elements of the remaining argument lists. Discard any results. All the argument lists should be of the same length for this to be well-behaved." (let (arglist) (while (car lists) (setq arglist (mapcar 'car lists)) (apply proc arglist) (setq lists (mapcar 'cdr lists))))) (defun vm-delete (predicate list &optional retain) "Delete all elements satisfying PREDICATE from LIST and return the resulting list. If optional argument RETAIN is t, then retain all elements that satisfy PREDICATE rather than deleting them. The original LIST is permanently modified." (let ((p list) (retain (if retain 'not 'identity)) prev) (while p (if (funcall retain (funcall predicate (car p))) (if (null prev) (setq list (cdr list) p list) (setcdr prev (cdr p)) (setq p (cdr p))) (setq prev p p (cdr p)))) list )) (defun vm-elems (n list) "Select the first N elements of LIST and return them as a list." (let (res) (while (and list (> n 0)) (setq res (cons (car list) res)) (setq list (cdr list)) (setq n (1- n))) (nreverse res))) (defun vm-find (list pred) "Find the first element of LIST satisfying PRED and return the position" (let ((n 0)) (while (and list (not (apply pred (car list) nil))) (setq list (cdr list)) (setq n (1+ n))) (if list n nil))) (defun vm-find-all (list pred) "Find all the elements of LIST satisfying PRED" (let ((n 0) (res nil)) (while list (when (apply pred (car list) nil) (setq res (cons (car list) res))) (setq list (cdr list)) (setq n (1+ n))) (nreverse res))) (defun vm-find2 (list1 list2 pred) "Find the first pair of elements of LIST1 and LIST2 satisfying PRED and return the position" (let ((n 0)) (while (and list1 list2 (not (apply pred (car list1) (car list2) nil))) (setq list1 (cdr list2) list2 (cdr list2)) (setq n (1+ n))) (if (and list1 list2) n nil))) (defun vm-elems-of (list) "Return the set of elements of LIST as a list." (let ((res nil)) (while list (unless (member (car list) res) (setq res (cons (car list) res))) (setq list (cdr list))) (nreverse res))) (defun vm-for-all (list pred) (catch 'fail (progn (while list (if (apply pred (car list) nil) (setq list (cdr list)) (throw 'fail nil))) t))) (fset 'vm-interactive-p (if (fboundp 'interactive-p) ; Xemacs or Gnu Emacs under obsolescence 'interactive-p (lambda () (called-interactively-p 'any)))) (fset 'vm-device-type (cond (vm-xemacs-p 'device-type) (vm-fsfemacs-p 'vm-fsfemacs-device-type))) (defun vm-fsfemacs-device-type (&optional device) "An FSF Emacs emulation for XEmacs `device-type' function. Returns the type of the current screen device: one of 'x, 'gtk, 'w32, 'ns and 'pc. The optional argument DEVICE is ignored." (if (eq window-system 'x) (if (featurep 'gtk) 'gtk) window-system)) (defun vm-generate-new-unibyte-buffer (name) (if vm-xemacs-p (generate-new-buffer name) (let* (;; (default-enable-multibyte-characters nil) ;; don't need this because of set-buffer-multibyte below (buffer (generate-new-buffer name))) (when (fboundp 'set-buffer-multibyte) (with-current-buffer buffer (set-buffer-multibyte nil))) buffer))) (defun vm-generate-new-multibyte-buffer (name) (if vm-xemacs-p (generate-new-buffer name) (let* (;; (default-enable-multibyte-characters t) ;; don't need this because of set-buffer-multibyte below (buffer (generate-new-buffer name))) (if (fboundp 'set-buffer-multibyte) (with-current-buffer buffer (set-buffer-multibyte t)) ;; This error checking only works on FSF (with-current-buffer buffer (unless enable-multibyte-characters (error "VM internal error #1922: buffer is not multibyte")))) buffer))) (defun vm-make-local-hook (hook) (if (fboundp 'make-local-hook) ; Emacs/XEmacs 21 (make-local-hook hook))) (fset 'xemacs-abbreviate-file-name 'abbreviate-file-name) (defun vm-abbreviate-file-name (path) (if vm-xemacs-p (xemacs-abbreviate-file-name path t) (abbreviate-file-name path))) (fset 'emacs-find-file-name-handler 'find-file-name-handler) (defun vm-find-file-name-handler (filename operation) (if (fboundp 'find-file-name-handler) (condition-case () (emacs-find-file-name-handler filename operation) (wrong-number-of-arguments (emacs-find-file-name-handler filename))) nil)) (fset 'emacs-focus-frame 'focus-frame) (defun vm-select-frame-set-input-focus (frame) (if (fboundp 'select-frame-set-input-focus) ;; defined in FSF Emacs 22.1 (select-frame-set-input-focus frame) (select-frame frame) (emacs-focus-frame frame) (raise-frame frame))) (fset 'emacs-get-buffer-window 'get-buffer-window) (defun vm-get-buffer-window (buffer &optional which-frames which-devices) (condition-case nil ; try XEmacs (or (emacs-get-buffer-window buffer which-frames which-devices) (and vm-search-other-frames (emacs-get-buffer-window buffer t t))) (wrong-number-of-arguments (condition-case nil ; try recent Gnu Emacs (or (emacs-get-buffer-window buffer which-frames) (and vm-search-other-frames (emacs-get-buffer-window buffer t))) (wrong-number-of-arguments ; baseline old Emacs (emacs-get-buffer-window buffer)))))) (defun vm-get-visible-buffer-window (buffer &optional which-frames which-devices) (condition-case nil (or (emacs-get-buffer-window buffer which-frames which-devices) (and vm-search-other-frames (emacs-get-buffer-window buffer t which-devices))) (wrong-number-of-arguments (condition-case nil (or (emacs-get-buffer-window buffer which-frames) (and vm-search-other-frames (get-buffer-window buffer 'visible))) (wrong-number-of-arguments (emacs-get-buffer-window buffer)))))) (defun vm-force-mode-line-update () "Force a mode line update in all frames." (if (fboundp 'force-mode-line-update) (force-mode-line-update t) (with-current-buffer (other-buffer) (set-buffer-modified-p (buffer-modified-p))))) (defun vm-delete-directory-file-names (list) (vm-delete 'file-directory-p list)) (defun vm-delete-backup-file-names (list) (vm-delete 'backup-file-name-p list)) (defun vm-delete-auto-save-file-names (list) (vm-delete 'auto-save-file-name-p list)) (defun vm-delete-index-file-names (list) (vm-delete 'vm-index-file-name-p list)) (defun vm-delete-directory-names (list) (vm-delete 'file-directory-p list)) (defun vm-index-file-name-p (file) (and (file-regular-p file) (stringp vm-index-file-suffix) (let ((str (concat (regexp-quote vm-index-file-suffix) "$"))) (string-match str file)) t )) (defun vm-delete-duplicates (list &optional all hack-addresses) "Delete duplicate equivalent strings from the list. If ALL is t, then if there is more than one occurrence of a string in the list, then all occurrences of it are removed instead of just the subsequent ones. If HACK-ADDRESSES is t, then the strings are considered to be mail addresses, and only the address part is compared (so that \"Name \" and \"foo\" would be considered to be equivalent.)" (let ((hashtable vm-delete-duplicates-obarray) (new-list nil) sym-string sym) (fillarray hashtable 0) (while list (setq sym-string (if hack-addresses (nth 1 (funcall vm-chop-full-name-function (car list))) (car list)) sym-string (or sym-string "-unparseable-garbage-") sym (intern (if hack-addresses (downcase sym-string) sym-string) hashtable)) (if (boundp sym) (and all (setcar (symbol-value sym) nil)) (setq new-list (cons (car list) new-list)) (set sym new-list)) (setq list (cdr list))) (delq nil (nreverse new-list)))) (defun vm-member-0 (thing list) (catch 'done (while list (and (equal (car list) thing) (throw 'done list)) (setq list (cdr list))) nil )) (fset 'vm-member (symbol-function (if (fboundp 'member) 'member 'vm-member-0))) (defun vm-delqual (ob list) (let ((prev nil) (curr list)) (while curr (if (not (equal ob (car curr))) (setq prev curr curr (cdr curr)) (if (null prev) (setq list (cdr list) curr list) (setq curr (cdr curr)) (setcdr prev curr)))) list )) (defun vm-copy-local-variables (buffer &rest variables) (let ((values (mapcar 'symbol-value variables))) (with-current-buffer buffer (vm-mapc 'set variables values)))) (put 'folder-empty 'error-conditions '(folder-empty error)) (put 'folder-empty 'error-message "Folder is empty") (put 'unrecognized-folder-type 'error-conditions '(unrecognized-folder-type error)) (put 'unrecognized-folder-type 'error-message "Unrecognized folder type") (defun vm-error-if-folder-empty () (while (null vm-message-list) (if vm-folder-type (signal 'unrecognized-folder-type nil) (signal 'folder-empty nil)))) (defun vm-copy (object) "Make a copy of OBJECT, which could be a list, vector, string or marker." (cond ((consp object) (let (return-value cons) (setq return-value (cons (vm-copy (car object)) nil) cons return-value object (cdr object)) (while (consp object) (setcdr cons (cons (vm-copy (car object)) nil)) (setq cons (cdr cons) object (cdr object))) (setcdr cons object) return-value )) ((vectorp object) (apply 'vector (mapcar 'vm-copy object))) ((stringp object) (copy-sequence object)) ((markerp object) (copy-marker object)) (t object))) (defun vm-run-hook-on-message (hook-variable message) (with-current-buffer (vm-buffer-of message) (vm-save-restriction (widen) (save-excursion (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) (run-hooks hook-variable))))) (defun vm-run-message-hook (message hook-variable) (vm-run-hook-on-message hook-variable message)) (make-obsolete 'vm-run-message-hook 'vm-run-hook-on-message "8.2.0") (defun vm-run-hook-on-message-with-args (hook-variable message &rest args) (with-current-buffer (vm-buffer-of message) (vm-save-restriction (widen) (save-excursion (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) (apply 'run-hook-with-args hook-variable args))))) (defun vm-run-message-hook-with-args (message hook-variable &rest args) (apply 'vm-run-hook-on-message-with-args hook-variable message args)) (make-obsolete 'vm-run-message-hook-with-args 'vm-run-hook-on-message-with-args "8.2.0") (defun vm-error-free-call (function &rest args) (condition-case nil (apply function args) (error nil))) (put 'beginning-of-folder 'error-conditions '(beginning-of-folder error)) (put 'beginning-of-folder 'error-message "Beginning of folder") (put 'end-of-folder 'error-conditions '(end-of-folder error)) (put 'end-of-folder 'error-message "End of folder") (defun vm-trace (&rest args) (with-current-buffer (get-buffer-create "*vm-trace*") (apply 'insert args))) (defun vm-timezone-make-date-sortable (string) (or (cdr (assq string vm-sortable-date-alist)) (let ((vect (vm-parse-date string)) (date (vm-parse (current-time-string) " *\\([^ ]+\\)"))) ;; if specified date is incomplete fill in the holes ;; with useful information, defaulting to the current ;; date and timezone for everything except hh:mm:ss which ;; defaults to midnight. (if (equal (aref vect 1) "") (aset vect 1 (nth 2 date))) (if (equal (aref vect 2) "") (aset vect 2 (nth 1 date))) (if (equal (aref vect 3) "") (aset vect 3 (nth 4 date))) (if (equal (aref vect 4) "") (aset vect 4 "00:00:00")) (if (equal (aref vect 5) "") (aset vect 5 (vm-current-time-zone))) ;; save this work so we won't have to do it again (setq vm-sortable-date-alist (cons (cons string (condition-case nil (timezone-make-date-sortable (format "%s %s %s %s %s" (aref vect 1) (aref vect 2) (aref vect 3) (aref vect 4) (aref vect 5))) (error "1970010100:00:00"))) vm-sortable-date-alist)) ;; return result (cdr (car vm-sortable-date-alist))))) (defun vm-current-time-zone () (or (condition-case nil (let* ((zone (car (current-time-zone))) (absmin (/ (vm-abs zone) 60))) (format "%c%02d%02d" (if (< zone 0) ?- ?+) (/ absmin 60) (% absmin 60))) (error nil)) (let ((temp-buffer (vm-make-work-buffer))) (condition-case nil (unwind-protect (with-current-buffer temp-buffer (call-process "date" nil temp-buffer nil) (nth 4 (vm-parse (vm-buffer-string-no-properties) " *\\([^ ]+\\)"))) (and temp-buffer (kill-buffer temp-buffer))) (error nil))) "")) (defun vm-parse-date (date) (let ((weekday "") (monthday "") (month "") (year "") (hour "") (timezone "") (start nil) string (case-fold-search t)) (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date) (setq weekday (substring date (match-beginning 0) (match-end 0)))) (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date) (setq month (substring date (match-beginning 0) (match-end 0)))) (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date) (setq hour (substring date (match-beginning 0) (match-end 0)))) (cond ((string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date) (setq timezone (substring date (1+ (match-beginning 0)) (match-end 0)))) ((or (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date) (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date) (string-match "gmt\\([+---][0-9]+\\)?" date)) (setq timezone (substring date (match-beginning 0) (match-end 0))))) (while (and (or (zerop (length monthday)) (zerop (length year))) (string-match "\\(^\\| \\)\\([0-9]+\\)\\($\\| \\)" date start)) (setq string (substring date (match-beginning 2) (match-end 2)) start (match-end 0)) (cond ((and (zerop (length monthday)) (<= (length string) 2)) (setq monthday string)) ((= (length string) 2) (if (< (string-to-number string) 70) (setq year (concat "20" string)) (setq year (concat "19" string)))) (t (setq year string)))) (aset vm-parse-date-workspace 0 weekday) (aset vm-parse-date-workspace 1 monthday) (aset vm-parse-date-workspace 2 month) (aset vm-parse-date-workspace 3 year) (aset vm-parse-date-workspace 4 hour) (aset vm-parse-date-workspace 5 timezone) vm-parse-date-workspace)) (defun vm-should-generate-summary () (cond ((eq vm-startup-with-summary t) t) ((integerp vm-startup-with-summary) (let ((n vm-startup-with-summary)) (cond ((< n 0) (null (nth (vm-abs n) vm-message-list))) ((= n 0) nil) (t (nth (1- n) vm-message-list))))) (vm-startup-with-summary t) (t nil))) (defun vm-find-composition-buffer (&optional not-picky) (let ((b-list (buffer-list)) choice alternate) (save-excursion (while b-list (set-buffer (car b-list)) (if (eq major-mode 'mail-mode) (if (buffer-modified-p) (setq choice (current-buffer) b-list nil) (and not-picky (null alternate) (setq alternate (current-buffer))) (setq b-list (cdr b-list))) (setq b-list (cdr b-list)))) (or choice alternate)))) (defun vm-get-file-buffer (file) "Like get-file-buffer, but also checks buffers against FILE's truename" (or (get-file-buffer file) (and (fboundp 'file-truename) (get-file-buffer (file-truename file))) (and (fboundp 'find-buffer-visiting) (find-buffer-visiting file)))) ;; The following function is not working correctly on Gnu Emacs 23. ;; So we do it ourselves. (defun vm-delete-auto-save-file-if-necessary () (if vm-xemacs-p (delete-auto-save-file-if-necessary) (when (and buffer-auto-save-file-name delete-auto-save-files (not (string= buffer-file-name buffer-auto-save-file-name)) (file-newer-than-file-p buffer-auto-save-file-name buffer-file-name)) (condition-case () (if (save-window-excursion (with-output-to-temp-buffer "*Directory*" (buffer-disable-undo standard-output) (save-excursion (let ((switches dired-listing-switches) (file buffer-file-name) (save-file buffer-auto-save-file-name)) (if (file-symlink-p buffer-file-name) (setq switches (concat switches "L"))) (set-buffer standard-output) ;; Use insert-directory-safely, not insert-directory, ;; because these files might not exist. In particular, ;; FILE might not exist if the auto-save file was for ;; a buffer that didn't visit a file, such as "*mail*". ;; The code in v20.x called `ls' directly, so we need ;; to emulate what `ls' did in that case. (insert-directory-safely save-file switches) (insert-directory-safely file switches)))) (yes-or-no-p (format "Delete auto save file %s? " buffer-auto-save-file-name))) (delete-file buffer-auto-save-file-name)) (file-error nil)) (set-buffer-auto-saved)))) (defun vm-set-region-face (start end face) (let ((e (vm-make-extent start end))) (vm-set-extent-property e 'face face))) (fset 'vm-xemacs-set-face-foreground (function set-face-foreground)) (fset 'vm-fsfemacs-set-face-foreground (function set-face-foreground)) (fset 'vm-xemacs-set-face-background (function set-face-background)) (fset 'vm-fsfemacs-set-face-background (function set-face-background)) (defun vm-default-buffer-substring-no-properties (beg end &optional buffer) (let ((s (if buffer (with-current-buffer buffer (buffer-substring beg end)) (buffer-substring beg end)))) (set-text-properties 0 (length s) nil s) (copy-sequence s))) (fset 'vm-buffer-substring-no-properties (cond ((fboundp 'buffer-substring-no-properties) (function buffer-substring-no-properties)) (vm-xemacs-p (function buffer-substring)) (t (function vm-default-buffer-substring-no-properties)))) (defun vm-buffer-string-no-properties () (vm-buffer-substring-no-properties (point-min) (point-max))) (fset 'vm-substring-no-properties (cond ((fboundp 'substring-no-properties) (function substring-no-properties)) (t (function substring)))) (defun vm-insert-region-from-buffer (buffer &optional start end) (let ((target-buffer (current-buffer))) (set-buffer buffer) (save-restriction (widen) (or start (setq start (point-min))) (or end (setq end (point-max))) (set-buffer target-buffer) (insert-buffer-substring buffer start end) (set-buffer buffer)) (set-buffer target-buffer))) (if (not (fboundp 'vm-extent-property)) (if vm-fsfemacs-p (fset 'vm-extent-property 'overlay-get) (fset 'vm-extent-property 'extent-property))) (if (not (fboundp 'vm-extent-object)) (if vm-fsfemacs-p (fset 'vm-extent-object 'overlay-buffer) (fset 'vm-extent-object 'extent-object))) (if (not (fboundp 'vm-set-extent-property)) (if vm-fsfemacs-p (fset 'vm-set-extent-property 'overlay-put) (fset 'vm-set-extent-property 'set-extent-property))) (if (not (fboundp 'vm-set-extent-endpoints)) (if vm-fsfemacs-p (fset 'vm-set-extent-endpoints 'move-overlay) (fset 'vm-set-extent-endpoints 'set-extent-endpoints))) (if (not (fboundp 'vm-make-extent)) (if vm-fsfemacs-p (fset 'vm-make-extent 'make-overlay) (fset 'vm-make-extent 'make-extent))) (if (not (fboundp 'vm-extent-end-position)) (if vm-fsfemacs-p (fset 'vm-extent-end-position 'overlay-end) (fset 'vm-extent-end-position 'extent-end-position))) (if (not (fboundp 'vm-extent-start-position)) (if vm-fsfemacs-p (fset 'vm-extent-start-position 'overlay-start) (fset 'vm-extent-start-position 'extent-start-position))) (if (not (fboundp 'vm-detach-extent)) (if vm-fsfemacs-p (fset 'vm-detach-extent 'delete-overlay) (fset 'vm-detach-extent 'detach-extent))) (if (not (fboundp 'vm-delete-extent)) (if vm-fsfemacs-p ;; This doesn't actually destroy the overlay, but it is the ;; best there is. (fset 'vm-delete-extent 'delete-overlay) (fset 'vm-delete-extent 'delete-extent))) (if (not (fboundp 'vm-disable-extents)) (if (and vm-fsfemacs-p (fboundp 'remove-overlays)) (fset 'vm-disable-extents 'remove-overlays) ;; XEamcs doesn't need to disable extents because they don't ;; slow things down (fset 'vm-disable-extents (lambda (&optional beg end name val) nil)))) (if (not (fboundp 'vm-extent-properties)) (if vm-fsfemacs-p (fset 'vm-extent-properties 'overlay-properties) (fset 'vm-extent-properties 'extent-properties))) (defun vm-extent-at (pos &optional property) "Find an extent at POS in the current buffer having PROPERTY. PROPERTY defaults nil, meaning any extent will do. In XEmacs, the extent is the \"smallest\" extent at POS. In FSF Emacs, this may not be the case." (if (fboundp 'extent-at) (extent-at pos nil property) (let ((o-list (overlays-at pos)) (o nil)) (if (null property) (car o-list) (while o-list (if (overlay-get (car o-list) property) (setq o (car o-list) o-list nil) (setq o-list (cdr o-list)))) o )))) (defun vm-extent-list (beg end &optional property) "Returns a list of the extents that overlap the positions BEG to END. If PROPERTY is given, then only the extents have PROPERTY are returned." (if (fboundp 'extent-list) (extent-list nil beg end nil property) (let ((o-list (overlays-in beg end))) (if property (vm-delete (function (lambda (e) (vm-extent-property e property))) o-list t) o-list)))) (defun vm-copy-extent (e) (let ((props (vm-extent-properties e)) (ee (vm-make-extent (vm-extent-start-position e) (vm-extent-end-position e)))) (while props (vm-set-extent-property ee (car props) (car (cdr props))) (setq props (cdr (cdr props)))))) (defun vm-make-tempfile (&optional filename-suffix proposed-filename) (let ((modes (default-file-modes)) (file (vm-make-tempfile-name filename-suffix proposed-filename))) (unwind-protect (progn (set-default-file-modes (vm-octal 600)) (vm-error-free-call 'delete-file file) (write-region (point) (point) file nil 0)) (set-default-file-modes modes)) file )) (defun vm-make-tempfile-name (&optional filename-suffix proposed-filename) (if (stringp proposed-filename) (setq proposed-filename (file-name-nondirectory proposed-filename))) (let (filename) (cond ((and (stringp proposed-filename) (not (file-exists-p (setq filename (convert-standard-filename (expand-file-name proposed-filename vm-temp-file-directory)))))) t ) ((stringp proposed-filename) (let ((done nil)) (while (not done) (setq filename (convert-standard-filename (expand-file-name (format "%d-%s" vm-tempfile-counter proposed-filename) vm-temp-file-directory)) vm-tempfile-counter (1+ vm-tempfile-counter) done (not (file-exists-p filename)))))) (t (let ((done nil)) (while (not done) (setq filename (convert-standard-filename (expand-file-name (format "vm%d%d%s" vm-tempfile-counter (random 100000000) (or filename-suffix "")) vm-temp-file-directory)) vm-tempfile-counter (1+ vm-tempfile-counter) done (not (file-exists-p filename))))))) filename )) (defun vm-make-work-buffer (&optional name) "Create a unibyte buffer with NAME for VM to do its work in encoding/decoding, conversions, subprocess communication etc." (let ((work-buffer (vm-generate-new-unibyte-buffer (or name "*vm-workbuf*")))) (buffer-disable-undo work-buffer) ;; probably not worth doing since no one sets buffer-offer-save ;; non-nil globally, do they? ;; (with-current-buffer work-buffer ;; (setq buffer-offer-save nil)) work-buffer )) (defun vm-make-multibyte-work-buffer (&optional name) (let ((work-buffer (vm-generate-new-multibyte-buffer (or name "*vm-workbuf*")))) (buffer-disable-undo work-buffer) ;; probably not worth doing since no one sets buffer-offer-save ;; non-nil globally, do they? ;; (with-current-buffer work-buffer ;; (setq buffer-offer-save nil)) work-buffer )) (fset 'xemacs-insert-char 'insert-char) (defun vm-insert-char (char &optional count ignored buffer) (condition-case nil (progn (xemacs-insert-char char count ignored buffer) (fset 'vm-insert-char 'insert-char)) (wrong-number-of-arguments (fset 'vm-insert-char 'vm-xemacs-compatible-insert-char) (vm-insert-char char count ignored buffer)))) (defun vm-xemacs-compatible-insert-char (char &optional count ignored buffer) (if (and buffer (eq buffer (current-buffer))) (insert-char char count) (with-current-buffer buffer (insert-char char count)))) (defun vm-symbol-lists-intersect-p (list1 list2) (catch 'done (while list1 (and (memq (car list1) list2) (throw 'done t)) (setq list1 (cdr list1))) nil )) (defun vm-folder-buffer-value (var) (if vm-mail-buffer (with-current-buffer vm-mail-buffer (symbol-value var)) (symbol-value var))) (defsubst vm-with-string-as-temp-buffer (string function) (let ((work-buffer (vm-make-multibyte-work-buffer))) (unwind-protect (with-current-buffer work-buffer (insert string) (funcall function) (buffer-string)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-string-assoc (elt list) (let ((case-fold-search t) (found nil) (elt (regexp-quote elt))) (while (and list (not found)) (if (and (equal 0 (string-match elt (car (car list)))) (= (match-end 0) (length (car (car list))))) (setq found t) (setq list (cdr list)))) (car list))) (defun vm-nonneg-string (n) (if (< n 0) "?" (int-to-string n))) (defun vm-string-member (elt list) (let ((case-fold-search t) (found nil) (elt (regexp-quote elt))) (while (and list (not found)) (if (and (equal 0 (string-match elt (car list))) (= (match-end 0) (length (car list)))) (setq found t) (setq list (cdr list)))) list)) (defun vm-string-equal-ignore-case (str1 str2) (let ((case-fold-search t) (reg (regexp-quote str1))) (and (equal 0 (string-match reg str2)) (= (match-end 0) (length str2))))) (defun vm-match-data () (let ((n (1- (/ (length (match-data)) 2))) (list nil)) (while (>= n 0) (setq list (cons (match-beginning n) (cons (match-end n) list)) n (1- n))) list)) (defun vm-time-difference (t1 t2) (let (usecs secs 65536-secs carry) (setq usecs (- (nth 2 t1) (nth 2 t2))) (if (< usecs 0) (setq carry 1 usecs (+ usecs 1000000)) (setq carry 0)) (setq secs (- (nth 1 t1) (nth 1 t2) carry)) (if (< secs 0) (setq carry 1 secs (+ secs 65536)) (setq carry 0)) (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) (+ (* 65536-secs 65536) secs (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) (if (fboundp 'char-to-int) (fset 'vm-char-to-int 'char-to-int) (fset 'vm-char-to-int 'identity)) (cond ((fboundp 'charsets-in-region) (fset 'vm-charsets-in-region 'charsets-in-region)) ((fboundp 'find-charset-region) (fset 'vm-charsets-in-region 'find-charset-region))) ;; Wrapper for coding-system-p: ;; The XEmacs function expects a coding-system object as its argument, ;; the GNU Emacs function expects a symbol. ;; In the non-MULE case, return nil (is this the right fallback?). (defun vm-coding-system-p (name) (cond (vm-xemacs-mule-p (coding-system-p (find-coding-system name))) (vm-fsfemacs-mule-p (coding-system-p name)))) (cond ((fboundp 'coding-system-name) (fset 'vm-coding-system-name 'coding-system-name)) (t (fset 'vm-coding-system-name 'identity))) (if (fboundp 'coding-system-name) (defun vm-coding-system-name-no-eol (coding-system) (coding-system-name (coding-system-change-eol-conversion coding-system nil))) (defun vm-coding-system-name-no-eol (coding-system) (coding-system-change-eol-conversion coding-system nil))) (defun vm-get-file-line-ending-coding-system (file) (if (not (or vm-fsfemacs-mule-p vm-xemacs-mule-p vm-xemacs-file-coding-p)) nil (let ((coding-system-for-read (vm-binary-coding-system)) (work-buffer (vm-make-work-buffer))) (unwind-protect (with-current-buffer work-buffer (condition-case nil (insert-file-contents file nil 0 4096) (error nil)) (goto-char (point-min)) (cond ((re-search-forward "[^\r]\n" nil t) (if vm-fsfemacs-mule-p 'raw-text-unix 'no-conversion-unix)) ((re-search-forward "\r[^\n]" nil t) (if vm-fsfemacs-mule-p 'raw-text-mac 'no-conversion-mac)) ((search-forward "\r\n" nil t) (if vm-fsfemacs-mule-p 'raw-text-dos 'no-conversion-dos)) (t (vm-line-ending-coding-system)))) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-new-folder-line-ending-coding-system () (cond ((eq vm-default-new-folder-line-ending-type nil) (vm-line-ending-coding-system)) ((eq vm-default-new-folder-line-ending-type 'lf) (if vm-fsfemacs-mule-p 'raw-text-unix 'no-conversion-unix)) ((eq vm-default-new-folder-line-ending-type 'crlf) (if vm-fsfemacs-mule-p 'raw-text-dos 'no-conversion-dos)) ((eq vm-default-new-folder-line-ending-type 'cr) (if vm-fsfemacs-mule-p 'raw-text-mac 'no-conversion-mac)) (t (vm-line-ending-coding-system)))) (defun vm-collapse-whitespace () (goto-char (point-min)) (while (re-search-forward "[ \t\n]+" nil 0) (replace-match " " t t))) (defvar vm-paragraph-prefix-regexp "^[ >]*" "A regexp used by `vm-forward-paragraph' to match paragraph prefixes.") (defvar vm-empty-line-regexp "^[ \t>]*$" "A regexp used by `vm-forward-paragraph' to match paragraph prefixes.") (defun vm-skip-empty-lines () "Move forward as long as current line matches `vm-empty-line-regexp'." (while (and (not (eobp)) (looking-at vm-empty-line-regexp)) (forward-line 1))) (defun vm-forward-paragraph () "Move forward to end of paragraph and do it also right for quoted text. As a side-effect set `fill-prefix' to the paragraphs prefix. Returns t if there was a line longer than `fill-column'." (let ((long-line) (line-no 1) len-fill-prefix) (forward-line 0) ; cover for bad fill-region fns (setq fill-prefix nil) (while (and ;; stop at end of buffer (not (eobp)) ;; empty lines break paragraphs (not (looking-at "^[ \t]*$")) ;; do we see a prefix (looking-at vm-paragraph-prefix-regexp) (let ((m (match-string 0)) lenm) (or (and (null fill-prefix) ;; save prefix for next line (setq fill-prefix m len-fill-prefix (length m))) ;; is it still the same prefix? (string= fill-prefix m) ;; or is it just shorter by whitespace on the second line (and (= line-no 2) (< (setq lenm (length m)) len-fill-prefix) (string-match "^[ \t]+$" (substring fill-prefix lenm)) ;; then save new shorter prefix (setq fill-prefix m len-fill-prefix lenm))))) (end-of-line) (setq line-no (1+ line-no)) (setq long-line (or long-line (> (current-column) fill-column))) (forward-line 1)) long-line)) (defun vm-fill-paragraphs-containing-long-lines (width start end) "Fill paragraphs spanning more than WIDTH columns in region START to END. If WIDTH is 'window-width, the current width of the Emacs window is used. If vm-word-wrap-paragraphs is set non-nil, then the longlines package is used to word-wrap long lines without removing any existing line breaks. In order to fill also quoted text you will need `filladapt.el' as the adaptive filling of GNU Emacs does not work correctly here." (if (and vm-word-wrap-paragraphs (locate-library "longlines")) (vm-fill-paragraphs-by-longlines start end) (if (eq width 'window-width) (setq width (- (window-width (get-buffer-window (current-buffer))) 1))) (save-excursion (let ((buffer-read-only nil) (fill-column vm-paragraph-fill-column) (adaptive-fill-mode nil) (abbrev-mode nil) (fill-prefix nil) ;; (use-hard-newlines t) (filled 0) (message (if (car vm-message-pointer) (vm-su-subject (car vm-message-pointer)) (buffer-name))) (needmsg (> (- end start) 12000))) (if needmsg (vm-inform 5 "Filling message to column %d" fill-column)) ;; we need a marker for the end since this position might change (or (markerp end) (setq end (vm-marker end))) (goto-char start) (while (< (point) end) (setq start (point)) (vm-skip-empty-lines) (when (and (< (point) end) ; if no newline at the end (let ((fill-column width)) (vm-forward-paragraph))) (fill-region start (point)) (setq filled (1+ filled)))) ;; Turning off these messages because they go by too fast and ;; are not particularly enlightening. USR, 2010-01-26 ;; (if (= filled 0) ;; (vm-inform 7 "Nothing to fill") ;; (vm-inform 7 "Filled %s paragraph%s" ;; (if (> filled 1) (format "%d" filled) "one") ;; (if (> filled 1) "s" ""))) )))) (defun vm-fill-paragraphs-by-longlines (start end) "Uses longlines.el for filling the region." ;; prepare for longlines.el in XEmacs (require 'overlay) (require 'longlines) (defvar fill-nobreak-predicate nil) (defvar undo-in-progress nil) (defvar longlines-mode-hook nil) (defvar longlines-mode-on-hook nil) (defvar longlines-mode-off-hook nil) (unless (functionp 'replace-regexp-in-string) (defun replace-regexp-in-string (regexp rep string &optional fixedcase literal) (vm-replace-in-string string regexp rep literal))) (unless (functionp 'line-end-position) (defun line-end-position () (save-excursion (end-of-line) (point)))) (unless (functionp 'line-beginning-position) (defun line-beginning-position (&optional n) (save-excursion (if n (forward-line n)) (beginning-of-line) (point))) (unless (functionp 'replace-regexp-in-string) (defun replace-regexp-in-string (regexp rep string &optional fixedcase literal) (vm-replace-in-string string regexp rep literal)))) ;; now do the filling (let ((buffer-read-only nil) (fill-column (if (numberp vm-fill-paragraphs-containing-long-lines) vm-fill-paragraphs-containing-long-lines (- (window-width (get-buffer-window (current-buffer))) 1))) ) (save-excursion (vm-save-restriction ;; longlines-wrap-region contains a (forward-line -1) which is causing ;; wrapping of headers which is wrong, so we restrict it here! (narrow-to-region start end) (longlines-decode-region start end) ; make linebreaks hard (longlines-wrap-region start end) ; wrap, adding soft linebreaks (widen))))) (defun vm-make-message-id () (let (hostname (time (current-time))) (setq hostname (cond ((string-match "\\." (system-name)) (system-name)) ((and (stringp mail-host-address) (string-match "\\." mail-host-address)) mail-host-address) (t "gargle.gargle.HOWL"))) (format "<%d.%d.%d.%d@%s>" (car time) (nth 1 time) (nth 2 time) (random 1000000) hostname))) (defun vm-keep-some-buffers (buffer ring-variable number-to-keep &optional rename-prefix) "Keep the BUFFER in the variable RING-VARIABLE, with NUMBER-TO-KEEP being the maximum number of buffers kept. If necessary, the RING-VARIABLE is pruned. If the optional argument string RENAME-PREFIX is given BUFFER is renamed by adding the prefix at the front before adding it to the RING-VARIABLE." (if (memq buffer (symbol-value ring-variable)) (set ring-variable (delq buffer (symbol-value ring-variable))) (with-current-buffer buffer (rename-buffer (concat "saved " (buffer-name)) t))) (set ring-variable (cons buffer (symbol-value ring-variable))) (set ring-variable (vm-delete 'buffer-name (symbol-value ring-variable) t)) (if (not (eq number-to-keep t)) (let ((extras (nthcdr (or number-to-keep 0) (symbol-value ring-variable)))) (mapc (function (lambda (b) (when (and (buffer-name b) (or (not (buffer-modified-p b)) (not (with-current-buffer b buffer-offer-save)))) (kill-buffer b)))) extras) (and (symbol-value ring-variable) extras (setcdr (memq (car extras) (symbol-value ring-variable)) nil))))) (defvar enable-multibyte-characters) (defvar buffer-display-table) (defun vm-fsfemacs-nonmule-display-8bit-chars () (cond ((and vm-fsfemacs-p (or (not vm-fsfemacs-mule-p) (and (boundp 'enable-multibyte-characters) (not enable-multibyte-characters)))) (let* (tab (i 160)) ;; We need the function make-display-table, but it is ;; in disp-table.el, which overwrites the value of ;; standard-display-table when it is loaded, which ;; sucks. So here we cruftily copy just enough goop ;; out of disp-table.el so that a display table can be ;; created, and thereby avoid loading disp-table. (put 'display-table 'char-table-extra-slots 6) (setq tab (make-char-table 'display-table nil)) (while (< i 256) (aset tab i (vector i)) (setq i (1+ i))) (setq buffer-display-table tab))))) (defun vm-url-decode-string (string) (vm-with-string-as-temp-buffer string 'vm-url-decode-buffer)) (defun vm-url-decode-buffer () (let ((case-fold-search t) (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) (?C . 12) (?D . 13) (?E . 14) (?F . 15) (?a . 10) (?b . 11) (?c . 12) (?d . 13) (?e . 14) (?f . 15))) char) (save-excursion (goto-char (point-min)) (while (re-search-forward "%[0-9A-F][0-9A-F]" nil t) (insert-char (+ (* (cdr (assq (char-after (- (point) 2)) hex-digit-alist)) 16) (cdr (assq (char-after (- (point) 1)) hex-digit-alist))) 1) (delete-region (- (point) 1) (- (point) 4)))))) (defun vm-process-kill-without-query (process &optional flag) (if (fboundp 'process-kill-without-query) (process-kill-without-query process flag) (set-process-query-on-exit-flag process flag))) (defun vm-process-sentinel-kill-buffer (process what-happened) (kill-buffer (process-buffer process))) (defun vm-fsfemacs-scroll-bar-width () (or vm-fsfemacs-cached-scroll-bar-width (let (size) (setq size (frame-pixel-width)) (scroll-bar-mode nil) (setq size (- size (frame-pixel-width))) (scroll-bar-mode nil) (setq vm-fsfemacs-cached-scroll-bar-width size)))) (defvar vm-disable-modes-ignore nil "List of modes ignored by `vm-disable-modes'. Any mode causing an error while trying to disable it will be added to this list. It still will try to diable it, but no error messages are generated anymore for it.") (defun vm-disable-modes (&optional modes) "Disable the given minor modes. If MODES is nil the take the modes from the variable `vm-disable-modes-before-encoding'." (let (m) (while modes (setq m (car modes) modes (cdr modes)) (condition-case errmsg (if (functionp m) (funcall m -1)) (error (when (not (member m vm-disable-modes-ignore)) (vm-warn 0 2 "Could not disable mode `%S': %S" m errmsg) (setq vm-disable-modes-ignore (cons m vm-disable-modes-ignore))) nil))))) (defun vm-add-write-file-hook (vm-hook-fn) "Add a function to the hook called during write-file. Emacs changed the name of write-file-hooks to write-file-functions as of Emacs 22.1. This function is used to supress compiler warnings." (if (boundp 'write-file-functions) (add-hook 'write-file-functions vm-hook-fn) (add-hook 'write-file-hooks vm-hook-fn))) (defun vm-add-find-file-hook (vm-hook-fn) "Add a function to the hook called during find-file. Emacs changed the name of the hook find-file-hooks to find-file-hook in Emacs 22.1. This function used to supress compiler warnings." (if (boundp 'find-file-hook) (add-hook 'find-file-hook vm-hook-fn) (add-hook 'find-file-hooks vm-hook-fn))) ;; Aliases for VM functions ;;; vm-misc.el ends here vm-8.2.0b/lisp/vm-crypto.el0000755000175000017500000001665011676442160016032 0ustar srivastasrivasta;;; vm-crypto.el --- Encryption and related functions for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-crypto) (eval-when-compile (require 'vm-misc) (require 'vm-folder) ) ;; compatibility (fset 'vm-pop-md5 'vm-md5-string) ;;;###autoload (defun vm-md5-region (start end) (if (fboundp 'md5) (md5 (current-buffer) start end) (let ((buffer nil) (retval nil) (curbuf (current-buffer))) (unwind-protect (save-excursion (setq buffer (vm-make-work-buffer)) (set-buffer buffer) (insert-buffer-substring curbuf start end) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (setq retval (call-process-region (point-min) (point-max) vm-pop-md5-program t buffer nil)) (if (not (equal retval 0)) (progn (error "%s failed: exited with code %s" vm-pop-md5-program retval))) ;; md5sum generates extra output even when summing stdin. (goto-char (point-min)) (if (re-search-forward " [ *]?-\n" nil t) (replace-match "")) (goto-char (point-min)) (if (or (re-search-forward "[^0-9a-f\n]" nil t) (< (point-max) 32)) (error "%s produced bogus MD5 digest '%s'" vm-pop-md5-program (vm-buffer-substring-no-properties (point-min) (point-max)))) ;; MD5 digest is 32 chars long ;; mddriver adds a newline to make neaten output for tty ;; viewing, make sure we leave it behind. (vm-buffer-substring-no-properties (point-min) (+ (point-min) 32))) (and buffer (kill-buffer buffer)))))) ;; output is in hex ;;;###autoload (defun vm-md5-string (string) (if (fboundp 'md5) (md5 string) (vm-with-string-as-temp-buffer string (function (lambda () (goto-char (point-min)) (insert (vm-md5-region (point-min) (point-max))) (delete-region (point) (point-max))))))) ;; output is the raw digest bits, not hex ;;;###autoload (defun vm-md5-raw-string (s) (setq s (vm-md5-string s)) (let ((raw (make-string 16 0)) (i 0) n (hex-digit-alist '((?0 . 0) (?1 . 1) (?2 . 2) (?3 . 3) (?4 . 4) (?5 . 5) (?6 . 6) (?7 . 7) (?8 . 8) (?9 . 9) (?A . 10) (?B . 11) (?C . 12) (?D . 13) (?E . 14) (?F . 15) ;; some mailer uses lower-case hex ;; digits despite this being forbidden ;; by the MIME spec. (?a . 10) (?b . 11) (?c . 12) (?d . 13) (?e . 14) (?f . 15)))) (while (< i 32) (setq n (+ (* (cdr (assoc (aref s i) hex-digit-alist)) 16) (cdr (assoc (aref s (1+ i)) hex-digit-alist)))) (aset raw (/ i 2) n) (setq i (+ i 2))) raw )) ;;;###autoload (defun vm-xor-string (s1 s2) (let ((len (length s1)) result (i 0)) (if (/= len (length s2)) (error "strings not of equal length")) (setq result (make-string len 0)) (while (< i len) (aset result i (logxor (aref s1 i) (aref s2 i))) (setq i (1+ i))) result )) ;;;###autoload (defun vm-setup-ssh-tunnel (host port) (let (local-port process done) (while (not done) (setq local-port (+ 1025 (random (- 65536 1025))) process nil) (condition-case nil (progn (setq process (open-network-stream "TEST-CONNECTION" nil "127.0.0.1" local-port)) (vm-process-kill-without-query process)) (error nil)) (cond ((null process) (setq process (apply 'start-process (format "SSH tunnel to %s:%s" host port) (vm-make-work-buffer) vm-ssh-program (nconc (list "-L" (format "%d:%s:%s" local-port host port)) (copy-sequence vm-ssh-program-switches) (list host vm-ssh-remote-command))) done t) (vm-process-kill-without-query process) (set-process-sentinel process 'vm-process-sentinel-kill-buffer)) (t (delete-process process)))) ;; wait for some output from vm-ssh-remote-command. this ;; ensures that when we return the ssh connection is ready to ;; do port-forwarding. (accept-process-output process) local-port )) (defun vm-generate-random-data-file (n-octets) (let ((file (vm-make-tempfile)) work-buffer (i n-octets)) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (while (> i 0) (insert-char (random 256) 1) (setq i (1- i))) (write-region (point-min) (point-max) file nil 0)) (and work-buffer (kill-buffer work-buffer))) file )) ;;;###autoload (defun vm-setup-stunnel-random-data-if-needed () (cond ((null vm-stunnel-random-data-method) nil) ((eq vm-stunnel-random-data-method 'generate) (if (and (stringp vm-stunnel-random-data-file) (file-readable-p vm-stunnel-random-data-file)) nil (setq vm-stunnel-random-data-file (vm-generate-random-data-file (* 4 1024))))))) ;;;###autoload (defun vm-tear-down-stunnel-random-data () (if (stringp vm-stunnel-random-data-file) (vm-error-free-call 'delete-file vm-stunnel-random-data-file)) (setq vm-stunnel-random-data-file nil)) (defun vm-stunnel-random-data-args () (cond ((null vm-stunnel-random-data-method) nil) ((eq vm-stunnel-random-data-method 'generate) (list "-R" vm-stunnel-random-data-file)) (t nil))) ;;;###autoload (defun vm-stunnel-configuration-args (host port) (if (eq vm-stunnel-wants-configuration-file 'unknown) (setq vm-stunnel-wants-configuration-file (not (eq (call-process vm-stunnel-program nil nil nil "-h") 0)))) (if (not vm-stunnel-wants-configuration-file) (nconc (vm-stunnel-random-data-args) (list "-W" "-c" "-r" (format "%s:%s" host port))) (let ((work-buffer nil) (workfile (vm-stunnel-configuration-file))) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (if (and vm-stunnel-program-additional-configuration-file (stringp vm-stunnel-program-additional-configuration-file) (file-readable-p vm-stunnel-program-additional-configuration-file)) (insert-file-contents vm-stunnel-program-additional-configuration-file)) (insert "client = yes\n") (insert "RNDfile = " vm-stunnel-random-data-file "\n") (insert "RNDoverwrite = no\n") (insert "connect = " (format "%s:%s" host port) "\n") (write-region (point-min) (point-max) workfile nil 0)) (and work-buffer (kill-buffer work-buffer))) (list workfile) ))) (defun vm-stunnel-configuration-file () (if vm-stunnel-configuration-file vm-stunnel-configuration-file (setq vm-stunnel-configuration-file (vm-make-tempfile)) (vm-register-global-garbage-files (list vm-stunnel-configuration-file)) vm-stunnel-configuration-file)) ;;; vm-crypto.el ends here vm-8.2.0b/lisp/vm-thread.el0000755000175000017500000015401711676442160015761 0ustar srivastasrivasta;;; vm-thread.el --- Thread support for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1994, 2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; Copyright (C) 2010 Uday S. Reddy ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-thread) ;; For function declarations (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-motion) (require 'vm-summary) (require 'vm-sort) ) ;; -------------------------------------------------------------------------- ;; Top-level operations ;; ;; vm-toggle-threads-display: interactive () -> none ;; vm-build-threads : (message list) -> none ;; vm-build-thread-lists : () -> none ;; vm-unthread-message-and-mirrors : (message &key ;; :message-changing bool) -> none ;; vm-unthread-message : (message &key ;; :message-changing bool) -> none ;; ;; vm-check-thread-integrity: (&optional message list) -> none ;; ;; vm-thread-mark-for-summary-update : message list -> none ;; ;; vm-parent: (message) -> message ;; vm-references: (message) -> string list ;; ;; vm-thread-symbol : (message) -> symbol ;; vm-thread-list : (message) -> symbol list ;; vm-thread-root : (message or symbol) -> message ;; vm-thread-root-sym : (message or symbol) -> symbol ;; vm-thread-root-p : (message) -> bool ;; vm-thread-indentation : (message) -> integer ;; vm-thread-subtree : (message or symbol) -> message list ;; vm-thread-count : (message or symbol) -> integer ;; vm-subject-symbol: (message) -> symbol ;; ;; The thread-obarray and thread-subject-obarray properties ;; ;; vm-th-thread-symbol: (message) -> symbol ;; vm-th-messages-of : symbol -> message list ;; vm-th-message-of : symbol -> message or nil ;; vm-th-children-of : symbol -> symbol list ;; vm-th-child-messages-of : symbol -> message list ;; vm-th-parent-of : symbol -> symbol ;; vm-th-date-of : symbol -> string ;; vm-th-youngest-date-of : symbol -> string ;; vm-th-oldest-date-of : symbol -> string ;; vm-th-oldest-subject-of : symbol -> string ;; vm-th-thread-date-of : symbol X criterion-symbol -> string ;; vm-th-canonical-message-p : message -> bool ;; vm-th-canonical-message: message -> message ;; vm-th-root : symbol -> message ;; ;; vm-th-new-thread-symbol: message -> symbol ;; vm-th-add-message-to-symbol: symbol X message -> void ;; vm-th-remove-message-from-symbol: symbol X message -> void ;; vm-th-init-thread-symbol: symbol X message -> void ;; vm-th-set-parent : symbol X symbol -> void ;; vm-th-add-child: symbol X symbol -> void ;; vm-th-delete-child: symbol X symbol -> void ;; ;; vm-th-clear-cached-data: symbol X symbol -> void ;; ;; ;; vm-ts-subject-symbol : symbol -> symbol ;; vm-ts-root-of : symbol -> symbol ;; vm-ts-root-date-of : symbol -> date ;; vm-ts-members-of : symbol -> symbol list ;; vm-ts-messages-of : symbol -> message list ;; vm-ts-set-root-of: symbol X symbol -> void ;; vm-ts-set-root-date-of: symbol X date -> void ;; vm-ts-set-members-of: symbol X symbol list -> void ;; vm-ts-set-messages-of: symbol X message list -> void ;; vm-ts-set: symbol X ;; (:root symbol :root-date date ;; :members symbol list :messages message list) -> void ;; ;; vm-ts-add-member: symbol X symbol -> void ;; vm-ts-add-message: symbol X message -> void ;; vm-ts-add-members: symbol X symbol list -> void ;; vm-ts-add-messages: symbol X message list -> void ;; ;; vm-ts-merge : symbol X symbol -> void ;; ;; vm-ts-clear-cached-data: symbol X symbol -> void ;; ;; vm-th-parent : message -> string ;; (aliased to vm-parent) ;; vm-th-references : message -> string list ;; (aliased to vm-references) ;; vm-th-thread-indentation : message -> integer ;; (aliased to vm-thread-indentation) ;; -------------------------------------------------------------------------- (if (fboundp 'define-error) (define-error 'vm-thread-error "VM internal threading error") (put 'vm-thread-error 'error-conditions '(vm-thread-error error)) (put 'vm-thread-error 'error-message "VM internal threading error") ) (defun vm-trace-message-id () (interactive) (add-to-list 'vm-traced-message-ids (vm-su-message-id (vm-current-message))) (message "%s" vm-traced-message-ids)) (defun vm-trace-message-subject () (interactive) (add-to-list 'vm-traced-message-subjects (vm-so-sortable-subject (vm-current-message))) (message "%s" vm-traced-message-subjects)) (defsubst vm-thread-debug (message &rest args) (if (and vm-thread-debug vm-summary-show-threads (vectorp vm-thread-obarray)) (apply 'debug message args))) (defsubst vm-th-thread-symbol (m) (intern (vm-su-message-id m) vm-thread-obarray)) (defsubst vm-th-youngest-date-of (id-sym) (get id-sym 'youngest-date)) (defsubst vm-th-set-youngest-date-of (id-sym date) (put id-sym 'youngest-date date)) (defsubst vm-th-oldest-date-of (id-sym) (get id-sym 'oldest-date)) (defsubst vm-th-oldest-subject-of (id-sym) (get id-sym 'oldest-subject)) (defsubst vm-th-set-oldest-date-of (id-sym date) (put id-sym 'oldest-date date)) (defsubst vm-th-set-oldest-subject-of (id-sym subject) (put id-sym 'oldest-subject subject)) (defsubst vm-th-thread-date-of (id-sym criterion) "For the message with the interned symbol ID-SYM, return the youngest or oldest date in its thread. CRITERION must be one of 'youngest-date and 'oldest-date" (get id-sym criterion)) (defsubst vm-th-message-of (id-sym) (and (boundp id-sym) (symbol-value id-sym))) (defsubst vm-th-set-message-of (id-sym m) (set id-sym m)) (defsubst vm-th-messages-of (id-sym) (get id-sym 'messages)) (defsubst vm-th-canonical-message-p (m) (eq m (vm-th-message-of (vm-th-thread-symbol m)))) (defsubst vm-th-canonical-message (m) (vm-th-message-of (vm-th-thread-symbol m))) ;; (defsubst vm-th-message (id-sym) ;; (and (vm-th-messages-of id-sym) ;; (vm-last-elem (vm-th-messages-of id-sym)))) (defsubst vm-th-set-messages-of (id-sym ml) (put id-sym 'messages ml)) (defsubst vm-th-parent-of (id-sym) (get id-sym 'parent)) (defsubst vm-th-set-parent-of (id-sym p-sym) ;; For safety, set the symbol-value to nil (unless (boundp id-sym) (set id-sym nil)) (put id-sym 'parent p-sym)) (defsubst vm-th-children-of (id-sym) (get id-sym 'children)) (defun vm-th-visible-children-of (id-sym) (let ((kids (vm-th-children-of id-sym)) (result nil)) (while kids (if (vm-th-message-of (car kids)) (setq result (cons (car kids) result) kids (cdr kids)) (setq kids (append (vm-th-children-of (car kids)) (cdr kids))))) (nreverse result))) (defun vm-th-child-messages-of (id-sym) (let ((kids (vm-th-children-of id-sym)) (result nil) m) (while kids (setq m (vm-th-message-of (car kids))) (if m (setq result (cons m result))) (setq kids (cdr kids))) (nreverse result))) (defsubst vm-th-set-children-of (id-sym ml) (put id-sym 'children ml)) (defun vm-th-add-child (parent-sym id-sym) (if (member (symbol-name id-sym) (car vm-traced-message-ids)) (vm-thread-debug 'vm-th-add-child id-sym)) (unless (member id-sym (vm-th-children-of parent-sym)) (vm-th-set-children-of parent-sym (cons id-sym (vm-th-children-of parent-sym))))) (defun vm-th-delete-child (parent-sym id-sym) (if (member (symbol-name id-sym) (car vm-traced-message-ids) ) (vm-thread-debug 'vm-th-delete-child id-sym)) (let ((kids (vm-th-children-of parent-sym))) (vm-th-set-children-of parent-sym (remq id-sym kids)))) (defsubst vm-th-date-of (id-sym) (get id-sym 'date)) (defsubst vm-th-set-date-of (id-sym date) (put id-sym 'date date)) (defun vm-ts-subject-symbol (id-sym) ;; the subject symbol is calculated from the oldest-subject field ;; stored in the reference root of ID-SYM. ;; if there is no such field exists, then nil is returned. (if (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-ts-subject-symbol id-sym)) (let ((sym id-sym) parent subject) (while (setq parent (vm-th-parent-of sym)) (setq sym parent)) (if (setq subject (vm-th-oldest-subject-of sym)) (intern subject vm-thread-subject-obarray)))) (defsubst vm-ts-root-of (subject-sym) (aref (symbol-value subject-sym) 0)) (defsubst vm-ts-root-date-of (subject-sym) (aref (symbol-value subject-sym) 1)) (defsubst vm-ts-members-of (subject-sym) (aref (symbol-value subject-sym) 2)) (defsubst vm-ts-messages-of (subject-sym) (aref (symbol-value subject-sym) 3)) (defsubst vm-ts-set-root-of (subject-sym id-sym) (aset (symbol-value subject-sym) 0 id-sym)) (defsubst vm-ts-set-root-date-of (subject-sym date) (aset (symbol-value subject-sym) 1 date)) (defsubst vm-ts-set-members-of (subject-sym ml) (aset (symbol-value subject-sym) 2 ml)) (defsubst vm-ts-set-messages-of (subject-sym ml) (aset (symbol-value subject-sym) 3 ml)) (defun* vm-ts-set (subject-sym &key root root-date members messages) (let ((vec (symbol-value subject-sym))) (aset vec 0 root) (aset vec 1 root-date) (aset vec 2 members) (aset vec 3 messages))) ;;;###autoload (defun vm-thread-symbol (m) "Returns the interned symbol of message M which carries the threading information. Threads should have been built before this. Otherwise nil is returned." (with-current-buffer (vm-buffer-of m) (and (vectorp vm-thread-obarray) (intern (vm-su-message-id m) vm-thread-obarray)))) ;;;###autoload (defun vm-subject-symbol (m) "Returns the interned symbol of message M which carries the subject-based threading information. Threads should have been built before this. Otherwise nil is returned." (with-current-buffer (vm-buffer-of m) (vm-ts-subject-symbol (vm-th-thread-symbol m)))) ;; Integrity constraints for reference threads ;; MESSAGES: ;; The messages field of id-sym points to all known messages with ;; this id. ;; MESSAGE: ;; The message field of id-sym points to the canonical ;; message with this id, which must be the first in the messages ;; field. ;; DATE: ;; The date field of id-sym contains the date of the canonical ;; message with this id. ;; BASIC: ;; MESSAGES /\ MESSAGE /\ DATE ;; PARENT: ;; The parent field of id-sym contains the interned id of the ;; parent of the message, and the parent's children field contains ;; this id-sym. ;; CHILDREN: ;; The children field of id-sym contains the interned id's of all ;; the known children of the message. ;; LINKS: ;; PARENT /\ CHILDREN ;; YOUNGEST: ;; The youngest-date of id-sym contains the date of the youngest ;; message in the subthread rooted in this id. ;; OLDEST: ;; The oldest-date and oldest-subject of id-sym contain the date ;; and the subject (resp.) of the oldest ;; message in the thread containing this id. ;; DATES: ;; YOUNGEST /\ OLDEST ;; NODE: ;; BASIC /\ LINKS /\ DATES ;; Integrity constraints for subject threads ;; TS-ROOT: ;; The root of the subject symbol is the id of the canonical message of ;; the oldest message with the subject. ;; TS-DATE: ;; The date field of the subject symbol is the date of the root ;; message. ;; TS-MEMBERS: ;; The members field of the subject symbol contains all known ;; "members" of the subject thread, except for the root. ;; "Member" means the root of a reference thread with the given ;; subject. (The descendants may have different subject lines.) ;; TS-MESSAGES: ;; The messages field of the subject symbol is the list of all ;; the messages in the folder with this subject. (What about ;; descendant of a member that may have a different subject line?) ;; Cached information ;; SUBTREE: ;; The subtree fields of all the messages with the id contain the ;; subtrees rooted at that node (as recorded in the threads database). ;; LIST: ;; The thread-list fields of all the messages with the id contain ;; the thread-list above that node (as recorded in the threads database). ;; INDENTATION: ;; The thread-indentation field of all the messages with the id ;; store the length of the thread-list. ;; DISPLAY ;; The summary display shows the thread-indentation value. ;; SUBTREE0, LIST0, INDENTATION0 ;; Above properties hold only if the corresponding fields are ;; non-nil. ;; DISPLAY0: ;; If the message is not scheduled for summary-update then its ;; summary display shows the thread-indentation value. ;; CACHE: ;; SUBTREE /\ LIST /\ INDENTATION /\ DISPLAY ;; CACHE0: ;; SUBTREE0 /\ LIST0 /\ INDENTATION0 /\ DISPLAY0 ;;; thread tree - basic operations (defun vm-th-new-thread-symbol (m) "Create a new thread symbol for message M and intitialize its parent and child pointers." (let ((id-sym (vm-th-thread-symbol m))) (vm-th-set-parent-of id-sym nil) (vm-th-set-children-of id-sym nil) id-sym)) (defsubst vm-th-add-message-to-symbol (id-sym m) "Add message M to ID-SYM as one of the messages with its id." ;; requires: BASIC and messages /= nil ;; ensures: BASIC (unless (memq m (vm-th-messages-of id-sym)) (vm-th-set-messages-of id-sym (cons m (vm-th-messages-of id-sym))))) (defsubst vm-th-remove-message-from-symbol (id-sym m) "Delete message M from ID-SYM as one of the messages with its id." ;; requires: BASIC and m in messages ;; ensures: BASIC (vm-th-set-messages-of id-sym (remq m (vm-th-messages-of id-sym))) (if (eq m (vm-th-message-of id-sym)) (vm-th-set-message-of id-sym (car (vm-th-messages-of id-sym))))) (defsubst vm-th-init-thread-symbol (id-sym m) "Initialize thread symbol ID-SYM to the message M." ;; requires: true ;; ensures: BASIC (vm-th-set-message-of id-sym m) (vm-th-set-messages-of id-sym (list m)) (vm-th-set-date-of id-sym (vm-so-sortable-datestring m))) (defsubst vm-th-set-parent (id-sym parent-sym) "Set the parent of ID-SYM to PARENT-SYM." ;; requires: BASIC ;; ensures: BASIC /\ PARENT (vm-th-set-parent-of id-sym parent-sym) (vm-th-add-child parent-sym id-sym)) (defsubst vm-th-clear-cached-data (id-sym parent-sym) "Clear the cached thread-subtree and thread-list information that is invalidated by setting the parent of ID-SYM to PARENT-SYM. This involves the thread-subtrees of PARENT-SYM and all its ancestors. It also invovles thread-lists of ID-SYM and all its descendants." ;; ensures: SUBTREE0(ancestors(parent-sym)), LIST0(descendents(id-sym)) (vm-th-clear-subtree parent-sym) (vm-th-clear-thread-lists id-sym)) (defsubst vm-ts-add-member (subject-sym id-sym) "Add ID-SYM as a member of SUBJECT-SYM." ;; ensures: TS-MEMBERS(subject-sym) (unless (memq id-sym (vm-ts-members-of subject-sym)) (vm-ts-set-members-of subject-sym (cons id-sym (vm-ts-members-of subject-sym))))) (defun vm-ts-add-members (subject-sym id-sym-list) "Add all the elements of ID-SYM-LIST as members of SUBJECT-SYM" (mapc (lambda (id-sym) (vm-ts-add-member subject-sym id-sym)) id-sym-list)) (defsubst vm-ts-add-message (subject-sym m) "Add M as a message in the subject thread of SUBJECT-SYM." ;; ensures: TS-MESSAGES(subject-sym) (vm-ts-set-messages-of subject-sym (cons m (vm-ts-messages-of subject-sym)))) (defun vm-ts-add-messages (subject-sym m-list) "Add all the elements of M-LIST to the subject thread of SUBJECT-SYM" (mapc (lambda (m) (vm-ts-add-message subject-sym m)) m-list)) (defun vm-ts-merge (subject-sym other-sym) "Merge subject symbol OTHER-SYM into SUBJECT-SYM and destroy OTHER-SYM." (let ((subject-root (vm-ts-root-of subject-sym)) (other-root (vm-ts-root-of other-sym))) (vm-th-clear-cached-data subject-root subject-root) (vm-th-clear-cached-data other-root other-root) (if (string< (vm-ts-root-date-of subject-sym) (vm-ts-root-date-of other-sym)) ;; subject-sym is older; merge other-sym (progn (vm-ts-add-members subject-sym (cons other-root (vm-ts-members-of other-sym))) (vm-ts-add-messages subject-sym (vm-ts-messages-of other-sym))) ;; other-sym is older; copy it into subject-sym (vm-ts-add-member subject-sym subject-root) (vm-ts-set-root-of subject-sym other-root) (vm-ts-set-root-date-of subject-sym (vm-ts-root-date-of other-sym)) (vm-ts-add-members subject-sym (vm-ts-members-of other-sym)) (vm-ts-add-messages subject-sym (vm-ts-messages-of other-sym))) ;; destroy other-sym (makunbound other-sym) ;; ---------------- atomic block ----------------------- (let ((inhibit-quit nil)) (mapc (lambda (c-sym) (vm-thread-mark-for-summary-update (vm-th-messages-of c-sym))) (vm-ts-members-of subject-sym))) ;; -------------- end atomic block --------------------- )) (defsubst vm-ts-clear-cached-data (id-sym subject-sym) "Clear the cached thread-subtree and thread-list information for ID-SYM, which is the subject root of SUBJECT-SYM. This involves clearing the thread-subtree of ID-SYM and the thread-lists of all members of SUBJEC-SYM. (not entirely clear if this is right). USR, 2011-04-08" ;; ensures: SUBTREE0(ancestors(id-sym)) /\ ;; LIST0(descendants(members(subject-sym))) (vm-th-clear-subtree id-sym) (mapc 'vm-th-clear-thread-lists (vm-ts-members-of subject-sym))) ;;;###autoload (defun vm-toggle-threads-display () "Toggle the threads display on and off. When the threads display is on, the folder will be sorted by thread activity and thread indentation (via the %I summary format specifier) will be visible." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) ;; get numbering of new messages done now ;; so that the sort code only has to worry about the ;; changes it needs to make. (vm-update-summary-and-mode-line) (vm-set-summary-redo-start-point t) (setq vm-summary-show-threads (not vm-summary-show-threads)) ;; Toggle between "physical-order" and "activity" sort-keys. ;; This would have been better if vm-ml-sort-keys was a list of ;; sort-keys, but it is a string and this is a quick fix. (cond ((equal vm-ml-sort-keys "physical-order") (setq vm-ml-sort-keys "activity")) ((equal vm-ml-sort-keys "activity") (setq vm-ml-sort-keys "physical-order")) ((equal vm-ml-sort-keys "reversed-physical-order") (setq vm-ml-sort-keys "reversed-activity")) ((equal vm-ml-sort-keys "reversed-activity") (setq vm-ml-sort-keys "reversed-physical-order"))) (if vm-summary-show-threads (vm-sort-messages (or vm-ml-sort-keys "activity")) (vm-sort-messages (or vm-ml-sort-keys "physical-order")))) ;;;###autoload (defun vm-promote-subthread (n) "Decrease the thread indentation of the current message and its subthread by $N$ steps (provided as a prefix argument). The case $N$ being 0 is a special case. It means to decrease the indentation all the way to 0." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((modified (buffer-modified-p)) (msg (car vm-message-pointer)) (indent 0)) (if (= n 0) ; special case, set to 0 (let ((indent (or (vm-thread-indentation-of msg) 0))) (mapc (lambda (m) (vm-set-thread-indentation-offset-of m (- indent))) (vm-thread-subtree msg))) (mapc (lambda (m) (vm-set-thread-indentation-offset-of m (- (or (vm-thread-indentation-offset-of m) 0) n))) (vm-thread-subtree msg))) (vm-thread-mark-for-summary-update (list msg)) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-demote-subthread (n) "Increase the thread indentation of the current message and its subthread by $N$ steps (provided as a prefix argument). The case $N$ being 0 is a special case. It means to reset the indentation back to the normal indentation, i.e., no offset is used." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((modified (buffer-modified-p)) (msg (car vm-message-pointer))) (if (= n 0) (mapc (lambda (m) (vm-set-thread-indentation-offset-of m 0)) (vm-thread-subtree msg)) (mapc (lambda (m) (vm-set-thread-indentation-offset-of m (+ (or (vm-thread-indentation-offset-of m) 0) n))) (vm-thread-subtree msg))) (vm-thread-mark-for-summary-update (list msg)) (vm-update-summary-and-mode-line))) ;; Dependency of threading information ;; ;; parent & children -> thread-list -> thread-indentation ;; | ;; |--> thread-subtree ;;;###autoload (defun vm-build-threads (message-list) "For all messages in MESSAGE-LIST, build thread information in the `vm-thread-obarray' and `vm-thread-subject-obarray'. If MESSAGE-LIST is nil, do it for all the messages in the folder. USR, 2010-07-15" (let ((initializing (not (vectorp vm-thread-obarray))) (mp (or message-list vm-message-list)) (n 0) ;; Just for laughs, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 40)) ;; no need to schedule reindents of reparented messages ;; unless there were already messages present. (schedule-reindents message-list) m parent parent-sym id id-sym date refs old-parent-sym) (when initializing (setq vm-thread-obarray (make-vector 641 0) vm-thread-subject-obarray (make-vector 641 0))) ;; Build threads using references (vm-build-reference-threads mp schedule-reindents initializing) ;; Record thread dates and subjects (vm-record-thread-dates mp) ;; Build threads using subject (when vm-thread-using-subject (vm-build-subject-threads mp schedule-reindents initializing)) ;; Calculate thread-subtrees for all the known message ID's (mapatoms (lambda (id-sym) (when (vm-th-message-of id-sym) (vm-thread-subtree id-sym))) vm-thread-obarray) (when (> n modulus) (vm-inform 6 "Building threads... done")))) (defun vm-build-reference-threads (mlist schedule-reindents initializing) "Build reference threads for all the messages in MLIST. If threads are already built, then just insert these messages into the threads database. If SCHEDULE-REINDENTS is non-nil, then ask for the summary lines of all affected messages to be updated. If INITIALIZING is non-nil, then assume that the threads database is being initialized." (let ((n 0) (mp mlist) modulus total m parent parent-sym id id-sym date refs old-parent-sym) (setq total (* 2 (length mlist))) (setq modulus (max 10 (/ (length mlist) 50))) (while mp (setq m (car mp) id (vm-su-message-id m) id-sym (intern-soft id vm-thread-obarray)) (if (member id vm-traced-message-ids) (vm-thread-debug 'vm-build-reference-threads id m)) (unless id-sym ; first occurrence now (setq id-sym (vm-th-new-thread-symbol m))) ;; { BASIC0(id-sym) } (if (vm-th-messages-of id-sym) ; registered already (vm-th-add-message-to-symbol id-sym m) (vm-th-init-thread-symbol id-sym m)) ;; { BASIC /\ DISPLAY0 (id-sym) } (when schedule-reindents (vm-thread-mark-for-summary-update (list m))) ;; { BASIC /\ DISPLAY0 (id-sym) } ;; Thread using the parent (setq parent (vm-parent m)) (if (null parent) ;; {NODE /\ DISPLAY0 (id-sym)} ;; could be a duplicate copy of a message (unless initializing (vm-th-clear-subtree id-sym)) ;; {NODE /\ SUBTREE0 /\ DISPLAY0 (id-sym)} ;; {NODE /\ SUBTREE0 /\ LIST0 /\ INDENTATION0 /\ DISPLAY0 (id-sym)} (setq parent-sym (intern parent vm-thread-obarray)) ;; set the parent of m. ;; if there was a parent already, update it consistently. (if (not (vm-th-safe-parent-p id-sym parent-sym)) (vm-inform 10 "Unsafe thread parent detected for %s: %s" (symbol-name id-sym) (symbol-name parent-sym)) (if (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-build-reference-threads-1 id-sym)) (cond ((null (vm-th-parent-of id-sym)) ;; {BASIC /\ LINKS0 /\ DISPLAY0 (id-sym)} (unless initializing (vm-th-clear-cached-data id-sym parent-sym)) (vm-th-set-parent id-sym parent-sym)) ((eq (vm-th-parent-of id-sym) parent-sym) ;; could be a duplicate copy of a message (unless initializing (vm-th-clear-subtree id-sym)) (when schedule-reindents (vm-thread-mark-for-summary-update (vm-th-messages-of parent-sym)))) (t (setq old-parent-sym (vm-th-parent-of id-sym)) (unless initializing (vm-th-clear-subtree old-parent-sym) (vm-th-clear-cached-data id-sym parent-sym)) (vm-th-delete-child old-parent-sym id-sym) (vm-th-set-parent id-sym parent-sym) (when schedule-reindents (vm-thread-mark-for-summary-update (vm-th-messages-of id-sym)) (if (vm-th-message-of old-parent-sym) (vm-mark-for-summary-update (vm-th-message-of old-parent-sym)) (vm-thread-debug 'vm-build-reference-threads 'old-parent-sym old-parent-sym) )))))) ;; { NODE /\ CACHE0 (id-sym) } (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (vm-inform 7 "Building threads... %d%%" (* (/ (+ n 0.0) total) 100)))) ;; use the References header to set parenting information ;; for ancestors of this message. This does not override ;; a parent pointer for a message if it already exists. (setq mp mlist) (while mp (setq m (car mp) id (vm-su-message-id m)) (if (member id vm-traced-message-ids) (vm-thread-debug 'vm-build-reference-threads-2 m)) (if (cdr (setq refs (vm-references m))) (let (parent-sym id-sym msgs msg-syms) (setq parent-sym (intern (car refs) vm-thread-obarray) refs (cdr refs)) (while refs (setq id-sym (intern (car refs) vm-thread-obarray)) (when (null (vm-th-parent-of id-sym)) (if (not (vm-th-safe-parent-p id-sym parent-sym)) (vm-inform 10 "Unsafe reference parent detected for %s: %s" (symbol-name id-sym) (symbol-name parent-sym)) (if (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-build-reference-threads-2 id-sym)) (unless initializing (vm-th-clear-cached-data id-sym parent-sym)) (vm-th-set-parent id-sym parent-sym) (if schedule-reindents (vm-thread-mark-for-summary-update (vm-th-messages-of id-sym))))) (setq parent-sym id-sym refs (cdr refs))))) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (vm-inform 7 "Building threads... %d%%" (* (/ (+ n 0.0) total) 100))) ))) (defun vm-th-clear-thread-lists (id-sym) "Clear the thread-list and thread-indentation fields of the message with ID-SYM and all its descendants." ;; requires: BASIC /\ LINKS (descendants(id-sym)) ;; ensures: LIST0 /\ INDENTATION0 (descendants(id-sym)) (mapc (lambda (d) (vm-set-thread-list-of d nil) (vm-set-thread-indentation-of d nil)) (vm-th-messages-of id-sym)) (mapc 'vm-th-clear-thread-lists (vm-th-children-of id-sym))) (defun vm-th-clear-subtree-of (id-sym) "Clear the thread-subtrees of the messages with ID-SYM, i.e., set them to nil. They will get recalculated on demand." ;; (when (vm-th-message-of id-sym) ;; (vm-set-thread-subtree-of (vm-th-message-of id-sym) nil)) (mapc (lambda (m) (vm-set-thread-subtree-of m nil)) (vm-th-messages-of id-sym)) ) (defun vm-th-clear-subtree (id-sym) "Clear the thread subtrees of the messages with id-symbol ID-SYM and all its ancestors, followed via the parent links." ;; requires: BASIC /\ LINKS (ancestors(id-sym)) ;; ensures: TREE0(ancestors(id-sym)) (let ((msg (vm-th-message-of id-sym)) subject subject-sym) (vm-th-clear-subtree-of id-sym) (while (vm-th-parent-of id-sym) (setq id-sym (vm-th-parent-of id-sym)) (vm-th-clear-subtree-of id-sym) (when (vm-th-message-of id-sym) (setq msg (vm-th-message-of id-sym)))) ;; msg is now the reference root of id-sym (when msg (setq subject-sym (vm-ts-subject-symbol (vm-th-thread-symbol msg))) (when (and subject-sym (boundp subject-sym)) (setq id-sym (vm-ts-root-of subject-sym)) (vm-th-clear-subtree-of id-sym))))) (defun vm-th-safe-parent-p (id-sym parent-sym) "Check if it is safe to set the parent of ID-SYM to PARENT-SYM." ;; Check to make sure that ID-SYM is not an ancestor of PARENT-SYM (if (or (member (symbol-name id-sym) vm-traced-message-ids) (member (symbol-name parent-sym) vm-traced-message-ids)) (vm-thread-debug 'vm-thread-safe-parent-p id-sym parent-sym)) (let ((ancestor parent-sym)) (catch 'return (while ancestor (when (eq ancestor id-sym) (throw 'return nil)) (setq ancestor (vm-th-parent-of ancestor))) t))) (defun vm-th-belongs-to-reference-thread (id-sym) "Check if ID-SYM is the symbol of a message in a reference thread with other ancestors." (let ((parent (vm-th-parent-of id-sym))) (catch 'return (while parent (if (vm-th-messages-of parent) (throw 'return t) (setq parent (vm-th-parent-of parent)))) nil))) (defun vm-th-root (id-sym) "Return the reference-thread root message of ID-SYM; nil is returned in the special case ID-SYM doesn't have any messages or ancestors." (let ((parent (vm-th-parent-of id-sym)) (root (vm-th-message-of id-sym))) (while parent (when (vm-th-messages-of parent) (setq root (vm-th-message-of parent))) (setq parent (vm-th-parent-of parent))) root)) (defun vm-build-subject-threads (mp schedule-reindents initializing) (let ((n 0) (modulus 10) m id id-sym date subject subject-sym) (while mp (setq m (car mp) id (vm-su-message-id m) id-sym (vm-th-thread-symbol m) date (vm-so-sortable-datestring m)) (when (member id vm-traced-message-ids) (vm-thread-debug 'vm-build-subject-threads id m)) ;; Use the reference root's oldest-subject, which should be ;; defined by now (setq subject-sym (vm-ts-subject-symbol id-sym) subject (symbol-name subject-sym)) (when (member subject vm-traced-message-subjects) (vm-thread-debug 'vm-build-subject-threads id m)) ;; -------------- atomic block ------------------------------- (let* ((inhibit-quit t)) ;; if this subject was never seen before create the ;; information vector. (if (not (boundp subject-sym)) ;; new subject (set subject-sym (vector id-sym date nil (list m))) ;; this subject seen before (vm-ts-add-message subject-sym m) (cond ;; duplicate copy of the ts-root ((eq id-sym (vm-ts-root-of subject-sym)) (vm-th-clear-subtree (vm-ts-root-of subject-sym))) ;; if older than the ts-root, make it the root ((string< date (vm-ts-root-date-of subject-sym)) (let* ((i-sym (vm-ts-root-of subject-sym))) (unless initializing (vm-ts-clear-cached-data i-sym subject-sym)) (unless (vm-th-belongs-to-reference-thread i-sym) ;; strange. why would i-sym ever be in a ref thread? (vm-ts-add-member subject-sym i-sym)) (vm-ts-set-root-of subject-sym id-sym) (vm-ts-set-root-date-of subject-sym date) ;; this loops _and_ recurses and I'm worried ;; about it going into a spin someday. So I ;; unblock interrupts here. It's not critical ;; that it finish... the summary will just be out ;; of sync. (when schedule-reindents (let ((inhibit-quit nil)) ;; there might be need for vm-th-clear-subtree here (vm-thread-mark-for-summary-update (vm-ts-messages-of subject-sym)))))) ;; newer than the ts-root (t (unless (vm-th-belongs-to-reference-thread id-sym) (vm-th-clear-subtree (vm-ts-root-of subject-sym)) ;; no need to clear thread-lists; ts-root is unchanged (vm-ts-add-member subject-sym id-sym)))))) ;; -------------- end atomic block ---------------------------------- (setq mp (cdr mp) n (1+ n)) (when (zerop (% n modulus)) (vm-inform 7 "Building threads... %d" n))))) ;; used by the thread sort code. ;; ;; vm-thread-list initializes the oldest-date property on ;; the message-id symbols. Since this property is used as an ;; ordering key by the thread sort the oldest-date properties ;; must be computed before the sort begins, not during it. ;; Otherwise the sort won't be stable and there will be chaos. ;;;###autoload (defun vm-build-thread-lists () "Fill in the thread-list fields of the Soft data vector for all messages in the folder. Threads should have been built before this function is called." ;; (if vm-thread-debug ;; (vm-check-thread-integrity vm-message-list)) (dolist (m vm-message-list) (vm-thread-list m)) (if vm-thread-debug (vm-check-thread-integrity vm-message-list))) ;;;###autoload (defun vm-thread-mark-for-summary-update (message-list) "Mark the messages in MESSAGE-LIST and all their descendants for summary update. This function does not depend on cached thread-subtrees. USR, 2011-04-03" ;; requires: BASIC /\ LINKS (descendants(message-list)) ;; ensures: LIST0 /\ INDENTATION0 /\ DISPLAY0 (descendants(message-list)) (mapc (lambda (m) ;; if thread-list is null then we've already marked this ;; message, or it doesn't need marking. (if (null (vm-thread-list-of m)) nil (vm-mark-for-summary-update m t) (vm-set-thread-list-of m nil) (vm-set-thread-indentation-of m nil) (vm-thread-mark-for-summary-update (vm-th-child-messages-of (vm-thread-symbol m))))) message-list)) (defun vm-record-thread-dates (mlist) "Returns date and subject of all messages in MLIST in the oldest-date, youngest-date and oldest-subject fields of all their ancestors. The oldest-subject field is only updated for reference-based ancestors, whereas dates are updated for both reference and subject-based ancestors." (dolist (m mlist) (let ((done nil) (subject-thread nil) (loop-recovery-point nil) (date (vm-so-sortable-datestring m)) (subject (vm-so-sortable-subject m)) id-sym subject-sym loop-sym root-date root-subject youngest-date root) (with-current-buffer (vm-buffer-of m) ;; thread trees do not have loops any more, but better to be ;; safe than sorry. USR, 2011-05-13 (fillarray vm-thread-loop-obarray 0) (setq id-sym (vm-th-thread-symbol m)) (when (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-record-thread-dates id-sym)) (set (intern (symbol-name id-sym) vm-thread-loop-obarray) t) (while (not done) ;; save the date of the oldest message in this thread (setq root-date (vm-th-oldest-date-of id-sym)) (setq root-subject (vm-th-oldest-subject-of id-sym)) (when (or (null root-date) (string< date root-date)) (vm-th-set-oldest-date-of id-sym date) (unless subject-thread (vm-th-set-oldest-subject-of id-sym subject))) ;; save the date of the youngest message in this thread (setq youngest-date (vm-th-youngest-date-of id-sym)) (when (or (null root-date) (string< youngest-date date)) (vm-th-set-youngest-date-of id-sym date)) (cond ((vm-th-parent-of id-sym) (setq id-sym (vm-th-parent-of id-sym) loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) (if (boundp loop-sym) ;; loop detected, bail... (setq done t) (set loop-sym t) (when (vm-th-messages-of id-sym) (setq m (vm-th-message-of id-sym))))) ((null m) ; why this? USR, 2011-09-24 (setq done t)) ((null vm-thread-using-subject) (setq done t)) ((and (setq subject-sym (vm-ts-subject-symbol (vm-th-thread-symbol m))) (or (not (boundp subject-sym)) (and (eq (vm-ts-root-of subject-sym) (vm-th-thread-symbol m))))) (setq done t)) (t (setq subject-thread t) (setq id-sym (vm-ts-root-of subject-sym)) (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) (if (boundp loop-sym) ;; loop detected, bail... (setq done t) (setq root (vm-th-message-of id-sym)) (set loop-sym t) (setq m (vm-th-message-of id-sym)))))) )))) (defun vm-build-thread-list (message) "Returns the thread-list, i.e., the lineage of MESSAGE, as a list of symbols interned in vm-thread-obarray." (if (null message) (vm-thread-debug 'vm-build-thread-list-null) (let ((done nil) (loop-recovery-point nil) (date (vm-so-sortable-datestring message)) (subject (vm-so-sortable-subject message)) m thread-list id-sym subject-sym loop-sym root-date root-subject youngest-date root ancestors) (setq m message) (with-current-buffer (vm-buffer-of m) ;; thread trees do not have loops any more, but better to be ;; safe than sorry. USR, 2011-05-13 (fillarray vm-thread-loop-obarray 0) (setq id-sym (vm-th-thread-symbol m) thread-list (list id-sym)) (when (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-build-thread-list id-sym)) ;; if m is a non-canonical message for its message ID, give it ;; an artificial thread-list ;; But, does this make sense? ;; (unless (eq m (vm-th-message-of id-sym)) ;; (setq thread-list (list id-sym id-sym)) ;; (setq done t)) (set (intern (symbol-name id-sym) vm-thread-loop-obarray) t) (while (not done) ;; save the date of the oldest message in this thread (setq root-date (vm-th-oldest-date-of id-sym)) (setq root-subject (vm-th-oldest-subject-of id-sym)) (when (or (null root-date) (string< date root-date)) (vm-th-set-oldest-date-of id-sym date) (vm-th-set-oldest-subject-of id-sym subject)) ;; save the date of the youngest message in this thread (setq youngest-date (vm-th-youngest-date-of id-sym)) (when (or (null root-date) (string< youngest-date date)) (vm-th-set-youngest-date-of id-sym date)) (cond ((vm-th-parent-of id-sym) (setq id-sym (vm-th-parent-of id-sym) loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) (if (boundp loop-sym) ;; loop detected, bail... (setq done t thread-list (or loop-recovery-point thread-list)) (set loop-sym t) (setq thread-list (cons id-sym thread-list)) (when (vm-th-messages-of id-sym) (setq m (vm-th-message-of id-sym))))) ((null m) (setq done t)) ((null vm-thread-using-subject) (setq done t)) ((and (setq subject-sym (vm-ts-subject-symbol (vm-th-thread-symbol m))) (or (not (boundp subject-sym)) (and (eq (vm-ts-root-of subject-sym) (vm-th-thread-symbol m))))) (setq done t)) (t (setq id-sym (vm-ts-root-of subject-sym)) ;; seems to cause more trouble than it fixes ;; revisit this later. ;; (setq loop-recovery-point (or loop-recovery-point ;; thread-list)) (setq loop-sym (intern (symbol-name id-sym) vm-thread-loop-obarray)) (if (boundp loop-sym) ;; loop detected, bail... (setq done t thread-list (or loop-recovery-point thread-list)) (setq root (vm-th-message-of id-sym)) ;; the ancestors of id-sym will be added. ;; remove them if they were already added. (setq ancestors (remq id-sym (vm-thread-list root))) (mapc (lambda (a) (setq thread-list (remq a thread-list)) (makunbound (intern (symbol-name a) vm-thread-loop-obarray))) ancestors) (set loop-sym t) (setq thread-list (cons id-sym thread-list) m (vm-th-message-of id-sym)))))) thread-list )))) ;; remove message struct from thread data. ;; ;; optional second arg non-nil means forget information that ;; might be different if the message contents changed. ;; ;; message must be a real (non-virtual) message ;;;###autoload (defun* vm-unthread-message-and-mirrors (message &key message-changing) "Removes MESSAGE and all its mirrored messages from their current threads. If optional argument MESSAGE-CHANGING is non-nil, then forget information that might be different if the message contents changed. MESSAGE should be a real (non-virtual) message. The full functionality of this function is not entirely clear. USR, 2010-07-24" (save-current-buffer (mapc (lambda (m) ;; Don't trust blindly. The user could have killed some of ;; these buffers. (when (buffer-name (vm-buffer-of m)) (set-buffer (vm-buffer-of m)) (when (vectorp vm-thread-obarray) (vm-unthread-message m :message-changing message-changing)))) (cons message (vm-virtual-messages-of message))))) ;;;###autoload (defun* vm-unthread-message (m &key message-changing) "Removes message M from its thread. If optional argument MESSAGE-CHANGING is non-nil, then forget information that might be different if the message contents changed. The message will be reinserted into an appropriate thread later. USR, 2011-03-17" (let (date subject id-sym s-sym p-sym root root-sym) ;; handles for the thread and thread-subject databases (setq id-sym (vm-th-thread-symbol m)) (setq s-sym (vm-ts-subject-symbol id-sym)) (if (member (symbol-name id-sym) vm-traced-message-ids) (vm-thread-debug 'vm-unthread-message id-sym)) (if (and s-sym (member (symbol-name s-sym) vm-traced-message-subjects)) (vm-thread-debug 'vm-unthread-message id-sym)) ;; mark the subtree for summary update before we change it (vm-thread-mark-for-summary-update (list m)) ;; discard cached thread properties of descendants and ancestors (vm-th-clear-cached-data id-sym id-sym) ;; remove the message from its erstwhile thread ;; -------------- atomic block ------------------------------- (let ((inhibit-quit t)) (when (boundp id-sym) ;; remove m from its thread node (vm-th-remove-message-from-symbol id-sym m) ;; reset the thread dates of m (setq date (vm-so-sortable-datestring m)) (setq subject (vm-so-sortable-subject m)) (vm-th-set-youngest-date-of id-sym date) (vm-th-set-oldest-date-of id-sym date) (vm-th-set-oldest-subject-of id-sym subject) ;; if message changed, remove it from the thread tree ;; not clear what is going on. USR, 2010-07-24 (when (and message-changing (null (vm-th-message-of id-sym))) (setq p-sym (vm-th-parent-of id-sym)) (when p-sym (vm-th-delete-child p-sym id-sym)) (vm-th-set-parent-of id-sym nil)))) ;;-------------- end atomic block ------------------------------ ;; remove the message from its erstwhile subject thread (when (and s-sym (boundp s-sym)) (if (eq (vm-ts-root-of s-sym) id-sym) ;; handle the subject thread root ;; (when message-changing (cond ;; duplicate copy present, so keep the root id-sym. ;; FIXME the thread-subtree of the duplicate copy has to be ;; cleared somehow. ((vm-th-message-of id-sym) (vm-ts-set-messages-of s-sym (remq m (vm-ts-messages-of s-sym)))) ;; subject thread becomes empty ((null (remq m (vm-ts-messages-of s-sym))) (makunbound s-sym)) (t (let ((p (remq m (vm-ts-messages-of s-sym))) msg date children oldest-msg oldest-date) ;; find the oldest message in the subject thread (while p (setq msg (vm-th-canonical-message (car p))) (when msg (setq date (vm-so-sortable-datestring msg)) (when (or (null oldest-date) (string-lessp date oldest-date)) (setq oldest-msg msg) (setq oldest-date date))) (setq p (cdr p))) ;; make the oldest message the new subject root (if (null oldest-msg) ;; subject thread is empty (makunbound s-sym) ;; subject thread nonempty (let (new-sub new-s-sym) (setq root-sym (vm-th-thread-symbol oldest-msg)) ;; (setq children (vm-th-visible-children-of id-sym)) (setq children (cons id-sym (vm-ts-members-of s-sym))) ;; (vm-th-clear-cached-data root-sym root-sym) (vm-th-clear-subtree root-sym) ;; (vm-th-clear-thread-lists root-sym) (mapc 'vm-th-clear-thread-lists (vm-ts-members-of s-sym)) (vm-ts-set s-sym :root root-sym :root-date oldest-date :members (remq root-sym children) :messages (remq m (vm-ts-messages-of s-sym))) ;; I'm not sure there aren't situations ;; where this might loop forever. ;; ---------------- atomic block ----------------------- (let ((inhibit-quit nil)) (mapc (lambda (c-sym) (vm-thread-mark-for-summary-update (vm-th-messages-of c-sym))) (cons root-sym children))) ;; -------------- end atomic block --------------------- ))))) ;; ) ;; handle a non-root of subject thread (unless (vm-th-message-of id-sym) (vm-ts-set-members-of s-sym (append (vm-th-visible-children-of id-sym) (remq id-sym (vm-ts-members-of s-sym))))) (vm-ts-set-messages-of s-sym (remq m (vm-ts-messages-of s-sym))) ))) ;; This doesn't work yet ;; (if vm-thread-debug ;; (vm-check-thread-integrity)) ) ;; This function is still under development. USR, 2011-04-04 ;;;###autoload (defun vm-attach-to-thread () "Attach the current message as a child of the message last visited." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-folder-read-only) (vm-build-threads-if-unbuilt) (unless vm-last-message-pointer (error "No last message visited")) (let ((new-parent (car vm-last-message-pointer)) (p-sym (vm-thread-symbol (car vm-last-message-pointer))) (m (car vm-message-pointer)) (m-sym (vm-thread-symbol (car vm-message-pointer)))) ;; (vm-thread-mark-for-summary-update (list m)) (vm-unthread-message m :message-changing t) (unless (vm-th-safe-parent-p m-sym p-sym) (error "Attaching to thread will create a cycle")) (vm-th-set-parent-of m-sym p-sym) (vm-th-add-child p-sym m-sym)) (vm-inform 5 "Message attached to thread") (vm-update-summary-and-mode-line) ) ;;;###autoload (defun vm-references (m) "Returns the cached references list of message M. If the cache is nil, retrieves the references list from the headers and caches it. USR, 2010-03-13" (or (vm-references-of m) (vm-set-references-of m (let (references) (setq references (vm-get-header-contents m "References:" " ")) (and references (vm-parse references "[^<]*\\(<[^>]+>\\)")))))) (defalias 'vm-th-references 'vm-references) ;;;###autoload (defun vm-parent (m) "Returns the cached parent message of message M (in its thread). If the cache is nil, calculates the parent and caches it. USR, 2010-03-13" (or (vm-parent-of m) (vm-set-parent-of m (or (vm-last-elem (vm-references m)) (let (in-reply-to ids id) (setq in-reply-to (vm-get-header-contents m "In-Reply-To:" " ") ids (and in-reply-to (vm-parse in-reply-to "[^<]*\\(<[^>]+>\\)"))) (while ids (when (< (length id) (length (car ids))) (setq id (car ids))) (setq ids (cdr ids))) (and id (vm-set-references-of m (list id))) id ))))) (defalias 'vm-th-parent 'vm-parent) ;;;###autoload (defun vm-thread-indentation (m) "Returns the cached thread-indentation of message M. If the cache is nil, calculates the thread-indentation and caches it. It also applies any thread-indentation-offset that has been defined for a subthread. USR, 2011-04-03" (+ (or (vm-thread-indentation-of m) (let ((p (vm-thread-list m)) (n 0)) (catch 'done (while p (cond ((null (vm-th-messages-of (car p))) (setq p (cdr p))) (vm-summary-thread-indentation-by-references (setq n (length p)) (throw 'done nil)) (t (setq n (1+ n) p (cdr p)))))) (if (and (eq (car p) (vm-thread-symbol m)) (not (eq (vm-th-message-of (car p)) m))) ;; thread root is a duplicate of m (vm-set-thread-indentation-of m n) (vm-set-thread-indentation-of m (1- n))) (vm-thread-indentation-of m))) (or (vm-thread-indentation-offset-of m) 0) )) (defalias 'vm-th-thread-indentation 'vm-thread-indentation) ;;;###autoload (defun vm-thread-list (m) "Returns the cached thread-list of message M. If the cache is nil, calculates the thread-list and caches it. USR, 2010-03-13" (or (vm-thread-list-of m) (progn (vm-set-thread-list-of m (vm-build-thread-list m)) ;; reset the thread-subtrees, forcing them to be rebuilt ;; (mapc 'vm-th-clear-subtree-of (vm-thread-list-of m)) (vm-thread-list-of m)))) (defalias 'vm-th-thread-list 'vm-thread-list) ;;;###autoload (defun vm-thread-root (m) "Returns the root message of M. M can be either a message or the interned symbol of a message. If there are multiple messages with the same root message ID, one of them is chosen arbitrarily. Threads should have been built for this function to work." ;; requires: LIST0(m) (let (m-sym list id-sym) (cond ((symbolp m) (setq m-sym m) (setq m (vm-th-message-of m-sym))) (t (setq m-sym (vm-thread-symbol m)))) (if (and vm-debug (member (symbol-name m-sym) vm-traced-message-ids)) (debug 'vm-thread-root m-sym)) (catch 'return (unless m-sym (vm-thread-debug 'vm-thread-root-null m-sym) (throw 'return m)) (setq list (vm-thread-list m)) (while list (setq id-sym (car list)) (when (vm-th-messages-of id-sym) (throw 'return (vm-th-message-of id-sym))) (setq list (cdr list))) nil))) ;;;###autoload (defun vm-thread-root-sym (m) "Returns interned symbol of the root message of M. M can be either a message or the interned symbol of M. Threads should have been built for this function to work. See also: `vm-thread-root'." ;; requires: LIST0(m) (let (m-sym list id-sym) (cond ((symbolp m) (setq m-sym m) (setq m (vm-th-message-of m-sym))) (t (setq m-sym (vm-thread-symbol m)))) (if (and vm-debug (member (symbol-name m-sym) vm-traced-message-ids)) (debug 'vm-thread-root-sym m-sym)) (catch 'return (unless m-sym (vm-thread-debug 'vm-thread-root-sym-null m-sym) (throw 'return nil)) (setq list (vm-thread-list m)) (while list (setq id-sym (car list)) (when (vm-th-messages-of id-sym) (throw 'return id-sym)) (setq list (cdr list))) nil))) ;;;###autoload (defun vm-thread-root-p (m) "Returns t if message M is known to be a thread root, nil otherwise. No exceptions are thrown for errors." ;; Threads may not be turned on. So, ignore errors. ;; requires: LIST0(m) (condition-case err (and (eq m (vm-thread-root m)) (> (vm-thread-count m) 1)) (vm-thread-error nil))) ;;;###autoload (defun vm-thread-subtree (msg) "Returns the list of messages in the thread subtree of MSG. MSG can be a message or the interned symbol of a message. Threads should have been built for this function to work." (let (m-sym) (if (symbolp msg) (setq m-sym msg msg (vm-th-message-of msg)) (setq m-sym (vm-thread-symbol msg))) (unless m-sym (vm-thread-debug 'vm-thread-subtree m-sym) (signal 'vm-thread-error (list 'vm-thread-subtree))) (if (eq msg (vm-th-message-of m-sym)) ;; canonical message for this message ID (or (vm-thread-subtree-of msg) ;; otherwise calcuate the thread-subtree (let ((list (list m-sym)) (loop-obarray (make-vector 29 0)) subject-sym id-sym id result) (when (member (vm-su-message-id msg) vm-traced-message-ids) (with-current-buffer (vm-buffer-of msg) (vm-thread-debug 'vm-thread-subtree (vm-su-message-id msg)))) (while list (setq id-sym (car list) id (symbol-name id-sym) subject-sym (with-current-buffer (vm-buffer-of msg) (vm-ts-subject-symbol id-sym))) (when (and (vm-th-messages-of id-sym) (not (memq (vm-th-message-of id-sym) result))) (setq result (append result (vm-th-messages-of id-sym)))) (when (null (intern-soft id loop-obarray)) (intern id loop-obarray) (nconc list (copy-sequence (vm-th-children-of id-sym))) (when (and subject-sym (boundp subject-sym) (eq id-sym (vm-ts-root-of subject-sym))) (nconc list (copy-sequence (vm-ts-members-of subject-sym))))) (setq list (cdr list))) (when msg (vm-set-thread-subtree-of msg result)) result)) ;; non-canonical message for this message ID (vm-set-thread-subtree-of msg (list msg)) (list msg)))) ;;;###autoload (defun vm-thread-count (m) "Returns the number of messages in the thread-subtree of message M. M can be a message or the interned symbol of M. Threads should have been built for this function to work." (length (vm-thread-subtree m))) ;;;###autoload (defun vm-check-thread-integrity (&optional ml) "Check that all messages are members of their thread subtrees. Conversely, all members of thread subtrees should actually belong to the thread. Used for testing purposes." (interactive) (vm-select-folder-buffer) (let ((errors-found nil)) (when (vectorp vm-thread-obarray) (unless ml (with-current-buffer (or vm-mail-buffer (current-buffer)) (setq ml vm-message-list))) ;; Check that all messages have been recorded in the threads ;; database (mapc (lambda (m) (unless (vm-th-message-of (vm-th-thread-symbol m)) (vm-thread-debug 'message-not-in-database m))) ml) ;; Check that all messages belong to their respective subtrees (mapc (lambda (m) (let* ((root (vm-thread-root-sym m)) (tree (and root (vm-thread-subtree root)))) (if (vm-th-messages-of (vm-thread-symbol m)) (unless root (vm-thread-debug 'message-with-no-root m) (setq errors-found t)) (vm-thread-debug 'message-lost m) (setq errors-found t)) (with-current-buffer (vm-buffer-of m) (unless (eq root (intern-soft (symbol-name root) vm-thread-obarray)) (vm-thread-debug 'interned-in-wrong-buffer root m) (setq errors-found t))) (when (and (vm-th-message-of root) (not (memq m tree))) (vm-thread-debug 'missing m)))) ml) ;; Check that all subtrees have correct messages (mapc (lambda (subroot) (let* ((subtree (vm-thread-subtree subroot)) (buf (vm-buffer-of subroot))) (mapc (lambda (m) (unless (and (vm-thread-root m) (eq (vm-thread-root m) (vm-thread-root subroot))) (vm-thread-debug 'spurious m) (setq errors-found t)) (unless (eq buf (vm-buffer-of m)) (vm-thread-debug 'wrong-buffer m) (setq errors-found t))) subtree))) ml) ;; Recover from errors (when errors-found (vm-warn 0 2 (concat "Problem detected with the threads database; " "try vm-fix-my-summary")) ;; (setq vm-thread-obarray 'bonk) ;; (setq vm-thread-subject-obarray 'bonk) )))) ;;; vm-thread.el ends here vm-8.2.0b/lisp/vm-biff.el0000755000175000017500000004277211676442160015424 0ustar srivastasrivasta;;; vm-biff.el --- a xlbiff like tool for VM ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 2001 Robert Fenk ;; ;; Author: Robert Fenk ;; Status: Tested with XEmacs 21.4.15 & VM 7.18 ;; Keywords: VM helpers ;; X-URL: http://www.robf.de/Hacking/elisp ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; ;; Put this file into your load path and add the following line to your .vm ;; file ;; ;; (require 'vm-biff) ;; ;; Try: M-x customize-group vm-biff RET ;; ;; You should set `vm-auto-get-newmail', since otherwise this package ;; does not make any sense! If getting mail is slow, use fetchmail to ;; retrieve it to a local file and uses that file as VM spool file! ;; ;;; Code: (provide 'vm-biff) (eval-when-compile (require 'vm-misc) (require 'vm-summary) ) ;; vm-xemacs.el is a fake file to fool the Emacs 23 compiler (declare-function get-itimer "vm-xemacs.el" (name)) (declare-function start-itimer "vm-xemacs.el" (name function value &optional restart is-idle with-args &rest function-arguments)) (declare-function set-itimer-restart "vm-xemacs.el" (itimer restart)) (declare-function delete-itimer "vm-xemacs" (itimer)) (declare-function set-specifier "vm-xemacs" (specifier value &optional locale tag-set how-to-add)) (declare-function console-type "vm-xemacs" (&optional console)) (declare-function frame-device "vm-xemacs" (&optional frame)) (declare-function window-displayed-height "vm-xemacs" (&optional window)) (defvar current-itimer) (declare-function vm-decode-mime-encoded-words-in-string "vm-mime" (string)) (declare-function vm-goto-message "vm-motion" (n)) (declare-function vm-mouse-set-mouse-track-highlight "vm-mouse" (start end &optional overlay)) (declare-function vm-summary-faces-add "vm-summary-faces" (message)) (when vm-xemacs-p (require 'overlay)) (when vm-fsfemacs-p (defvar horizontal-scrollbar-visible-p nil)) ; group already defined in vm-vars.el ;(defgroup vm nil ; "VM" ; :group 'mail) (defgroup vm-biff nil "The VM biff lib" :group 'vm-ext) (defcustom vm-biff-position 'center "*Position of the popup-frame." :group 'vm-biff :type '(choice (const :tag "center the popup frame" center) (list :tag "Position of the top-left corner." :value (1 1) (integer :tag "X") (integer :tag "Y")))) (defcustom vm-biff-width 120 "*Width of the popup-frame." :group 'vm-biff :type 'integer) (defcustom vm-biff-max-height 10 "*Maximum hight of the popup window." :group 'vm-biff :type 'integer) (defcustom vm-biff-body-peek 50 "*Maximum number of chractes to peek into the body of a message." :group 'vm-biff :type 'integer) (defcustom vm-biff-focus-popup nil "*t if popup window should get the focus after an update." :group 'vm-biff :type 'boolean) (defcustom vm-biff-auto-remove nil "*Number of seconds after the popup window is automatically removed." :group 'vm-biff :type '(choice (integer :tag "Number of seconds" 10) (const :tag "Disable remove" nil))) (defcustom vm-biff-summary-format nil "*Like `vm-summary-format' but for popup buffers." :group 'vm-biff :type '(choice (string :tag "Summary format") (const :tag "Disable own format" nil))) (defcustom vm-biff-selector '(and (new) (not (deleted)) (not (outgoing))) "*virtual folder selector matching messages to display in the pop-up." :group 'vm-biff :type 'sexp) (defcustom vm-biff-place-frame-function 'vm-biff-place-frame "*Function that sets the popup frame position and size." :group 'vm-biff :type 'function) (defcustom vm-biff-select-hook nil "*List of hook functions to be run when selection a message." :group 'vm-biff :type '(repeat (function))) (defcustom vm-biff-select-frame-hook nil "*List of hook functions to be run when selection a message. You may want to add `vm-biff-fvwm-focus-vm-folder-frame'. " :group 'vm-biff :type '(repeat (function))) (defcustom vm-biff-folder-list nil "*List of folders to generate a popup for. The default is all spool files listed in `vm-spool-files'. Testing is done by string-matching it against the current buffer-file-name. Another form is an alist of elements (FODERNAME SELECTOR), where SELECTOR is a virtual folder selector matching the messges which should be displayed. See `vm-biff-selector' for an example and `vm-virtual-folder-alist' on how virtual folder selectors work." :group 'vm-biff :type '(repeat (string))) (defvar vm-biff-keymap nil "Keymap for vm-biff popup buffers.") (when (not vm-biff-keymap) (setq vm-biff-keymap (make-sparse-keymap "VM Biff")) (define-key vm-biff-keymap "q" 'vm-biff-delete-popup) (define-key vm-biff-keymap " " 'vm-biff-delete-popup) (define-key vm-biff-keymap [(space)] 'vm-biff-delete-popup) (define-key vm-biff-keymap [(button1)] 'vm-biff-delete-popup) (define-key vm-biff-keymap [(mouse-1)] 'vm-biff-delete-popup) (define-key vm-biff-keymap [(return)] 'vm-biff-select-message) (define-key vm-biff-keymap [(button2)] 'vm-biff-select-message-mouse) (define-key vm-biff-keymap [(mouse-2)] 'vm-biff-select-message-mouse)) (defun vm-summary-function-V (msg) (let ((body-start (vm-text-of msg)) (body-end (vm-end-of msg)) peek) (if (< vm-biff-body-peek (- body-end body-start)) (setq body-end (+ vm-biff-body-peek body-start))) (save-excursion (save-restriction (set-buffer (vm-buffer-of msg)) (widen) (goto-char body-end) (re-search-forward "$" (point-max) t) (setq peek (vm-decode-mime-encoded-words-in-string (buffer-substring body-start (point)))) (let ((pos 0)) (if (string-match "^\n+" peek pos) (setq peek (replace-match "" t t peek))) (while (setq pos (string-match "\n\n+" peek pos)) (setq peek (replace-match "\n" t t peek))) (setq pos 0) (while (setq pos (string-match "\n" peek pos)) (setq peek (replace-match "\n\t" t t peek) pos (+ 2 pos)))) (setq peek (concat "\t" peek)) (put-text-property 0 (length peek) 'face 'bold peek) peek)))) (defun vm-biff-place-frame (&optional f) "Centers the frame and limits it to `vm-biff-max-height' lines." (let ((f (or f (selected-frame))) (height (1+ (count-lines (point-min) (point-max))))) (if (> height vm-biff-max-height) (setq height vm-biff-max-height)) (set-frame-size f vm-biff-width height) (if (eq 'center vm-biff-position) (set-frame-position f (/ (- (x-display-pixel-width) (frame-pixel-width f)) 2) (/ (- (x-display-pixel-height) (frame-pixel-height f)) 2)) (apply 'set-frame-position f vm-biff-position)))) (defconst vm-biff-frame-properties '(;; common properties (name . "New Mail") (unsplittable . t) (minibuffer . nil) (user-position . t) (menubar-visible-p . nil) (default-toolbar-visible-p . nil) ; (has-modeline-p . nil) (top . 1) (left . 1) ;; Xemacs properties (initially-unmapped . t) (modeline-shadow-thickness . 0) (vertical-scrollbar . nil) ;; GNU Emacs properties (vertical-scroll-bars . nil) (menu-bar-lines . 0) (tool-bar-lines . 0) (visibility . nil) ) "Default properties for popup frame.") (defvar vm-biff-message-pointer nil) (defvar vm-biff-folder-buffer nil) (defvar vm-biff-message-number nil) (defvar vm-biff-folder-frame nil) (defvar vm-biff--folder-window nil) (defun vm-biff-x-p () (if vm-xemacs-p (memq (console-type) '(x mswindows)) t)) (defun vm-biff-get-buffer-window (buf) (if vm-xemacs-p (vm-get-buffer-window buf (vm-biff-x-p) (frame-device)) (vm-get-buffer-window buf (vm-biff-x-p)))) (defun vm-biff-find-folder-window (msg) (let ((buf (vm-buffer-of msg))) (save-excursion (set-buffer buf) (or (vm-biff-get-buffer-window buf) (and vm-presentation-buffer (vm-biff-get-buffer-window vm-presentation-buffer)) (and vm-summary-buffer (vm-biff-get-buffer-window vm-summary-buffer)))))) (defun vm-biff-find-folder-frame (msg) (let ((ff (vm-biff-find-folder-window msg))) (if ff (window-frame ff)))) ;;;###autoload (defun vm-biff-select-message () "Put focus on the folder frame and select the appropiate message." (interactive) (let* ((vm-biff-message-pointer (or (get-text-property (point) 'vm-message-pointer) vm-biff-message-pointer)) (msg (car vm-biff-message-pointer)) (vm-biff-message-number (vm-number-of msg)) (vm-biff-folder-buffer (vm-buffer-of msg)) (vm-biff-folder-window (vm-biff-find-folder-window msg)) vm-biff-folder-frame) (if vm-biff-folder-window (setq vm-biff-folder-frame (window-frame vm-biff-folder-window))) (setq vm-biff-message-pointer nil) (vm-biff-delete-popup) (cond ((and vm-biff-folder-frame (vm-biff-x-p)) (vm-select-frame-set-input-focus vm-biff-folder-frame) (run-hooks 'vm-biff-select-frame-hook) (select-window vm-biff-folder-window)) (vm-biff-folder-window (select-window vm-biff-folder-window)) (t (bury-buffer) (switch-to-buffer vm-biff-folder-buffer))) (sit-for 0) (if vm-biff-message-number (vm-goto-message (string-to-number (vm-number-of msg)))) (run-hooks 'vm-biff-select-hook))) ;;;###autoload (defun vm-biff-select-message-mouse (event) (interactive "e") (mouse-set-point event) (vm-biff-select-message)) (defcustom vm-biff-FvwmCommand-path "/usr/bin/FvwmCommand" "Full qualified path to FvwmCommand." :group 'vm-biff :type 'file) ;;;###autoload (defun vm-biff-fvwm-focus-vm-folder-frame () "Jumps to the frame containing the folder for the selected message. 1) Your Emacs frame needs to have the folder name in its title, see the variable `frame-title-format' on how to set this up. 2) You need to define the FVWM2 function SelectWindow and start the FvwmCommandS module. Therefore, you will need the following lines in your .fvwm2rc file. AddToFunc InitFunction + I Module FvwmCommandS AddToFunc RestartFunction + I Module FvwmCommandS AddToFunc SelectWindow + I Next ($0) Iconify false + I Next ($0) Raise + I Next ($0) WarpToWindow 10p 10p " (interactive) (let ((p (start-process "FvwmCommand" " *FvwmCommand*" vm-biff-FvwmCommand-path "-c"))) (process-send-string p (concat "SelectWindow *" (buffer-name vm-biff-folder-buffer) "*\n")) (process-send-eof p))) ;;;###autoload (defun vm-biff-delete-popup (&optional wf) (interactive) (if (vm-biff-x-p) (delete-frame wf) (if (not (one-window-p)) (delete-window wf))) (sit-for 0)) (defun vm-biff-timer-delete-popup (wf) (if (featurep 'itimer) (delete-itimer current-itimer)) (vm-biff-delete-popup wf)) (defvar vm-biff-message-pointer nil) (make-variable-buffer-local 'vm-biff-message-pointer) (defvar horizontal-scrollbar-visible-p) ; defined for XEmacs only ;;;###autoload (defun vm-biff-popup (&optional force) "Scan the current VM folder for new messages and popup a summary frame." (interactive (list current-prefix-arg)) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (when (not vm-biff-folder-list) (setq vm-biff-folder-list (if (stringp (car vm-spool-files)) (list (expand-file-name vm-primary-inbox vm-folder-directory)) (mapcar (lambda (f) (expand-file-name (car f) vm-folder-directory)) vm-spool-files)))) (let* ((mp vm-message-pointer) (folder (buffer-name)) (do-mouse-track (or (and vm-mouse-track-summary (vm-mouse-support-possible-p)) vm-summary-enable-faces)) (buf (get-buffer-create (concat " *new messages in VM folder: " folder "*"))) selector msg new-messages wf) (let ((fl vm-biff-folder-list)) (while fl (if (stringp (car fl)) (if (string-match (car fl) (or (buffer-file-name) (buffer-name))) (setq selector (list vm-biff-selector) fl nil)) (if (string-match (caar fl) (or (buffer-file-name) (buffer-name))) (setq selector (cdar fl) fl nil))) (setq fl (cdr fl)))) (when selector ;; collect the new messages (set-buffer buf) (setq buffer-read-only nil) (erase-buffer) (let (start) (while mp (setq msg (car mp)) (when (apply 'vm-vs-or msg selector) (setq start (point)) (vm-tokenized-summary-insert msg (vm-summary-sprintf (or vm-biff-summary-format vm-summary-format) msg t)) (put-text-property start (point) 'vm-message-pointer mp) (when do-mouse-track (vm-mouse-set-mouse-track-highlight start (point))) (if vm-summary-enable-faces (vm-summary-faces-add msg) (vm-summary-highlight-region start (point) vm-summary-highlight-face)) (if (not new-messages) (setq new-messages mp))) (setq mp (cdr mp)))) (when (and new-messages (or force (not (equal new-messages vm-biff-message-pointer)))) (setq msg (car new-messages)) (backward-delete-char 1) (goto-char (point-min)) (setq truncate-lines t buffer-read-only t) (use-local-map vm-biff-keymap) (setq vm-biff-message-pointer new-messages) ;; if in the minibuffer then seletc a different window (if (active-minibuffer-window) (other-window 1)) ;; generate a own window/frame showing the messages (if (vm-biff-x-p) ;; X Window System or MS Windows (let* ((sf (selected-frame)) (ff (vm-biff-find-folder-frame msg)) (props (if ff (cons (cons 'popup ff) vm-biff-frame-properties) vm-biff-frame-properties)) (mf (or (and (if vm-xemacs-p (vm-get-buffer-window buf t (frame-device)) (vm-get-buffer-window buf t)) (window-frame (vm-biff-get-buffer-window buf))) (make-frame props)))) (select-frame mf) (switch-to-buffer buf) (if vm-xemacs-p (set-specifier horizontal-scrollbar-visible-p nil)) (if (functionp vm-biff-place-frame-function) (funcall vm-biff-place-frame-function)) (make-frame-visible mf) (setq wf mf) (if vm-biff-focus-popup (vm-select-frame-set-input-focus mf) (select-frame sf))) ;; Terminal (let ((w (vm-get-buffer-window buf)) (window-min-height 2) (h (count-lines (point-min) (point-max)))) (if w (if vm-biff-focus-popup (select-window w)) (setq wf (split-window (selected-window)))) (sit-for 0) (switch-to-buffer buf) (if (> h vm-biff-max-height) (setq h vm-biff-max-height)) (if vm-xemacs-p (setq h (- (window-displayed-height) h)) (setq h (- (window-height) h))) (if (not (one-window-p)) (shrink-window h))))) (if vm-biff-auto-remove (cond ((condition-case nil (progn (require 'itimer) t) (error nil)) (start-itimer (buffer-name) 'vm-biff-timer-delete-popup vm-biff-auto-remove nil t t wf)) ((condition-case nil (progn (require 'timer) t) (error nil)) (run-at-time vm-biff-auto-remove nil 'vm-biff-timer-delete-popup wf)))))))) (add-hook 'vm-arrived-messages-hook 'vm-biff-popup t) vm-8.2.0b/lisp/vm-motion.el0000755000175000017500000005225011676442160016013 0ustar srivastasrivasta;;; vm-motion.el --- Commands to move around in a VM folder ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-motion) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-thread) (require 'vm-window) (require 'vm-page) ) (declare-function vm-so-sortable-subject "vm-sort" (message)) (defun vm-record-and-change-message-pointer (old new) "Change the `vm-message-pointer' of the folder from OLD to NEW, both of which must be pointers into the `vm-message-list'." (intern (buffer-name) vm-buffers-needing-display-update) (vm-garbage-collect-message) (setq vm-last-message-pointer old vm-message-pointer new vm-need-summary-pointer-update t)) ;;;###autoload (defun vm-goto-message (n) "Go to the message numbered N. Interactively N is the prefix argument. If no prefix arg is provided N is prompted for in the minibuffer. If vm-follow-summary-cursor is non-nil this command will go to the message under the cursor in the summary buffer if the summary window is selected. This only happens if no prefix argument is given." (interactive (list (cond (current-prefix-arg (prefix-numeric-value current-prefix-arg)) ((vm-follow-summary-cursor) nil) ((vm-follow-folders-summary-cursor) nil) (t (let ((last-command last-command) (this-command this-command)) (vm-read-number "Go to message: ")))))) (if (null n) () ; nil means work has been done already (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-goto-message) '(vm-goto-message)) (let ((cons (nthcdr (1- n) vm-message-list))) (if (null cons) (error "No such message.")) (if (eq vm-message-pointer cons) (vm-present-current-message) (vm-record-and-change-message-pointer vm-message-pointer cons) (vm-present-current-message) ;;(vm-warn 0 0 "start of message you want is: %s" ;; (vm-su-start-of (car vm-message-pointer))) (if (and (vm-summary-operation-p) vm-summary-show-threads (get-text-property (+ (vm-su-start-of (car vm-message-pointer)) 2) 'invisible vm-summary-buffer)) (vm-expand-thread (vm-thread-root (car vm-message-pointer)))) )))) ;;;###autoload (defun vm-goto-message-last-seen () "Go to the message last previewed." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-goto-message-last-seen) '(vm-goto-message-last-seen)) (if vm-last-message-pointer (progn (vm-record-and-change-message-pointer vm-message-pointer vm-last-message-pointer) (vm-present-current-message)))) (defalias 'vm-goto-last-message-seen 'vm-goto-message-last-seen) ;;;###autoload (defun vm-goto-parent-message () "Go to the parent of the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-build-threads-if-unbuilt) (vm-display nil nil '(vm-goto-parent-message) '(vm-goto-parent-message)) (let ((lineage (cdr (reverse (vm-thread-list (car vm-message-pointer))))) (message nil)) (cond ((null lineage) (vm-inform 5 "Message has no parent listed.")) ((vm-th-messages-of (car lineage)) (setq message (car lineage))) ((y-or-n-p (concat "Parent message is not in this folder. " "Go to the next ancestor? ")) (while (and lineage (null (vm-th-messages-of (car lineage)))) (setq lineage (cdr lineage))) (if (null lineage) (vm-inform 5 "Message has no ancestors in this folder") (setq message (car lineage))))) (when message (setq message (car (vm-th-messages-of (car lineage)))) (vm-record-and-change-message-pointer vm-message-pointer (vm-message-position message)) (vm-present-current-message)))) (defun vm-check-count (count) (if (>= count 0) (if (< (length vm-message-pointer) count) (signal 'end-of-folder nil)) (if (< (1+ (- (length vm-message-list) (length vm-message-pointer))) (vm-abs count)) (signal 'beginning-of-folder nil)))) (defun vm-move-message-pointer (direction) "Move vm-message-pointer along DIRECTION by one position. DIRECTION is one of 'forward and 'backward. USR, 2011-01-18" (let ((mp vm-message-pointer)) (if (eq direction 'forward) (progn (setq mp (cdr mp)) (if (null mp) (if vm-circular-folders (setq mp vm-message-list) (signal 'end-of-folder nil)))) (setq mp (vm-reverse-link-of (car mp))) (if (null mp) (if vm-circular-folders (setq mp (vm-last vm-message-list)) (signal 'beginning-of-folder nil)))) (setq vm-message-pointer mp))) (defun vm-should-skip-message (mp &optional skip-dogmatically) "Checks various preference settings and message attributes to determine whether the current message should be skipped during movement. The first argument MP is a pointer into the message-list. The optional argument SKIP-DOGMATICALLY asks it to follow a strong interpretation of the preferences. USR, 2011-01-18" (or (and (if skip-dogmatically vm-skip-deleted-messages (eq vm-skip-deleted-messages t)) (vm-deleted-flag (car mp))) (vm-should-skip-hidden-message mp) (and (if skip-dogmatically vm-skip-read-messages (eq vm-skip-read-messages t)) (or (vm-deleted-flag (car mp)) (not (or (vm-new-flag (car mp)) (vm-unread-flag (car mp)))))) (and (eq last-command 'vm-next-command-uses-marks) (null (vm-mark-of (car mp)))))) (defun vm-should-skip-hidden-message (mp) "Checks if the current message in MP should be skipped as a hidden message in the summary buffer." (and vm-summary-buffer (with-current-buffer vm-summary-buffer (and vm-skip-collapsed-sub-threads vm-summary-enable-thread-folding vm-summary-show-threads (> (vm-thread-indentation (car mp)) 0) (vm-collapsed-root-p (vm-thread-root (car mp))) (get-text-property (vm-su-start-of (car mp)) 'invisible))))) ;;;###autoload (defun vm-next-message (&optional count retry signal-errors) "Go forward one message and preview it. With prefix arg (optional first argument) COUNT, go forward COUNT messages. A negative COUNT means go backward. If the absolute value of COUNT is greater than 1, then the values of the variables vm-skip-deleted-messages and vm-skip-read-messages are ignored. When invoked on marked messages (via `vm-next-command-uses-marks') this command 'sees' marked messages as it moves." ;; second arg RETRY non-nil means retry a failed move, giving ;; not nil-or-t values of the vm-skip variables a chance to ;; work. ;; ;; third arg SIGNAL-ERRORS non-nil means that if after ;; everything we still have bashed into the end or beginning of ;; folder before completing the move, signal ;; beginning-of-folder or end-of-folder. Otherwise no error ;; will be signaled. ;; ;; Note that interactively all args are 1, so error signaling ;; and retries apply to all interactive moves. (interactive "p\np\np") ;;(vm-inform 8 "running vm next message") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate (if signal-errors 1 0) (vm-interactive-p)) ;; include other commands that call vm-next-message so that the ;; correct window configuration is applied for these particular ;; non-interactive calls. (vm-display nil nil '(vm-next-message vm-delete-message vm-undelete-message vm-scroll-forward) (list this-command)) (or count (setq count 1)) (let ((oldmp vm-message-pointer) (use-marks (eq last-command 'vm-next-command-uses-marks)) (error) (direction (if (> count 0) 'forward 'backward)) (count (vm-abs count))) (cond ((null vm-message-pointer) (setq vm-message-pointer vm-message-list)) ((/= count 1) (condition-case () (let ((oldmp oldmp)) (while (not (zerop count)) (vm-move-message-pointer direction) (if (and use-marks (null (vm-mark-of (car vm-message-pointer)))) (progn (while (and (not (eq vm-message-pointer oldmp)) (null (vm-mark-of (car vm-message-pointer)))) (vm-move-message-pointer direction)) (if (eq vm-message-pointer oldmp) ;; terminate the loop (setq count 1) ;; reset for next pass (setq oldmp vm-message-pointer)))) (if (not (vm-should-skip-hidden-message vm-message-pointer)) (vm-decrement count)))) (beginning-of-folder (setq error 'beginning-of-folder)) (end-of-folder (setq error 'end-of-folder)))) (t (condition-case () (progn (vm-move-message-pointer direction) (while (and (not (eq oldmp vm-message-pointer)) (vm-should-skip-message vm-message-pointer t)) (vm-move-message-pointer direction)) ;; Retry the move if we've gone a complete circle and ;; retries are allowed and there are other messages ;; besides this one. (and (eq vm-message-pointer oldmp) retry (cdr vm-message-list) (progn (vm-move-message-pointer direction) (while (and (not (eq oldmp vm-message-pointer)) (vm-should-skip-message vm-message-pointer)) (vm-move-message-pointer direction))))) (beginning-of-folder ;; we bumped into the beginning of the folder without finding ;; a suitable stopping point; retry the move if we're allowed. (setq vm-message-pointer oldmp) ;; if the retry fails, we make sure the message pointer ;; is restored to its old value. (if retry (setq vm-message-pointer (condition-case () (let ((vm-message-pointer vm-message-pointer)) (vm-move-message-pointer direction) (while (vm-should-skip-message vm-message-pointer) (vm-move-message-pointer direction)) vm-message-pointer ) (beginning-of-folder (setq error 'beginning-of-folder) oldmp ))) (setq error 'beginning-of-folder))) (end-of-folder ;; we bumped into the end of the folder without finding ;; a suitable stopping point; retry the move if we're allowed. (when (and (vm-summary-operation-p) (get-text-property (vm-su-start-of (car vm-message-pointer)) 'invisible vm-summary-buffer)) (setq error 'end-of-folder) (setq retry nil)) (setq vm-message-pointer oldmp) ;; if the retry fails, we make sure the message pointer ;; is restored to its old value. (if retry (setq vm-message-pointer (condition-case () (let ((vm-message-pointer vm-message-pointer)) (vm-move-message-pointer direction) (while (vm-should-skip-message vm-message-pointer) (vm-move-message-pointer direction)) vm-message-pointer ) (end-of-folder (setq error 'end-of-folder) oldmp ))) (setq error 'end-of-folder)))))) (unless (eq vm-message-pointer oldmp) (vm-record-and-change-message-pointer oldmp vm-message-pointer) (vm-present-current-message)) (when (and error signal-errors) (signal error nil)))) ;;;###autoload (defun vm-previous-message (&optional count retry signal-errors) "Go back one message and preview it. With prefix arg COUNT, go backward COUNT messages. A negative COUNT means go forward. If the absolute value of COUNT > 1 the values of the variables vm-skip-deleted-messages and vm-skip-read-messages are ignored." (interactive "p\np\np") (or count (setq count 1)) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 t) (vm-display nil nil '(vm-previous-message) '(vm-previous-message)) (vm-next-message (- count) retry signal-errors)) ;;;###autoload (defun vm-next-message-no-skip (&optional count) "Like vm-next-message but will not skip deleted or read messages." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-next-message-no-skip) '(vm-next-message-no-skip)) (when (and vm-summary-enable-thread-folding vm-summary-show-threads vm-summary-thread-folding-on-motion) (with-current-buffer vm-summary-buffer (let ((msg (vm-summary-message-at-point)) (root (vm-thread-root (vm-summary-message-at-point)))) ;; if last message collapse (and do not move) (if (= (string-to-number (vm-number-of msg)) (+ (string-to-number (vm-number-of root)) (- (vm-thread-count root) 1))) (vm-collapse-thread t))))) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil) (vm-skip-collapsed-sub-threads (not vm-summary-thread-folding-on-motion))) (vm-next-message count nil t))) ;; backward compatibility (fset 'vm-Next-message 'vm-next-message-no-skip) ;;;###autoload (defun vm-previous-message-no-skip (&optional count) "Like vm-previous-message but will not skip deleted or read messages." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-previous-message-no-skip) '(vm-previous-message-no-skip)) (when (and vm-summary-enable-thread-folding vm-summary-show-threads vm-summary-thread-folding-on-motion) (with-current-buffer vm-summary-buffer (let ((msg (vm-summary-message-at-point)) (root (vm-thread-root (vm-summary-message-at-point)))) ;; if root message collapse (moving up) (if (eq msg root) (vm-collapse-thread t))))) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil) (vm-skip-collapsed-sub-threads (not vm-summary-thread-folding-on-motion))) (vm-previous-message count))) ;; backward compatibility (fset 'vm-Previous-message 'vm-previous-message-no-skip) ;;;###autoload (defun vm-next-unread-message () "Move forward to the nearest new or unread message, if there is one." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-next-unread-message) '(vm-next-unread-message)) (condition-case () (let ((vm-skip-read-messages t) (oldmp vm-message-pointer)) (vm-next-message 1 nil t) ;; in case vm-circular-folders is non-nil (and (eq vm-message-pointer oldmp) (signal 'end-of-folder nil))) (end-of-folder (vm-inform 5 "No next unread message")))) ;;;###autoload (defun vm-previous-unread-message () "Move backward to the nearest new or unread message, if there is one." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-previous-unread-message) '(vm-previous-unread-message)) (condition-case () (let ((vm-skip-read-messages t) (oldmp vm-message-pointer)) (vm-previous-message) ;; in case vm-circular-folders is non-nil (and (eq vm-message-pointer oldmp) (signal 'beginning-of-folder nil))) (beginning-of-folder (vm-inform 5 "No previous unread message")))) ;;;###autoload (defun vm-next-message-same-subject () "Move forward to the nearest message with the same subject. vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply to the subject comparisons." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-next-message-same-subject) '(vm-next-message-same-subject)) (let ((oldmp vm-message-pointer) (done nil) (subject (vm-so-sortable-subject (car vm-message-pointer)))) (condition-case () (progn (while (not done) (vm-move-message-pointer 'forward) (if (eq oldmp vm-message-pointer) (signal 'end-of-folder nil)) (if (equal subject (vm-so-sortable-subject (car vm-message-pointer))) (setq done t))) (vm-record-and-change-message-pointer oldmp vm-message-pointer) (vm-present-current-message)) (end-of-folder (setq vm-message-pointer oldmp) (vm-inform 5 "No next message with the same subject"))))) ;;;###autoload (defun vm-previous-message-same-subject () "Move backward to the nearest message with the same subject. vm-subject-ignored-prefix and vm-subject-ignored-suffix will apply to the subject comparisons." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-previous-message-same-subject) '(vm-previous-message-same-subject)) (let ((oldmp vm-message-pointer) (done nil) (subject (vm-so-sortable-subject (car vm-message-pointer)))) (condition-case () (progn (while (not done) (vm-move-message-pointer 'backward) (if (eq oldmp vm-message-pointer) (signal 'beginning-of-folder nil)) (if (equal subject (vm-so-sortable-subject (car vm-message-pointer))) (setq done t))) (vm-record-and-change-message-pointer oldmp vm-message-pointer) (vm-present-current-message)) (beginning-of-folder (setq vm-message-pointer oldmp) (vm-inform 5 "No previous message with the same subject"))))) (defun vm-find-first-unread-message (new) (let (mp unread-mp) (setq mp vm-message-list) (if new (while mp (if (and (vm-new-flag (car mp)) (not (vm-deleted-flag (car mp)))) (setq unread-mp mp mp nil) (setq mp (cdr mp)))) (while mp (if (and (or (vm-new-flag (car mp)) (vm-unread-flag (car mp))) (not (vm-deleted-flag (car mp)))) (setq unread-mp mp mp nil) (setq mp (cdr mp))))) unread-mp )) (defun vm-thoughtfully-select-message () "Select a message in the current folder for the cursor position, which should be the first new message, if there is any, the first unread message, if there is any, or the position the cursor was at the last time the folder was visited. USR, 2010-03-08" (let ((new (and vm-jump-to-new-messages (vm-find-first-unread-message t))) (unread (and vm-jump-to-unread-messages (vm-find-first-unread-message nil))) fix mp) (if (null vm-message-pointer) (setq fix (vm-last vm-message-list))) (setq mp (or new unread fix)) (if (and mp (not (eq mp vm-message-pointer))) (progn (vm-record-and-change-message-pointer vm-message-pointer mp) mp ) nil ))) ;;;###autoload (defun vm-follow-summary-cursor () "Select the message under the cursor in the summary window before executing commands that operate on the current message. This occurs only when the summary buffer window is the selected window. If a new message is selected then return t, otherwise nil. USR, 2010-03-08" (and vm-follow-summary-cursor (eq major-mode 'vm-summary-mode) (let ((point (point)) message-pointer message-list mp) (save-excursion (set-buffer vm-mail-buffer) (setq message-pointer vm-message-pointer message-list vm-message-list)) (cond ((or (null message-pointer) (and (>= point (vm-su-start-of (car message-pointer))) (< point (vm-su-end-of (car message-pointer))))) nil ) ;; the position at eob belongs to the last message ((and (eobp) (= (vm-su-end-of (car message-pointer)) point)) nil ) ((eobp) (save-excursion (while (get-text-property (- (point) 3) 'invisible) (goto-char (- (vm-su-start-of (get-text-property (- (point) 3) 'vm-message)) 3))) (vm-goto-message (string-to-number (vm-number-of (get-text-property (- (point) 3) 'vm-message))))) t) ;; make the position at eob belong to the last message ;; ((eobp) ;; (while (get-text-property (point) 'invisible) ;; (goto-char (1- (point))) ;; setq mp ;; ;;(setq mp (vm-last message-pointer)) ;; (save-excursion ;; (set-buffer vm-mail-buffer) ;; (vm-record-and-change-message-pointer ;; vm-message-pointer mp) ;; (vm-present-current-message) ;; ;; return non-nil so the caller will know that ;; ;; a new message was selected. ;; t )) (t (if (< point (vm-su-start-of (car message-pointer))) (setq mp message-list) (setq mp (cdr message-pointer) message-pointer nil)) (while (or (and (not (eq mp message-pointer)) (>= point (vm-su-end-of (car mp)))) (get-text-property (+ (vm-su-start-of (car mp)) 3) 'invisible)) (setq mp (cdr mp))) (if (not (eq mp message-pointer)) (save-excursion (set-buffer vm-mail-buffer) (vm-record-and-change-message-pointer vm-message-pointer mp) ;; preview disabled to avoid message ;; loading. USR, 2010-09-30 ;; (vm-present-current-message) ;; return non-nil so the caller will know that ;; a new message was selected. t ))))))) ;;; vm-motion.el ends here vm-8.2.0b/lisp/vm-mark.el0000755000175000017500000004061411676442160015441 0ustar srivastasrivasta;;; vm-mark.el --- Commands for handling messages marks ;; ;; This file is part of VM ;; ;; Copyright (C) 1990, 1993, 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-mark) (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-motion) (require 'vm-thread) (require 'vm-summary) (require 'vm-sort) (require 'vm-virtual) (require 'vm-window) ) ;;;###autoload (defun vm-clear-all-marks () "Removes all message marks in the current folder." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-inform 5 "Clearing all marks...") (let ((mp vm-message-list)) (while mp (if (vm-mark-of (car mp)) (progn (vm-set-mark-of (car mp) nil) (vm-mark-for-summary-update (car mp) t))) (setq mp (cdr mp)))) (vm-display nil nil '(vm-clear-all-marks) '(vm-clear-all-marks marking-message)) (vm-update-summary-and-mode-line) (vm-inform 5 "Clearing all marks... done")) ;;;###autoload (defun vm-toggle-all-marks () "Toggles all message marks in the current folder. Messages that are unmarked will become marked and messages that are marked will become unmarked." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-inform 5 "Toggling all marks...") (let ((mp vm-message-list)) (while mp (vm-set-mark-of (car mp) (not (vm-mark-of (car mp)))) (vm-mark-for-summary-update (car mp) t) (setq mp (cdr mp)))) (vm-display nil nil '(vm-toggle-all-marks) '(vm-toggle-all-marks marking-message)) (vm-update-summary-and-mode-line) (vm-inform 5 "Toggling all marks... done")) ;;;###autoload (defun vm-mark-all-messages () "Mark all messages in the current folder." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-inform 5 "Marking all messages...") (let ((mp vm-message-list)) (while mp (vm-set-mark-of (car mp) t) (vm-mark-for-summary-update (car mp) t) (setq mp (cdr mp)))) (vm-display nil nil '(vm-mark-all-messages) '(vm-mark-all-messages marking-message)) (vm-update-summary-and-mode-line) (vm-inform 5 "Marking all messages... done")) ;;;###autoload (defun vm-mark-message (count) "Mark the current message. Numeric prefix argument N means mark the current message and the next N-1 messages. A negative N means mark the current message and the previous N-1 messages." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((direction (if (< count 0) 'backward 'forward)) (count (vm-abs count)) (oldmp vm-message-pointer) (vm-message-pointer vm-message-pointer)) (while (not (zerop count)) (if (not (vm-mark-of (car vm-message-pointer))) (progn (vm-set-mark-of (car vm-message-pointer) t) (vm-mark-for-summary-update (car vm-message-pointer) t))) (vm-decrement count) (if (not (zerop count)) (vm-move-message-pointer direction)))) (vm-display nil nil '(vm-mark-message) '(vm-mark-message marking-message)) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-unmark-message (count) "Remove the mark from the current message. Numeric prefix argument N means unmark the current message and the next N-1 messages. A negative N means unmark the current message and the previous N-1 messages." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Unmark"))) (while mlist (if (vm-mark-of (car mlist)) (progn (vm-set-mark-of (car mlist) nil) (vm-mark-for-summary-update (car mlist) t))) (setq mlist (cdr mlist)))) (vm-display nil nil '(vm-unmark-message) '(vm-unmark-message marking-message)) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-mark-summary-region () "Mark all messages with summary lines contained in the region." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (null vm-summary-buffer) (error "No summary.")) (set-buffer vm-summary-buffer) (if (not (mark)) (error "The region is not active now")) (vm-mark-or-unmark-summary-region t) (vm-display nil nil '(vm-mark-summary-region) '(vm-mark-summary-region marking-message)) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-unmark-summary-region () "Remove marks from messages with summary lines contained in the region." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (null vm-summary-buffer) (error "No summary.")) (set-buffer vm-summary-buffer) (if (not (mark)) (error "The region is not active now")) (vm-mark-or-unmark-summary-region nil) (vm-display nil nil '(vm-unmark-summary-region) '(vm-unmark-summary-region marking-message)) (vm-update-summary-and-mode-line)) (defun vm-mark-or-unmark-summary-region (markit) ;; The folder buffers copy of vm-message-list has already been ;; propagated to the summary buffer. (let ((mp vm-message-list) (beg (point)) (end (mark)) tmp m) (if (> beg end) (setq tmp beg beg end end tmp)) (while mp (setq m (car mp)) (if (not (eq (not markit) (not (vm-mark-of m)))) (if (or (and (> (vm-su-end-of m) beg) (< (vm-su-end-of m) end)) (and (>= (vm-su-start-of m) beg) (< (vm-su-start-of m) end)) (and (>= beg (vm-su-start-of m)) (< beg (vm-su-end-of m)))) (progn (vm-set-mark-of m markit) (vm-mark-for-summary-update m t)))) (setq mp (cdr mp))))) (defun vm-mark-or-unmark-messages-with-selector (val selector arg) (let ((mlist vm-message-list) (virtual (eq major-mode 'vm-virtual-mode)) (arglist (if arg (list arg) nil)) (count 0)) (setq selector (intern (concat "vm-vs-" (symbol-name selector)))) (while mlist (if (if virtual (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of (car mlist)))) (apply selector (vm-real-message-of (car mlist)) arglist)) (apply selector (car mlist) arglist)) (progn (vm-set-mark-of (car mlist) val) (vm-mark-for-summary-update (car mlist) t) (vm-increment count))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-mark-matching-messages vm-unmark-matching-messages) (list this-command 'marking-message)) (vm-update-summary-and-mode-line) (vm-inform 5 "%s message%s %smarked" (if (> count 0) count "No") (if (= 1 count) "" "s") (if val "" "un")))) ;;;###autoload (defun vm-mark-matching-messages (selector &optional arg) "Mark messages matching some criterion. You can use any of the virtual folder selectors, except for the `and', `or' and `not' selectors. See the documentation for the variable vm-virtual-folder-alist for more information." (interactive (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-select-folder-buffer) (vm-read-virtual-selector "Mark messages: ")))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-with-selector t selector arg)) ;;;###autoload (defun vm-unmark-matching-messages (selector &optional arg) "Unmark messages matching some criterion. You can use any of the virtual folder selectors, except for the `and', `or' and `not' selectors. See the documentation for the variable vm-virtual-folder-alist for more information." (interactive (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-select-folder-buffer) (vm-read-virtual-selector "Unmark messages: ")))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-with-selector nil selector arg)) ;;;###autoload (defun vm-mark-thread-subtree () "Mark all messages in the thread tree rooted at the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-thread-subtree t)) ;;;###autoload (defun vm-unmark-thread-subtree () "Unmark all messages in the thread tree rooted at the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-thread-subtree nil)) (defun vm-mark-or-unmark-thread-subtree (mark) (vm-build-threads-if-unbuilt) (let ((list (vm-thread-subtree (vm-thread-symbol (car vm-message-pointer))))) (while list (unless (eq (vm-mark-of (car list)) mark) (vm-set-mark-of (car list) mark) (vm-mark-for-summary-update (car list))) (setq list (cdr list)))) ;; (let ((list (list (car vm-message-pointer))) ;; (loop-obarray (make-vector 29 0)) ;; subject-sym id-sym) ;; (while list ;; (if (not (eq (vm-mark-of (car list)) mark)) ;; (progn ;; (vm-set-mark-of (car list) mark) ;; (vm-mark-for-summary-update (car list)))) ;; (setq id-sym (vm-last-elem (vm-thread-list (car list)))) ;; (if (null (intern-soft (symbol-name id-sym) loop-obarray)) ;; (progn ;; (intern (symbol-name id-sym) loop-obarray) ;; (nconc list (copy-sequence (vm-th-child-messages-of id-sym))) ;; (setq subject-sym (intern (vm-so-sortable-subject (car list)) ;; vm-thread-subject-obarray)) ;; (if (and (boundp subject-sym) ;; (eq id-sym (aref (symbol-value subject-sym) 0))) ;; (nconc list (copy-sequence ;; (aref (symbol-value subject-sym) 2)))))) ;; (setq list (cdr list)))) (vm-display nil nil '(vm-mark-thread-subtree vm-unmark-thread-subtree) (list this-command 'marking-message)) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-mark-messages-same-subject () "Mark all messages with the same subject as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-same-subject t)) ;;;###autoload (defun vm-unmark-messages-same-subject () "Unmark all messages with the same subject as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-same-subject nil)) (defun vm-mark-or-unmark-messages-same-subject (mark) (let ((mp vm-message-list) (mark-count 0) (subject (vm-so-sortable-subject (car vm-message-pointer)))) (while mp (if (and (not (eq (vm-mark-of (car mp)) mark)) (string-equal subject (vm-so-sortable-subject (car mp)))) (progn (vm-set-mark-of (car mp) mark) (vm-increment mark-count) (vm-mark-for-summary-update (car mp) t))) (setq mp (cdr mp))) (vm-display nil nil '(vm-mark-messages-same-subject vm-unmark-messages-same-subject) (list this-command 'marking-message)) (vm-update-summary-and-mode-line) (if (zerop mark-count) (vm-inform 5 "No messages %smarked" (if mark "" "un")) (vm-inform 5 "%d message%s %smarked" mark-count (if (= 1 mark-count) "" "s") (if mark "" "un"))))) ;;;###autoload (defun vm-mark-messages-same-author () "Mark all messages with the same author as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-same-author t)) ;;;###autoload (defun vm-unmark-messages-same-author () "Unmark all messages with the same author as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-same-author nil)) (defun vm-mark-or-unmark-messages-same-author (mark) (let ((mp vm-message-list) (mark-count 0) (author (vm-su-from (car vm-message-pointer)))) (while mp (if (and (not (eq (vm-mark-of (car mp)) mark)) (vm-string-equal-ignore-case author (vm-su-from (car mp)))) (progn (vm-set-mark-of (car mp) mark) (vm-increment mark-count) (vm-mark-for-summary-update (car mp) t))) (setq mp (cdr mp))) (vm-display nil nil '(vm-mark-messages-same-author vm-unmark-messages-same-author) (list this-command 'marking-message)) (vm-update-summary-and-mode-line) (if (zerop mark-count) (vm-inform 5 "No messages %smarked" (if mark "" "un")) (vm-inform 5 "%d message%s %smarked" mark-count (if (= 1 mark-count) "" "s") (if mark "" "un"))))) (defun vm-mark-or-unmark-messages-with-virtual-folder (val name) (let* ((vfolder (assoc name vm-virtual-folder-alist)) vm-virtual-folder-definition m mlist clauses (count 0)) (or vfolder (error "No such virtual folder, %s" name)) (setq vfolder (vm-copy vfolder)) (setq clauses (cdr vfolder)) (while clauses (setcar (car clauses) (list (list 'get-buffer (buffer-name)))) (setq clauses (cdr clauses))) (setq vm-virtual-folder-definition vfolder) (setq mlist (vm-build-virtual-message-list vm-message-list t)) (if (null vm-real-buffers) (while mlist (setq m (vm-real-message-of (car mlist))) (vm-set-mark-of m val) (vm-mark-for-summary-update m t) (vm-increment count) (setq mlist (cdr mlist))) (let ((curbuf (current-buffer)) vmlist) (while mlist (setq m (vm-real-message-of (car mlist)) vmlist (vm-virtual-messages-of m)) (while vmlist (cond ((eq curbuf (vm-buffer-of (car vmlist))) (vm-set-mark-of (car vmlist) val) (vm-mark-for-summary-update (car vmlist) t) (vm-increment count) (setq vmlist nil)) (t (setq vmlist (cdr vmlist))))) (setq mlist (cdr mlist))))) (vm-display nil nil '(vm-mark-matching-messages-with-virtual-folder vm-unmark-matching-messages-with-virtual-folder) (list this-command 'marking-message)) (vm-update-summary-and-mode-line) (vm-inform 5 "%s message%s %smarked" (if (> count 0) count "No") (if (= 1 count) "" "s") (if val "" "un")))) ;;;###autoload (defun vm-mark-matching-messages-with-virtual-folder (name) "Mark messages that are matched by the selectors of virtual folder NAME." (interactive (let ((last-command last-command) (this-command this-command)) (list (completing-read "Mark messages matching this virtual folder's selectors: " vm-virtual-folder-alist nil t)))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-with-virtual-folder t name)) ;;;###autoload (defun vm-unmark-matching-messages-with-virtual-folder (name) "Unmark messages that are matched by the selectors of virtual folder NAME." (interactive (let ((last-command last-command) (this-command this-command)) (list (completing-read "Unmark message matching this virtual folder's selectors: " vm-virtual-folder-alist nil t)))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-mark-or-unmark-messages-with-virtual-folder nil name)) ;;;###autoload (defun vm-next-command-uses-marks () "Does nothing except insure that the next VM command will operate only on the marked messages in the current folder. This only works for commands bound to key, menu or button press events. M-x vm-command will not work." (interactive) (setq this-command 'vm-next-command-uses-marks) (vm-inform 5 "Next command uses marks...") (vm-display nil nil '(vm-next-command-uses-marks) '(vm-next-command-uses-marks))) ;;;###autoload (defun vm-marked-messages () (let (list (mp vm-message-list)) (while mp (if (vm-mark-of (car mp)) (setq list (cons (car mp) list))) (setq mp (cdr mp))) (nreverse list))) ;;;###autoload (defun vm-mark-help () (interactive) (vm-display nil nil '(vm-mark-help) '(vm-mark-help)) (vm-inform 0 "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ...")) ;;; vm-mark.el ends here vm-8.2.0b/lisp/vm-vars.el0000755000175000017500000107062211676442160015465 0ustar srivastasrivasta ;;; vm-vars.el --- VM user and internal variable initialization ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-2003 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-vars) (require 'vm-version) (declare-function vm-parse "vm-misc" (string regexp &optional matchn matches)) (declare-function vm-delete-directory-names "vm-misc" (list)) (declare-function vm-display "vm-window" (buffer display commands configs &optional do-not-raise)) (declare-function xemacs-locate-data-directory "vm-xemacs" (name)) (fset 'xemacs-locate-data-directory 'locate-data-directory) ;; Don't use vm-device-type here because it may not be loaded yet. (declare-function device-type "vm-xemacs" ()) ;; (fset 'xemacs-device-type 'device-type) ;; Custom group definitions (defgroup vm nil "The VM mail reader." :link '(custom-manual "(vm)Top") :link '(url-link :tag "VM Homepage" "http://www.nongnu.org/viewmail/") :group 'mail) (defgroup vm-faces nil "Faces for VM." :group 'vm) (defgroup vm-misc nil "Miscellaneous VM configuration options." :group 'vm) (defgroup vm-folders nil "Mail folder settings for VM." :group 'vm) (defgroup vm-pop nil "POP3 mail folders for VM." :group 'vm-folders) (defgroup vm-imap nil "IMAP mail folders for VM." :group 'vm-folders) (defgroup vm-mime nil "MIME options for VM." :group 'vm) (defgroup vm-helpers nil "External helper programs used by VM." :group 'vm) (defgroup vm-summary nil "Options for VM's summary window." :group 'vm) (defgroup vm-hooks nil "Hooks for the VM mail reader." :group 'vm) (defgroup vm-digest nil "Options affecting VM's handling of digests." :group 'vm) (defgroup vm-frames nil "Options affecting frames and windows in VM." :group 'vm) (defgroup vm-url nil "Options affecting handling of URLs in VM." :group 'vm) (defgroup vm-compose nil "Options affecting mail composition within VM." :group 'vm) (defgroup vm-presentation nil "Options affecting the presentation of messages in VM." :group 'vm) (defgroup vm-dispose nil "Options affecting the saving, deleting and expunging of messages in VM." :group 'vm) (defgroup vm-print nil "Options affecting printing of messages in VM." :group 'vm) (defgroup vm-toolbar nil "Options affecting the VM toolbar" :group 'vm) (defgroup vm-add-ons nil "Options for non-core VM extensions" :group 'vm) ;; Custom variable definitions (defcustom vm-assimilate-new-messages-sorted nil "*When enabled new messages will be inserted in current sort order. Otherwise they are appended to the folder, which is VM default." :group 'vm-presentation :type 'boolean) (defcustom vm-init-file "~/.vm" "*Startup file for VM that is loaded the first time you run VM in an Emacs session." :group 'vm-misc :type 'file) (defcustom vm-preferences-file "~/.vm.preferences" "*Secondary startup file for VM, loaded after `vm-init-file'. It is meant for specifying the preferred settings for VM variables." :group 'vm-misc :type 'file) (defcustom vm-temp-file-directory (or (getenv "TMPDIR") (and (file-directory-p "/tmp") "/tmp") (and (file-directory-p "C:\\TEMP") "C:\\TEMP") (and (file-directory-p "C:\\") "C:\\") "/tmp") "*Name of a directory where VM can put temporary files." :group 'vm-misc :type 'directory) (defcustom vm-folder-directory nil "*Directory where folders of mail are kept." :group 'vm-folders :type '(choice (const nil) directory)) (defcustom vm-thunderbird-folder-directory nil "*Directory where Thunderbird's local folders are kept. This setting is used in `vm-visit-thunderbird-folder'. Note that only Thunderbird's local folders can be visited in VM, not its IMAP folders. " :group 'vm-folders :type '(choice (const nil) directory)) (defvar vm-foreign-folder-directory nil "If the current folder is a \"foreign\" folder, i.e., maintained by anothe mail client such as Thunderbird, then this variable holds its directory.") (defcustom vm-primary-inbox "~/INBOX" "*Mail is moved from the system mailbox to this file for reading." :group 'vm-folders :type 'file) (defcustom vm-crash-box nil "*File in which to store mail temporarily while it is transferred from the system mailbox to the primary inbox. If a crash occurs during this mail transfer, any missing mail will be found in this file. VM will do crash recovery from this file automatically at startup, as necessary. If the variable is to nil, a crash box name is created by appending `vm-primary-inbox' and `vm-crash-box-suffix'." :group 'vm-folders :type '(choice file (const :tag "Use vm-crash-box-suffix" nil))) (defcustom vm-crash-box-suffix ".crash" "*String suffix used to create possible crash box file names for folders. When VM uses `vm-spool-file-suffixes' to create a spool file name, it will append the value of `vm-crash-box-suffix' to the folder's file name to create a crash box name." :group 'vm-folders :type '(choice string (const :tag "No crash boxes" nil))) (defcustom vm-keep-crash-boxes nil "*Non-nil value should be a string specifying a directory where your crash boxes should be moved after VM has copied new mail out of them. This is a safety measure. In at least one case a pointer corruption bug inside Emacs has caused VM to believe that it had copied information out of the crash box when it in fact had not. VM then deleted the crash box, losing the batch of incoming mail. This is an exceedingly rare problem, but if you want to avoid losing mail if it happens, set `vm-keep-crash-boxes' to point to a directory in the same filesystem as all your crash boxes. Each saved crash box will have a unique name based on the current date and time the box was saved. You will need to clean out this directory from time to time; VM does not do so. A nil value means VM should just delete crash boxes after it has copied out the mail." :group 'vm-folders :type '(choice directory (const :tag "No, do not keep crash boxes" nil))) (defcustom vm-fetched-message-limit 10 "*Should be an integer representing the maximum number of messages that VM should keep in the Folder buffer when the messages are fetched on demand, or nil to signify no limit." :group 'vm-folders :type '(choice (const :tag "No Limit" nil) (integer :tag "Number of Mesages"))) (defcustom vm-index-file-suffix nil "*Suffix used to construct VM index file names, e.g., \".inx\". When VM visits a folder, it checks for the existence of a file whose name is the folder's file name with the value of this variable appended to it. If found, the file's contents will be used to tell VM about the contents of the folder. This is faster than parsing the folder itself. When you save a folder, the index file will be rewritten with updated information about the folder. A nil value means VM should not read or write index files." :group 'vm-folders :type '(choice (string :tag "File Suffix") (const :tag "Do not use index file" nil))) (defcustom vm-enable-external-messages nil "*Non-nil value should be a list of contexts in which VM may use message bodies stored externally. External messages are those stored in external sources such as the file system or remote mail servers. In some cases, VM is able to work with minimal header information of the messages, without loading the entire message bodies into the folder buffers. This allows faster start-up times and smaller memory images of Emacs sessions, at the cost of short delays when messages are viewed. As of version 8.2.0, this facility is only available for IMAP folders (context name `imap'). Messages larger than `vm-imap-max-message-size' are treated as external messages." :group 'vm-folders :type '(repeat (choice (const imap)))) (defvar vm-load-headers-only nil "This variable is replaced by `vm-enable-external-messages'.") (make-obsolete-variable 'vm-load-headers-only 'vm-enable-external-messages "8.2.0") ;; use this function to access vm-spool-files on the fly. this ;; allows us to use environmental variables without setting ;; vm-spool-files at load time and thereby making it hard to dump an ;; Emacs containing a preloaded VM. (defun vm-spool-files () (or vm-spool-files (and (setq vm-spool-files (getenv "MAILPATH")) (setq vm-spool-files (vm-delete-directory-names (vm-parse vm-spool-files "\\([^:%?]+\\)\\([%?][^:]*\\)?\\(:\\|$\\)")))) (and (setq vm-spool-files (getenv "MAIL")) (setq vm-spool-files (vm-delete-directory-names (list vm-spool-files)))))) (defcustom vm-spool-files nil "*If non-nil this variable's value should be a list of strings or a list of lists. If the value is a list of strings, the strings should name files that VM will check for incoming mail instead of the default place VM thinks your system mailbox is. Mail will be moved from these mailboxes to your primary inbox as specified by `vm-primary-inbox', using `vm-crash-box' as a waystation. If the value is a list of lists, each sublist should be of the form (INBOX SPOOLNAME CRASHBOX) INBOX, SPOOLNAME and CRASHBOX are all strings. INBOX is the folder where you want your new mail to be moved when you type 'g' (running `vm-get-new-mail') in VM. It is where you will read the mail. SPOOLNAME is where the mail system leaves your incoming mail, e.g. /var/spool/mail/kyle. It can also be a mailbox specification of the form, \"po:USER\", where USER is a user name. VM will pass this specification to the movemail program. It is up to movemail to interpret it and figure out where to find your mailbox. Some systems use special authentication methods that are only accessible via the movemail program. SPOOLNAME can also be a POP maildrop. A POP maildrop specification has the following format: \"pop:HOST:PORT:AUTH:USER:PASSWORD\" or \"pop-ssl:HOST:PORT:AUTH:USER:PASSWORD\" or \"pop-ssh:HOST:PORT:AUTH:USER:PASSWORD\" The second form is used to speak POP over an SSL connection. For this to work you should either have a version of Emacs with SSL capability or you have the stunnel program installed and set the variable `vm-stunnel-program'. The SSL version of the POP server will not use the same port as the non-SSL version. The third form is used to speak POP over an SSH connection. You must have the ssh program installed and the variable `vm-ssh-program' must name it in order for POP over SSH to work. SSH must be able to authenticate without a password, which means you must be using either .shosts authentication or RSA authentication. HOST is the host name of the POP server PORT is the TCP port number to connect to. This should normally be 110, unless you're using POP over SSL in which case the stanard port is 995. USER is the user name sent to the server. PASSWORD is the secret shared by you and the server for authentication purposes. How is it used depends on the value of the AUTH parameter. If the PASSWORD is \"*\", VM will prompt you for the password the first time you try to retrieve mail from maildrop. If the password is valid, VM will not ask you for the password again during this Emacs session. AUTH is the authentication method used to convince the server you should have access to the maildrop. Acceptable values are \"pass\", \"rpop\" and \"apop\". For \"pass\", the PASSWORD is sent to the server with the POP PASS command. For \"rpop\", the PASSWORD should be the string to be sent to the server via the RPOP command. In this case the string is not really a secret; authentication is done by other means. For \"apop\", an MD5 digest of the PASSWORD appended to the server timestamp will be sent to the server with the APOP command. In order to use \"apop\" you will have to set the value of `vm-pop-md5-program' appropriately to point at the program that will generate the MD5 digest that VM needs. SPOOLNAME can also be an IMAP maildrop. An IMAP maildrop specification has the following format: \"imap:HOST:PORT:MAILBOX:AUTH:USER:PASSWORD\" or \"imap-ssl:HOST:PORT:MAILBOX:AUTH:USER:PASSWORD\" or \"imap-ssh:HOST:PORT:MAILBOX:AUTH:USER:PASSWORD\" The second form is used to speak IMAP over an SSL connection. For this to work, you should either be using a version of Emacs with SSL capability or you must have the stunnel program installed and the variable `vm-stunnel-program' naming it. The third form is used to speak IMAP over an SSH connection. You must have the ssh program installed and the variable `vm-ssh-program' must name it in order for IMAP over SSH to work. SSH must be able to authenticate without a password, which means you must be using .shosts authentication or public key user authentication. HOST is the host name of the IMAP server. PORT is the TCP port number to connect to. This should normally be 143. For IMAP over SSL, the standard port is 993. There is no special port for IMAP over SSH. MAILBOX is the name of the mailbox on the IMAP server. Should be \"inbox\", to access your default IMAP maildrop on the server. AUTH is the authentication method used to convince the server you should have access to the maildrop. Acceptable values are \"preauth\", \"login\" and \"cram-md5\". \"preauth\" causes VM to skip the authentication stage of the protocol with the assumption that the session was authenticated in some external way. \"login\", tells VM to use the IMAP LOGIN command for authentication, which sends your username and password in cleartext to the server. \"cram-md5\" is a challenge response system that convinces the server of your identity without transmitting your password in the clear. Not all servers support \"cram-md5\"; if you're not sure, ask your mail administrator or just try it. USER is the user name used with authentication methods that require such an identifier. \"login\" and \"cram-md5\" use it currently. PASSWORD is the secret shared by you and the server for authentication purposes. If the PASSWORD is \"*\", VM will prompt you for the password the first time you try to retrieve mail from maildrop. If the password is valid, VM will not ask you for the password again during this Emacs session. CRASHBOX is the temporary file that VM uses to store mail in transit between the SPOOLNAME and the INBOX. If the system crashes or Emacs dies while mail is being moved, and the new mail is not in the SPOOLNAME or the INBOX, then it will be in the CRASHBOX. There can be multiple entries with the same INBOX value, but a particular SPOOLNAME should appear only once. CRASHBOXes should not be shared among different INBOXes, but you can use the same CRASHBOX/INBOX pair with a different SPOOLNAME. `vm-spool-files' will default to the value of the shell environmental variables MAILPATH or MAIL if either of these variables are defined and no particular value for `vm-spool-files' has been specified." :group 'vm-folders :type '(choice (repeat :tag "List of spool files" (file :tag "Spoolfile")) (repeat :tag "List of (inbox spoolfile crashbox) elements" (list (file :tag "Inbox") (file :tag "Spoolfile") (file :tag "Crashbox"))))) (defcustom vm-spool-file-suffixes nil "*List of suffixes to be used to create possible spool file names for folders. Example: (setq vm-spool-file-suffixes '(\".spool\" \"-\")) If you visit a folder ~/mail/beekeeping, when VM attempts to retrieve new mail for that folder it will look for mail in ~/mail/beekeeping.spool and ~/mail/beekeeping- in addition to scanning `vm-spool-files' for matches. The value of `vm-spool-files-suffixes' will not be used unless `vm-crash-box-suffix' is also defined, since a crash box is required for all mail retrieval from spool files." :group 'vm-folders :type '(repeat string)) (defcustom vm-make-spool-file-name nil "*Non-nil value should be a function that returns a spool file name for a folder. The function will be called with one argument, the folder's file name. If the folder does not have a file name, the function will not be called." :group 'vm-folders :type '(choice (const :tag "Default" nil) function)) (defcustom vm-make-crash-box-name nil "*Non-nil value should be a function that returns a crash box file name for a folder. The function will be called with one argument, the folder's file name. If the folder does not have a file name, the function will not be called." :group 'vm-folders :type '(choice (const :tag "Default" nil) function)) (defconst vm-pop-md5-program "md5" "*Program that reads a message on its standard input and writes an MD5 digest on its output.") (defcustom vm-pop-max-message-size nil "*If VM is about to retrieve via POP a message larger than this size (in bytes) it will ask the you whether it should retrieve the message. If VM is retrieving mail automatically because `vm-auto-get-new-mail' is set to a numeric value then you will not be prompted about large messages. This is to avoid prompting you while you're typing in another buffer. In this case the large message will be skipped with a warning message. You will be able to retrieved any skipped messages later by running `vm-get-new-mail' interactively. A nil value for `vm-pop-max-message-size' means no size limit." :group 'vm-pop :type '(choice (const :tag "No Limit" nil) (integer :tag "Bytes"))) (defcustom vm-pop-messages-per-session nil "*Non-nil value should be an integer specifying how many messages to retrieve per POP session. When you type 'g' to get new mail, VM will only retrieve that many messages from any particular POP maildrop. To retrieve more messages, type 'g' again. A nil value means there's no limit." :group 'vm-pop :type '(choice (const :tag "No Limit" nil) integer)) (defcustom vm-pop-bytes-per-session nil "*Non-nil value should be an integer specifying how many bytes to retrieve per POP session. When you type 'g' to get new mail, VM will only retrieve messages until the byte limit is reached on any particular POP maildrop. To retrieve more messages, type 'g' again. A nil value means there's no limit." :group 'vm-pop :type '(choice (const :tag "No Limit" nil) (integer :tag "Bytes"))) (defcustom vm-pop-expunge-after-retrieving nil "*Non-nil value means that, when a POP mailbox is used as a spool file, messages should be deleted after retrieving them. A nil value means messages will be left in the POP mailbox until you run `vm-expunge-pop-messages'. VM can only support a nil value for this variable if the remote POP server supports the UIDL command. If the server does not support UIDL and you've asked VM leave messages on the server, VM will complain about the lack of UIDL support and not retrieve messages from the server. This variable only affects POP mailboxes not listed in `vm-pop-auto-expunge-alist' (which is the recommended method for customizing this behavior)." :group 'vm-pop :type 'boolean) (defcustom vm-pop-auto-expunge-alist nil "*List of POP mailboxes and values specifying whether messages should be automatically deleted from the mailbox after retrieval. The format of the list is ((MAILBOX . VAL) (MAILBOX . VAL) ...) MAILBOX should be a POP mailbox specification as described in the documentation for the variable `vm-spool-files'. If you have the POP password specified in the `vm-spool-files' entry, you do not have to specify it here as well. Use `*' instead; VM will still understand that this mailbox is the same as the one in `vm-spool-files' that gives the password. VAL should be nil if retrieved messages should be left in the corresponding POP mailbox, t if retrieved messages should be deleted from the mailbox immediately after retrieval. VM can only support a non-nil setting of this variable if the remote POP server supports the UIDL command. If the server does not support UIDL and you've asked to VM leave messages on the server, VM will complain about the lack of UIDL support and not retrieve messages from the server." :group 'vm-pop :type '(repeat (cons string boolean))) (defvar vm-pop-auto-expunge-warned nil "List of POP mailboxes for which warning has been given about the lack of settings for auto-expunge.") (defcustom vm-pop-read-quit-response t "*Non-nil value tells VM to read the response to the POP QUIT command. Sometimes, for reasons unknown, the QUIT response never arrives from some POP servers and VM will hang waiting for it. So it is useful to be able to tell VM not to wait. Some other servers will not expunge messages unless the QUIT response is read, so for these servers you should set the variable's value to t." :group 'vm-pop :type 'boolean) (defconst vm-recognize-pop-maildrops "^\\(pop\\|pop-ssl\\|pop-ssh\\):[^:]+:[^:]+:[^:]+:[^:]+:.+" "Regular expression matching the maildrop specification of POP folders. It can be set to nil to prohibit POP maildrops.") (defcustom vm-pop-folder-alist nil "*Alist of POP maildrop specifications and names that refer to them. The alist format is: ((POPDROP NAME) ...) POPDROP is a POP maildrop specification in the same format used by `vm-spool-files' (which see). NAME is a string that should give a less cumbersome name that you will use to refer to this maildrop when using `vm-visit-pop-folder'." :group 'vm-pop :type '(repeat (list string string))) (defcustom vm-pop-folder-cache-directory nil "*Directory where VM stores cached copies of POP folders. When VM visits a POP folder (really just a POP server where you have a mailbox) it stores the retrieved message on your computer so that they need not be retrieved each time you visit the folder. The cached copies are stored in the directory specified by this variable." :group 'vm-pop :type '(choice (const nil) directory)) (defcustom vm-imap-max-message-size nil "*The largest message size of IMAP messages that VM should retrieve automatically. If VM encounters an IMAP message larger than this size, the action is as follows: - In IMAP folders, the message is treated as an external message if `vm-enable-external-messages' includes 'imap. Otherwise it is retrieved. - In local folders, the message is skipped if it is part of automatical mail retrieval. During interactive mail retrieval, obtained by running `vm-get-new-mail', VM queries you whether it should be retrieved. A nil value for `vm-imap-max-message-size' means no size limit." :group 'vm-imap :type '(choice (const :tag "Unlimited" nil) (integer :tag "Bytes"))) (defcustom vm-imap-messages-per-session nil "*Non-nil value should be an integer specifying how many messages to retrieve per IMAP session. When you type 'g' to get new mail, VM will only retrieve that many messages from any particular IMAP maildrop. To retrieve more messages, type 'g' again. A nil value means there's no limit." :group 'vm-imap :type '(choice (const :tag "Unlimited" nil) integer)) (defcustom vm-imap-bytes-per-session nil "*Non-nil value should be an integer specifying how many bytes to retrieve per IMAP session. When you type 'g' to get new mail, VM will only retrieve messages until the byte limit is reached on any particular IMAP maildrop. To retrieve more messages, type 'g' again. A nil value means there's no limit." :group 'vm-imap :type '(choice (const :tag "No Limit" nil) (integer :tag "Bytes"))) (defcustom vm-imap-expunge-after-retrieving nil "*Non-nil value means that, when an IMAP mailbox is used as a spool file, messages should be deleted after retrieving them. A nil value means messages will be left in the IMAP mailbox until you run `vm-expunge-imap-messages'. This variable only affects IMAP mailboxes not listed in `vm-imap-auto-expunge-alist' (which is the recommended method for customizing this behavior)." :group 'vm-imap :type 'boolean) (defcustom vm-imap-auto-expunge-alist nil "*List of IMAP mailboxes and values specifying whether messages should be automatically deleted from the mailbox after retrieval. The format of the list is ((MAILBOX . VAL) (MAILBOX . VAL) ...) MAILBOX should be an IMAP mailbox specification as described in the documentation for the variable `vm-spool-files'. If you have the IMAP password specified in the `vm-spool-files' entry, you do not have to specify it here as well. Use `*' instead; VM will still understand that this mailbox is the same as the one in `vm-spool-files' that contains the password. VAL should be nil if retrieved messages should be left in the corresponding IMAP mailbox, t if retrieved messages should be deleted from the mailbox immediately after retrieval." :group 'vm-imap :type '(repeat (cons (string :tag "IMAP Folder Specificaiton") boolean))) (defvar vm-imap-auto-expunge-warned nil "List of IMAP mailboxes for which warning has been given about the lack of settings for auto-expunge.") (defconst vm-recognize-imap-maildrops "^\\(imap\\|imap-ssl\\|imap-ssh\\):[^:]+:[^:]+:[^:]+:[^:]+:[^:]+:.+" "Regular expression matching maildrop specificaiton of IMAP folders. It can be set to nil to prohibit the recognition of IMAP maildrops.") (defvar vm-imap-server-list nil "*List of IMAP maildrop specifications that tell VM the IMAP servers you have access to and how to log into them. The IMAP maildrop specification in the same format used by `vm-spool-files' (which see). The mailbox part of the specifiation is ignored and should be asterisk or some other placeholder. ***This customization variable is deprecated. Use `vm-imap-account-alist' instead. Example: (setq vm-imap-server-list '( \"imap-ssl:mail.foocorp.com:993:inbox:login:becky:*\" \"imap:crickle.lex.ky.us:143:inbox:login:becky:*\" ) )" ) (make-obsolete-variable 'vm-imap-server-list 'vm-imap-account-alist "8.1.0") (defcustom vm-imap-account-alist nil "*Alist of IMAP account specifications and names that refer to them. The alist format is: ((IMAPDROP NAME) ...) IMAPDROP is a IMAP maildrop specification in the same format used by `vm-spool-files' (which see). NAME is a string that should give a less cumbersome name that you will use to refer to this maildrop when using `vm-visit-imap-folder'. Example: (setq vm-imap-account-alist '( (\"imap-ssl:mail.foocorp.com:993:inbox:login:becky:*\" \"becky\") (\"imap:crickle.lex.ky.us:143:inbox:login:becky:*\" \"crickle\") ) ) " :group 'vm-imap :type '(repeat (list (string :tag "IMAP Folder Specification") (string :tag "Nickname")))) (defcustom vm-imap-default-account nil "*Set this variable to a string denoting the name of an IMAP account (short name) declared in `vm-imap-account-alist'. The account specified here will be regarded as the default account for various purposes, e.g., for saving copies of outgoing mail." :group 'vm-imap :type '(choice (const :tag "None" nil) (string :tag "IMAP Account"))) (defcustom vm-imap-refer-to-inbox-by-account-name nil "*If set to non-nil, the INBOX folders on IMAP accounts are referred to by their account names instead of as \"INBOX\". The account names are those declared in `vm-imap-account-alist'. This is useful if one wants to handle multiple IMAP accounts during the same VM session, all of which might have an \"INBOX\" folder." :group 'vm-imap :type 'boolean) (defcustom vm-imap-tolerant-of-bad-imap nil "*Level of tolerance that vm should use for IMAP servers that don't follow the IMAP specification. Default of NIL or 0 means no tolerance. Level 1 allows possibly harmless violations of prohibitions. (But these violations could also be symptomatic of deeper problems.) Use this level carefully. Higher levels of violations are not currently permitted." :group 'vm-imap :type '(choice (const :tag "No Tolerance" nil) (const :tag "Tolerant" 1))) (defcustom vm-imap-folder-cache-directory nil "*Directory where VM stores cached copies of IMAP folders. When VM visits a IMAP folder (really just a IMAP server where you have a mailbox) it stores the retrieved message on your computer so that they need not be retrieved each time you visit the folder. The cached copies are stored in the directory specified by this variable." :group 'vm-imap :type '(choice (const :tag "None" nil) directory)) (defcustom vm-imap-save-to-server nil "*This variable controls the behavior of the `vm-save-message' command. If it is non-NIL, then messages from IMAP folders are saved to other IMAP folders on the server, instead of local folders. Messages from local folders are still saved to local folders. The specialized commands `vm-save-message-to-local-folder' and `vm-save-message-to-imap-folder' can be used to obtain particular behavior independent of this variable." :group 'vm-imap :type 'boolean) (defcustom vm-imap-expunge-retries 1 "*Number of retries to be performed for expunging IMAP mailboxes. Increase this if your IMAP server is sluggish." :group 'vm-imap :type 'integer) (defcustom vm-imap-server-timeout nil "*Number of seconds to wait for output from the IMAP server before timing out. It can be set to nil to never time out." :group 'vm-imap :type '(choice (const :tag "Never" nil) (integer :tag "Seconds"))) (defcustom vm-imap-ensure-active-sessions t "*If non-NIL, ensures that an IMAP session is active before issuing commands to the server. If it is not active, a new session is started. This ensures a failure-proof operation, but involves additional overhead in checking that the session is active." :group 'vm-imap :type 'boolean) (defcustom vm-imap-message-bunch-size 10 "*Number of messages to be bunched together in IMAP server operations. This permits faster interation with the IMAP servers. To disable bunching, set it to 1." :group 'vm-imap :type 'integer) (defcustom vm-imap-sync-on-get t "*If this variable is non-NIL, then the vm-get-new-mail command should synchronize with the IMAP mailbox on the server. This involves expunging messages that have been expunged from the server, saving and retrieving message attributes as well retrieving new messages. If the variable is NIL, this functionality can be obtained via the vm-imap-synchronize command." :group 'vm-imap :type 'boolean) (defcustom vm-auto-get-new-mail t "*Non-nil value causes VM to automatically move mail from spool files to a mail folder when the folder is first visited. Nil means you must always use `vm-get-new-mail' to pull in newly arrived messages. If the value is a number, then it specifies how often (in seconds) VM should check for new mail and try to retrieve it. This is done asynchronously using a timer task and may occur while you are editing other files. It should not disturb your editing, except perhaps for a pause while the check is being done." :group 'vm-folders :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (integer :tag "Seconds"))) (defcustom vm-mail-check-interval 300 "*Numeric value specifies the number of seconds between checks for new mail, carried out using a timer task. The maildrops for all visited folders are checked. A nil value means don't check for new mail. Note that if new mail is found, it is not retrieved. The buffer local variable `vm-spooled-mail-waiting' is set non-nil in the buffers of those folders that have mail waiting. VM displays \"Mail\" in the mode line of folders that have mail waiting." :group 'vm-folders :type '(choice (const nil) integer)) (defcustom vm-mail-check-always nil "*Set this variable to `t' if you want VM's mail-check to run continuously and take into account multiple mail clients reading from the same mail spool." :group 'vm-folders :type 'boolean) (defvar vm-spooled-mail-waiting nil "Value is non-nil if there is mail waiting for the current folder. This variable's value is local in all buffers. VM maintains this variable, you should not set it.") (make-variable-buffer-local 'vm-spooled-mail-waiting) (defcustom vm-default-folder-type (cond ((not (boundp 'system-configuration)) 'From_) ((or (string-match "-solaris" system-configuration) (string-match "usg-unix-v" system-configuration) (string-match "-ibm-aix" system-configuration)) 'From_-with-Content-Length) ((string-match "-sco" system-configuration) 'mmdf) (t 'From_)) "*Default folder type for empty folders. If VM has to add messages that have no specific folder type to an empty folder, the folder will become this default type. Allowed types are: From_ From_-with-Content-Length BellFrom_ mmdf babyl Value must be a symbol, not a string. i.e. write (setq vm-default-folder-type 'From_) in your .emacs or .vm file. If you set this variable's value to From_-with-Content-Length you must set `vm-trust-From_-with-Content-Length' non-nil." :group 'vm-folders :type '(choice (const From_) (const From_-with-Content-Length) (const BellFrom_) (const mmdf) (const babyl))) (defcustom vm-default-From_-folder-type 'From_ "*Value must be a symbol that tells VM which From-style folder type is used by your local mail delivery system. Valid values are From_ BellFrom_ Messages in From_ folders are separated by the two newlines followed by the string \"From\" and a space. Messages in BellFrom_ folders are only required to have a single newline before the \"From\" string. Since BellFrom_ and From_ folders cannot be reliably distinguished from each other, you must tell VM which one your system uses by setting the variable `vm-default-From_-folder-type' to either From_ or BellFrom_." :group 'vm-folders :type '(choice (const From_) (const BellFrom_))) (defcustom vm-default-new-folder-line-ending-type nil "*Value must be a symbol that specifies the line ending convention to use for new folders. Text files under UNIXish and Windows systems use different characters to indicate the end of a line. UNIXish systems use a single linefeed character, Windows uses a carriage return followed by a line feed. The value of this variable tells VM which to use. `nil' means use the line ending convention of the local system; CRLF if you're on a Windows system, LF for UNIXish systems. `crlf' means use CRLF. `lf' mean use LF. `cr' means use CR (old Macs use this)." :group 'vm-folders :type '(choice (const :tag "System Default" nil) (const :tag "Windows" crlf) (const :tag "Old Mac" cr) (const :tag "Unix" lf))) (defcustom vm-check-folder-types t "*Non-nil value causes VM to check folder and message types for compatibility before it performs certain operations. Before saving a message to a folder, VM will check that the destination folder is of the same type as the message to be saved. Before incorporating message into a visited folder, VM will check that the messages are of the same type as that folder. A nil value means don't do the checks. If non-nil, VM will either convert the messages to the appropriate type before saving or incorporating them, or it will signal an error. The value of `vm-convert-folder-types' determines which action VM will take." :group 'vm-folders :type 'boolean) (defcustom vm-convert-folder-types t "*Non-nil value means that when VM checks folder types and finds a mismatch (see `vm-check-folder-types'), it will convert the source messages to the type of the destination folder, if it can. If `vm-check-folder-types' is nil, then this variable isn't consulted." :group 'vm-folders :type 'boolean) (defcustom vm-trust-From_-with-Content-Length (eq vm-default-folder-type 'From_-with-Content-Length) "*Non-nil value means that if the first message in a folder contains a Content-Length header and begins with \"From \" VM can safely assume that all messages in the folder have Content-Length headers that specify the length of the text section of each message. VM will then use these headers to determine message boundaries instead of the usual way of searching for two newlines followed by a line that begins with \"From \". If you set `vm-default-folder-type' to From_-with-Content-Length you must set this variable non-nil." :group 'vm-folders :type 'boolean) (defvar vm-sync-thunderbird-status t "* If set to t, VM synchronizes its headers with the headers of Thunderbird so that full interoperation with Thunderbird becomes possible. If it is set to 'read-only then VM reads the Thunderbird status flags, but refrains from updating them. If it is set to nil then VM makes no attempt to read or write the Thunderbird status flags.") (make-variable-buffer-local 'vm-sync-thunderbird-status) ;; (defvar vm-folder-sync-thunderbird-status t ;; "If t VM synchronizes its headers with the headers of ;; Thunderbird so that full interoperation with Thunderbird becomes ;; possible. This is not a customization variable. See ;; `vm-sync-thunderbird-status' for customization.") ;; (defvar vm-read-thunderbird-status t ;; "* If t VM reads the headers of Thunderbird when visiting ;; folders, but not write Thunderbird headers. This variable has ;; effect only if `vm-folder-sync-thunderbird-status' is nil.") (defvar vm-folder-read-thunderbird-status t "If t VM reads the headers of Thunderbird when visiting folders. This is not a customization variable. See `vm-sync-thunderbird-status' for customization.") (make-variable-buffer-local 'vm-folder-read-thunderbird-status) (defcustom vm-sort-messages-by-delivery-date nil "*If set to t, VM will use the \"Delivery-Date\" header instead of the \"Date\" header for sorting messages." :group 'vm-summary :type 'boolean) (defcustom vm-visible-headers '("Resent-" "From:" "Sender:" "To:" "Newsgroups:" "Apparently-To:" "Cc:" "Subject:" "Date:") "*List of headers that should be visible when VM first displays a message. These should be listed in the order you wish them presented. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. For example, \"Date\" matches \"Date\" and \"Date-Sent\". Header names are always matched case insensitively. If the value of `vm-invisible-header-regexp' is nil, only the headers matched by `vm-visible-headers' will be displayed. Otherwise all headers are displayed except those matched by `vm-invisible-header-regexp'. In this case `vm-visible-headers' specifies the order in which headers are displayed. Headers not matching `vm-visible-headers' are displayed last." :group 'vm-presentation :type '(repeat regexp)) (defcustom vm-invisible-header-regexp nil "*Non-nil value should be a regular expression that tells what headers VM should NOT normally display when presenting a message. All other headers will be displayed. The variable `vm-visible-headers' specifies the presentation order of headers; headers not matched by `vm-visible-headers' are displayed last. Nil value causes VM to display ONLY those headers specified in `vm-visible-headers'." :group 'vm-presentation :type '(choice (const nil) regexp)) (defcustom vm-highlighted-header-regexp nil "*Value specifies which headers to highlight. This is a regular expression that matches the names of headers that should be highlighted when a message is first presented. For example setting this variable to \"From:\\\\|Subject:\" causes the From and Subject headers to be highlighted. If you're using XEmacs, you might want to use the builtin `highlight-headers' package instead. If so, then you should set the variable `vm-use-lucid-highlighting' non-nil. You'll need to set the various variables used by the highlight-headers package to customize highlighting. `vm-highlighted-header-regexp' is ignored in this case." :group 'vm-presentation :type '(choice (const nil) regexp)) (defcustom vm-use-lucid-highlighting (condition-case nil (progn (require 'highlight-headers) t ) (error nil)) "*Non-nil means to use the `highlight-headers' package in XEmacs. Nil means just use VM's builtin header highlighting code. FSF Emacs always uses VM's builtin highlighting code." :group 'vm-misc :type 'boolean) (defface vm-highlighted-header '((t (:inherit bold))) "Default face used to highlight headers." :group 'vm-faces) ;; (copy-face 'bold 'vm-highlighted-header) (defcustom vm-highlighted-header-face 'vm-highlighted-header "*Face to be used to highlight headers. The headers to highlight are specified by the `vm-highlighted-header-regexp' variable. This variable is ignored under XEmacs if `vm-use-lucid-highlighting' is non-nil. XEmacs' highlight-headers package is used instead. See the documentation for the function `highlight-headers' to find out how to customize header highlighting using this package." :group 'vm-faces :type 'symbol) (defcustom vm-preview-lines 0 "*Non-nil value N causes VM to display the visible headers + N lines of text of a message when it is first presented. The message is not actually flagged as read until it is exposed in its entirety. A value of t causes VM to display as much of the message as will fit in the window associated with the folder buffer. A nil value causes VM not to preview messages; no text lines are hidden and messages are immediately flagged as read." :group 'vm-presentation :type '(choice boolean integer)) (defcustom vm-preview-read-messages nil "*Non-nil value means to preview messages even if they've already been read. A nil value causes VM to preview messages only if new or unread." :group 'vm-presentation :type 'boolean) (defconst vm-always-use-presentation-buffer t "Non-nil means to always use a presentation buffer for displaying messages. It will also be used if no decoding or other modification of the message are necessary.") (make-obsolete-variable 'vm-always-use-presentation-buffer "The current behaviour is equivalent to setting this variable to t. Please remove all settings for this variable and report any problems that you might encounter." "8.2.0") (defconst vm-always-use-presentation t "Non-nil means to always use a presentation buffer for displaying messages. It will also be used if no decoding or other modification of the message are necessary. This constant is a place holder for the obsolete variable `vm-always-use-presentation-buffer'. It should be removed eventually.") (defcustom vm-word-wrap-paragraphs nil "*If non-nil, causes VM to word wrap paragraphs with long lines. This is done using the `longlines' library, which must be installed for the variable to have effect." :group 'vm-presentation :type 'boolean) (defcustom vm-word-wrap-paragraphs-in-reply nil "*If non-nil, causes VM to word wrap paragraphs with long lines during message composition. This is done using the `longlines' library, which must be installed for the variable to have effect." :group 'vm-compose :type 'boolean) (defcustom vm-fill-paragraphs-containing-long-lines nil "*This variable can be set to nil, a numeric value N, the symbol 'window-width. If it is numeric, it causes VM to fill paragraphs that contain lines spanning that many columns or more. Setting it to 'window-width has the effect of using the width of the Emacs window. Only plain text messages and text/plain MIME parts will be filled. The message itself is not modified; its text is copied into a presentation buffer before the filling is done. This variable determines which paragraphs are filled, but `vm-paragraph-fill-column' determines the fill column. Note that filling is carried out only if word wrapping is not in effect. The variable `vm-word-wrap-paragraphs' controls word wrapping." :group 'vm-presentation :type '(choice (const :tag "Off" nil) (const :tag "Window width" window-width) (integer :tag "Fill width"))) (defcustom vm-fill-paragraphs-containing-long-lines-in-reply nil "*This variable can be set to nil, a numeric value N, the symbol 'window-width. If it is numeric, it causes VM to fill included text in replies provided it has lines spanning that many columns or more. Setting it to 'window-width has the effect of using the width of the Emacs window. This variable determines which paragraphs are filled, but `vm-fill-long-lines-in-reply-column' determines the fill column. Note that filling is carried out only if word wrapping is not in effect. The variable `vm-word-wrap-paragraphs-in-reply' controls word wrapping." :group 'vm-compose :type '(choice (const :tag "No" nil) (const :tag "Window width" window-width) (integer :tag "Fill column"))) (defcustom vm-paragraph-fill-column (default-value 'fill-column) "*Column beyond which automatic line-wrapping should happen when re-filling lines longer than the value of `vm-fill-paragraphs-containing-long-lines'." :group 'vm-presentation :type 'integer) (defcustom vm-fill-long-lines-in-reply-column (default-value 'fill-column) "*Fill lines spanning that many columns or more in replies." :group 'vm-compose :type '(choice (const :tag "Off" nil) (const :tag "Window width" window-width) (integer :tag "Fill column"))) (defcustom vm-display-using-mime t "*Non-nil value means VM should display messages using MIME. MIME (Multipurpose Internet Mail Extensions) is a set of extensions to the standard Internet message format that allows reliable tranmission and reception of arbitrary data including images, audio and video as well as ordinary text. A non-nil value for this variable means that VM will recognize MIME encoded messages and display them as specified by the various MIME standards specifications. A nil value means VM will not display MIME messages any differently than any other message." :group 'vm-mime :type 'boolean) ;; this is t because at this time (11 April 1997) Solaris is ;; generating too many mangled MIME version headers. For the same ;; reason vm-mime-avoid-folding-content-type is also set to t. (defcustom vm-mime-ignore-mime-version t "*Non-nil value means ignore the version number in the MIME-Version header. VM only knows how to decode and display MIME version 1.0 messages. Some systems scramble the MIME-Version header, causing VM to believe that it cannot display a message that it actually can display. You can set `vm-mime-ignore-mime-version' non-nil if you use such systems." :group 'vm-mime :type 'boolean) (defcustom vm-mime-require-mime-version-header nil "*Non-nil means a message must contain MIME-Version to be considered MIME. The MIME standard requires that MIME messages contain a MIME-Version, but some mailers ignore the standard and do not send the header. Set this variable to nil if you want VM to be lax and parse such messages as MIME anyway." :group 'vm-mime :type 'boolean) (defcustom vm-mime-ignore-composite-type-opaque-transfer-encoding t "*Non-nil means VM should ignore transfer encoding declarations of base64 and quoted-printable for object of type message/* or multipart/*. The MIME spec requires that these composite types use either 7bit, 8bit, or binary transfer encodings but some mailers declare quoted-printable and base64 even when they are not used. Set this variable non-nil if you want VM to be lax and ignore this problem and try to display the object anyway." :group 'vm-mime :type 'boolean) (defcustom vm-mime-ignore-missing-multipart-boundary t "*Non-nil means VM should treat a missing MIME boundary marker as if the marker were at the end of the current enclosing MIME object or, if there is no enclosing object, at the end of the message. A nil value means VM will complain about missing boundaries and refuse to parse such MIME messages." :group 'vm-mime :type 'boolean) (defcustom vm-send-using-mime t "*Non-nil value means VM should support sending messages using MIME. MIME (Multipurpose Internet Mail Extensions) is a set of extensions to the standard Internet message format that allows reliable tranmission and reception of arbitrary data including images, audio and video as well as traditional text. A non-nil value for this variable means that VM will - allow you to attach files and messages to your outbound message. - analyze the composition buffer when you send off a message and encode it as needed. A nil value means VM will not offer any support for composing MIME messages." :group 'vm-mime :type 'boolean) (defcustom vm-mime-honor-content-disposition nil "*Non-nil value means use information from the Content-Disposition header to display MIME messages. Possible values are `t', to mean that the Content-Disposition header should always be honored or 'internal-only, to mean that an \"inline\" disposition should be honored only for internally-displayable types. The Content-Disposition header specifies whether a MIME object should be displayed inline or treated as an attachment. For VM, \"inline\" display means displaying the object in the Emacs buffer, if possible. Attachments will be displayed as a button that you can use mouse-2 to activate or mouse-3 to pull up a menu of options." :group 'vm-mime :type '(choice (const :tag "Ignore it" nil) (const :tag "Honor it always" t) (const :tag "Honor inline for internal types" internal-only))) (defvaralias 'vm-honor-mime-content-disposition 'vm-mime-honor-content-disposition) (defcustom vm-auto-decode-mime-messages t "*Non-nil value causes MIME decoding to occur automatically when a message containing MIME objects is exposed. A nil value means that you will have to run the `vm-decode-mime-message' command (normally bound to `D') manually to decode and display MIME objects." :group 'vm-mime :type 'boolean) (defcustom vm-mime-decode-for-preview t "*Non-nil value causes partial MIME decoding to happen when a message is previewed, instead of when it is displayed in full. The point of this is if `vm-preview-lines' is set to a non-nil, non-zero value you can see readable text instead of a potentially inscrutable MIME jumble. `vm-auto-decode-mime-messages' must also be set non-nil for this variable to have effect." :group 'vm-mime :type 'boolean) (defvar vm-mime-decode-for-show t "*Control variable that says whether MIME messages should be decoded for showing the message, in addition to decoding for preview.") (defcustom vm-mime-auto-displayed-content-types '("text" "image" "message/rfc822") "*List of MIME content types that should be displayed immediately after decoding. Other types will be displayed as a button that you must activate to display the object. A value of t means that all types should be displayed immediately. A nil value means never display MIME objects immediately; only use buttons. If the value is a list, it should be a list of strings, which should all be types or type/subtype pairs. Example: (setq vm-mime-auto-displayed-content-types '(\"text\" \"image/jpeg\")) If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. Note that all multipart types are processed specially, and this variable does not apply to them. In particular, multipart/digest messages are always displayed as a button to avoid automatically visiting a new folder while you are moving around in the current folder. message/partial messages are always displayed as a button, because there always needs to be a way to trigger the assembly of the parts into a full message. Any type that cannot be displayed internally or externally will be displayed as a button that allows you to save the body of the MIME object to a file." :group 'vm-mime :type '(choice (const t) (const nil) (repeat string))) (defvaralias 'vm-auto-displayed-mime-content-types 'vm-mime-auto-displayed-content-types) (defcustom vm-mime-auto-displayed-content-type-exceptions nil "*List of MIME content types that should not be displayed immediately after decoding. These types will be displayed as a button that you must activate to display the object. This is an exception list for the types listed in `vm-mime-auto-displayed-content-types'; all types listed there will be auto-displayed except those in the exception list. The value should be either nil or a list of strings. The strings should all be types or type/subtype pairs. Example: (setq vm-mime-auto-displayed-content-type-exceptions '(\"text/html\")) If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included." :group 'vm-mime :type '(choice (const nil) (repeat string))) (defvaralias 'vm-auto-displayed-mime-content-type-exceptions 'vm-mime-auto-displayed-content-type-exceptions) (defcustom vm-mime-internal-content-types t "*List of MIME content types that should be displayed internally if Emacs is capable of doing so. A value of t means that VM displays all types internally if possible. A list of exceptions can be specified via `vm-mime-internal-content-type-exceptions'. A nil value means never display MIME objects internally, which means VM must run an external viewer to display MIME objects. If the value is a list, it should be a list of strings. Example: (setq vm-mime-internal-content-types '(\"text\" \"message\" \"image/jpeg\")) If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. Note that all multipart types are always handled internally. There is no need to list them here." :group 'vm-mime :type '(choice (const :tag "Display all interanlly when possible" t) (const :tag "Never use Emacs' internal display capabilities" nil) (repeat (string :tag "MIME Type")))) (defcustom vm-mime-internal-content-type-exceptions nil "*List of MIME content types that should not be displayed internally. This is an exception list for the types specified in `vm-mime-internal-content-types'; all types listed there will be displayed internally except for those in the exception list. The value should be a list of strings. Example: (setq vm-mime-internal-content-type-exceptions '(\"image/jpeg\")) If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included." :group 'vm-mime :type '(choice (const nil) (repeat string))) (defcustom vm-mime-external-content-types-alist nil "*Alist of MIME content types and the external programs used to display them. If VM cannot display a type internally or has been instructed not to (see the documentation for the `vm-mime-internal-content-types' variable) it will try to launch an external program to display that type. The alist format is a list of lists, each sublist having the form (TYPE FUNCTION ARG ... ) or (TYPE PROGRAM ARG ARG ... ) or (TYPE COMMAND-LINE) TYPE is a string specifying a MIME type or type/subtype pair. For example \"text\" or \"image/jpeg\". If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. In the first form, FUNCTION is a lisp function that is responsible for displaying the attachment in an external application. Any ARGS will be passed to the function as arguments. The octets that compose the object will be written into a temporary file and the name of the file is passed as an additional argument. In the second form, PROGRAM is a string naming a program to run to display an object. Any ARGS will be passed to the program as arguments. The octets that compose the object will be written into a temporary file and the name of the file can be inserted into an ARG string by writing %f. In earlier versions of VM the filename was always added as the last argument; as of VM 6.49 this is only done if %f does not appear in any of the ARG strings. The filename inserted by %f will be quoted by `shell-quote-argument' and thus no single quotes should be used, i.e. do not use the following \"...'%f'...\". If the COMMAND-LINE form is used, the program and its arguments are specified as a single string and that string is passed to the shell for execution. Since the command line will be passed to the shell, you can use shell variables and redirection if needed. As with the PROGRAM/ARGS form, the name of the temporary file that contains the MIME object will be appended to the command line if %f does not appear in the command line string. In either the PROGRAM/ARG or COMMAND-LINE forms, all the program and argument strings will have any %-specifiers in them expanded as described in the documentation for the variable `vm-mime-button-format-alist'. The only difference is that %f refers to the temporary file VM creates to store the object to be displayed, not the filename that the sender may have associated with the attachment. Example: (setq vm-mime-external-content-types-alist '( (\"text/html\" browse-url-of-file) (\"image/gif\" \"xv\") (\"image/jpeg\" \"xv\") (\"video/mpeg\" \"mpeg_play\") (\"video\" w32-shell-execute \"open\") ) ) The first matching list element will be used. No multipart message will ever be sent to an external viewer." :group 'vm-mime :type '(choice (const nil) (alist :key-type (string :tag "MIME Type") :value-type (choice (group :tag "Function" (function :tag "Function") (repeat :inline t (string :tag "Args"))) (group :tag "Program" (file :tag "Program") (repeat :inline t (string :tag "Args"))) (string :tag "Shell Command"))))) (defcustom vm-mime-external-content-type-exceptions nil "*List of MIME content types that should not be displayed externally without a manual request from the user. This is an exception list for the types specified in `vm-mime-external-content-types-alist'; types listed there will not be displayed using the specified viewer unless you explicitly request it by menu or `$ e' from the keyboard. The value should be a list of strings. Example: (setq vm-mime-external-content-type-exceptions '(\"text/html\")) If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included." :group 'vm-mime :type '(choice (const nil) (repeat string))) (defcustom vm-mime-delete-viewer-processes t "*Non-nil value causes VM to kill external MIME viewer processes when you switch to a different message or quit the current message's folder." :group 'vm-mime :type 'boolean) (defcustom vm-mime-type-converter-alist nil "*Alist of MIME types and programs that can convert between them. If VM cannot display a content type, it will scan this list to see if the type can be converted into a type that it can display. The alist format is ( (START-TYPE END-TYPE COMMAND-LINE ) ... ) START-TYPE is a string specifying a MIME type or type/subtype pair. Example \"text\" or \"image/jpeg\". If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. END-TYPE must be an exact type/subtype pair. This is the type to which START-TYPE will be converted. COMMAND-LINE is a string giving a command line to be passed to the shell. The octets that compose the object will be written to the standard input of the shell command. Example: (setq vm-mime-type-converter-alist '( (\"image/jpeg\" \"image/gif\" \"jpeg2gif\") (\"text/html\" \"text/plain\" \"striptags\") ) ) The first matching list element will be used." :group 'vm-mime :type '(choice (const nil) (repeat (list (string :tag "From type") (string :tag "To type") (string :tag "Converter program"))))) (defvaralias 'vm-mime-alternative-select-method 'vm-mime-alternative-show-method) (make-obsolete-variable 'vm-mime-alternative-select-method 'vm-mime-alternative-show-method "8.2.0") (defcustom vm-mime-charset-converter-alist nil "*Alist of MIME charsets and programs that can convert between them. If VM cannot display a particular character set, it will scan this list to see if the charset can be converted into a charset that it can display. The alist format is ( ( START-CHARSET END-CHARSET COMMAND-LINE ) ... ) START-CHARSET is a string specifying a MIME charset. Example \"iso-8859-1\" or \"utf-8\". END-CHARSET is a string specifying the charset to which START-CHARSET will be converted. COMMAND-LINE is a string giving a command line to be passed to the shell. The characters in START-CHARSET will be written to the standard input of the shell command and VM expects characters encoded in END-CHARSET to appear at the standard output of the COMMAND-LINE. COMMAND-LINE is passed to the shell, so you can use pipelines, shell variables and redirections. Example: (setq vm-mime-charset-converter-alist '( (\"utf-8\" \"iso-2022-jp\" \"iconv -f utf-8 -t iso-2022-jp\") ) ) The first matching list element will be used." :group 'vm-mime :type '(choice (const nil) (repeat (list string string string)))) (defcustom vm-mime-alternative-show-method 'best-internal "*Value tells how to choose which multipart/alternative part to display. A MIME message of type multipart/alternative has multiple message parts containing the same information, but each part may be formatted differently. VM will display only one of the parts. This variable tells VM how to choose which part to display. (There is a separate variable `vm-mime-alternative-yank-method' for deciding the multipart/alternative to be used in replies.) A value of 'best means choose the part that is the most faithful to the sender's original content that can be displayed. A value of 'best-internal means choose the best part that can be displayed internally, (i.e. with the built-in capabilities of Emacs) and is allowed to be displayed internally (see `vm-mime-internal-content-types'). If none of the parts can be displayed internally, behavior reverts to that of 'best. The value can also be a list of the form (favorite TYPE ...) with the first element of the list being the symbol 'favorite'. The remaining elements of the list are strings specifying MIME types. VM will look for each TYPE in turn in the list of alternatives and choose the first matching alternative found that can be displayed. If the symbol 'favorite' is 'favorite-internal' instead, the first TYPE that matches an alternative that can be displayed internally will be chosen." :group 'vm-mime :type '(choice (choice (const best-internal) (const best) (const all)) (cons (const favorite) (repeat string)) (cons (const favorite-internal) (repeat string)))) (defcustom vm-mime-alternative-yank-method 'best-internal "*Value tells how to choose which multipart/alternative part to yank, i.e., include, in replies. It is similar to `vm-mime-alternative-show-method' used for displaying messages. A value of 'best means choose the part that is the most faithful to the sender's original content that can be displayed. A value of 'best-internal means choose the best part that can be displayed internally, (i.e. with the built-in capabilities of Emacs) and is allowed to be displayed internally (see `vm-mime-internal-content-types'). If none of the parts can be displayed internally, behavior reverts to that of 'best. The value can also be a list of the form (favorite TYPE ...) with the first element of the list being the symbol 'favorite'. The remaining elements of the list are strings specifying MIME types. VM will look for each TYPE in turn in the list of alternatives and choose the first matching alternative found that can be displayed. If the symbol 'favorite' is 'favorite-internal' instead, the first TYPE that matches an alternative that can be displayed internally will be chosen." :group 'vm-mime :type '(choice (choice (const best-internal) (const best) (const all)) (cons (const favorite) (repeat string)) (cons (const favorite-internal) (repeat string)))) (defcustom vm-mime-text/html-handler 'auto-select "*The library used for displaying HTML messages. The possible values are: emacs-w3m The emacs interface to the w3m viewer, emacs-w3 The emacs interface to the w3 viewer, w3m The w3m viewer used externally to convert to plain text, lynx The lynx viewer used externally to convert to plain text, auto-select Automatic selection among these alternatives, and nil No internal display of HTML messages. " :group 'vm-mime :type '(choice (const nil :tag "Do not display HTML messages.") (const auto-select :tag "Autoselect best method") (const emacs-w3m) (const emacs-w3) (const w3m) (const lynx))) (defcustom vm-mime-text/html-blocker "]*\\s-src=." "*Regexp after which a \"blocked:\" will be inserted. This is done in order to prevent loading of embedded images used to check if and when you read an email." :group 'vm-mime :type 'regexp) (defcustom vm-mime-text/html-blocker-exceptions nil "*Regexp matching URL which should not be blocked." :group 'vm-mime :type '(choice (const :tag "None" nil) regexp)) (defcustom vm-mime-default-face-charsets (if vm-fsfemacs-mule-p (if (eq window-system nil) '("us-ascii" "iso-8859-1") '("us-ascii")) '("us-ascii" "iso-8859-1")) "*List of character sets that can be displayed using the `default' face. The default face is what you normally see when you edit text in Emacs. The font assigned to the default face can typically display one or two character sets. For U.S. and Western European users, ``us-ascii'' and one of the ISO-8859 character sets usually can be displayed. Whatever character sets that your default face can display should be listed as the value of `vm-mime-default-face-charsets'. Example: (setq vm-mime-default-face-charsets '(\"us-ascii\" \"iso-8859-1\")) Case is not significant in character set names. For Emacs versions with MULE or Unicode support, this variable is semi-obsolete and should only be used for making bogus, unregistered character sets that are slight variants of ISO-8859-1 visible. Don't add charsets like \"utf-8\" that require additional decoding. A value of t means all character sets can be displayed by the default face. This should only be used in combination with `vm-mime-default-face-charset-exceptions' to tell VM that most of the mail you receive is displayable using your default face and its associated font, even though the messages might arrive with unknown or unregistered character sets specified in the MIME Content-Type header. To tell VM how to display other character sets, see `vm-mime-charset-font-alist'." :group 'vm-mime :type '(choice (const t) (repeat string))) (defcustom vm-mime-default-face-charset-exceptions nil "*List of character sets that cannot be displayed using the default face. This variable acts as an exception list for `vm-mime-default-face-charsets'. Character sets listed here will not be considered displayable using the default face even if they are also listed in `vm-mime-default-face-charsets'." :group 'vm-mime :type '(repeat string)) (defcustom vm-mime-charset-font-alist nil "*Assoc list of character sets and fonts that can be used to display them. The format of the list is: ( (CHARSET . FONT) ...) CHARSET is a string naming a MIME registered character set such as \"iso-8859-5\". Character set names should be specified in lower case. FONT is a string naming a font that can be used to display CHARSET. An example setup might be: (setq vm-mime-charset-font-alist '( (\"iso-8859-7\" . \"-*-*-medium-r-normal-*-16-160-72-72-c-80-iso8859-7\") ) ) This variable is only useful for character sets whose characters can all be encoded in single 8-bit bytes. Also multiple fonts can only be displayed if you're running under a window system e.g. X windows. So this variable will have no effect if you're running Emacs on a tty. If you're using FSF Emacs 20 or later, or you're using XEmacs with compiled in MULE support, this value of this variable is ignored. Note that under FSF Emacs 19, any fonts you use must be the same height as your default font. XEmacs does not have this limitation." :group 'vm-mime :type '(choice (const nil) (repeat (cons string string)))) (defcustom vm-mime-use-image-strips t "*Non-nil means chop an image into horizontal strip for display. Emacs treats a displayed image as a single large character and cannot scroll vertically within an image. To work around this limitation VM can display an image as a series of contiguous horizontal strips that Emacs' scrolling routines can better handle. To do this VM needs to have the ImageMagick programs 'convert' and 'identify' installed; `vm-imagemagick-convert-program' and `vm-imagemagick-identify-program must point to them. A nil value means VM should display images without cutting them into strips." :group 'vm-mime :type 'boolean) (defcustom vm-mime-display-image-strips-incrementally t "*Non-nil means display image strips as they are created rather than waiting until all the strips are created and displaying them all at once. See `vm-mime-use-image-strips'." :group 'vm-mime :type 'boolean) (defun vm-locate-executable-file (name) (or (cond ((fboundp 'locate-file) (locate-file name exec-path nil 1)) (t (let (file done (dirs exec-path)) (while (and dirs (not done)) (setq file (expand-file-name name (car dirs))) (if (file-executable-p file) (setq done t) (setq dirs (cdr dirs)))) (and dirs file)))) (let ((vmdir (file-name-directory (locate-library "vm"))) file) (setq vmdir (expand-file-name "../src/" vmdir) file (expand-file-name name vmdir)) (if (file-exists-p file) file ; (vm-warn 0 2 "VM could not find executable %S!" name) nil)))) (defcustom vm-imagemagick-convert-program (vm-locate-executable-file "convert") "*Name of ImageMagick 'convert' program. VM uses this program to convert between image formats and to slice up images for display. Set this to nil and VM will not use the 'convert' program." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-imagemagick-identify-program (vm-locate-executable-file "identify") "*Name of ImageMagick 'identify' program. VM uses this program to gather information about images. Set this to nil and VM will not use the 'convert' program." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defvar vm-mime-image-type-converter-alist (if (stringp vm-imagemagick-convert-program) (let ((x vm-imagemagick-convert-program)) (list (list "image" "image/png" (format "%s - png:-" x)) (list "image" "image/jpeg" (format "%s - jpeg:-" x)) (list "image" "image/gif" (format "%s - gif:-" x)) (list "image" "image/tiff" (format "%s - tiff:-" x)) (list "image" "image/xpm" (format "%s - xpm:-" x)) (list "image" "image/pbm" (format "%s - pbm:-" x)) (list "image" "image/xbm" (format "%s - xbm:-" x)) )))) (defcustom vm-mime-delete-after-saving nil "*Non-nil value causes VM to delete MIME body contents from a folder after the MIME object has been saved to disk. The MIME object is replaced with a message/external-body object that points to the disk copy of the object." :group 'vm-mime :type 'boolean) (defcustom vm-mime-confirm-delete t "*Non-nil value causes VM to request confirmation from the user before deleting a MIME object with `vm-delete-mime-object'." :group 'vm-mime :type 'boolean) (defcustom vm-mime-saveable-types (append '("application" "x-unknown" "application/x-gzip") ;; These are eliminated because they depend on evaluation order. ;; USR, 2011-04-28 ;; (mapcar (lambda (a) (car a)) ;; vm-mime-external-content-types-alist) ) "*List of MIME types which should be saved." :group 'vm-mime :type '(repeat (string :tag "MIME type" nil))) (defvaralias 'vm-mime-savable-types 'vm-mime-saveable-types) (defcustom vm-mime-saveable-type-exceptions '("text") "*List of MIME types which should not be saved." :group 'vm-mime :type '(repeat (string :tag "MIME type" nil))) (defvaralias 'vm-mime-savable-type-exceptions 'vm-mime-saveable-type-exceptions) (defcustom vm-mime-deleteable-types (append '("application" "x-unknown" "application/x-gzip") ;; These are eliminated because they depend on evaluation order. ;; USR, 2011-04-28 ;; (mapcar (lambda (a) (car a)) ;; vm-mime-external-content-types-alist) ) "*List of MIME types which should be deleted." :group 'vm-mime :type '(repeat (string :tag "MIME type" nil))) (defvaralias 'vm-mime-deletable-types 'vm-mime-deleteable-types) (defcustom vm-mime-deleteable-type-exceptions '("text") "*List of MIME types which should not be deleted." :group 'vm-mime :type '(repeat (string :tag "MIME type" nil))) (defvaralias 'vm-mime-deletable-type-exceptions 'vm-mime-deleteable-type-exceptions) (defvar vm-mime-auto-save-all-attachments-avoid-recursion nil "For internal use.") (defface vm-mime-button '((((type x w32 mswindows mac) (class color) (background light)) (:background "lightgrey" :box (:line-width 2 :style released-button))) (((type x w32 mswindows mac) (class color) (background dark)) (:background "grey50" :box (:line-width 2 :style released-button))) (((class color) (background light)) (:foreground "blue" :underline t)) (((class color) (background dark)) (:foreground "cyan" :underline t)) (t (:underline t))) "Default face used for MIME buttons." :group 'vm-faces) (defface vm-mime-button-mouse '((((type x w32 mswindows mac) (class color)) (:inherit highlight :box (:line-width 2 :style released-button))) (((class color)) (:inherit highlight)) (t (:inherit highlight))) "*Face to fontify focused MIME buttons." :group 'vm-faces) (defface vm-mime-button-pressed-face '((((type x w32 mswindows mac) (class color)) (:inherit vm-mime-button :box (:line-width 2 :style pressed-button))) (((class color)) (:inherit vm-mime-button)) (t (:inherit vm-mime-button))) "*Face to fontify pressed MIME buttons. (This is not yet used in VM.)" :group 'vm-faces) (defcustom vm-mime-button-face 'vm-mime-button "*Face used for text in buttons that trigger the display of MIME objects." :group 'vm-faces :type 'symbol) (defcustom vm-mime-button-mouse-face 'vm-mime-button-mouse "*Face used for text in MIME buttons when mouse is hovering." :group 'vm-faces :type 'symbol) (defface vm-attachment-button '((((type x w32 mswindows mac) (class color) (background light)) (:background "LavenderBlush3" :box (:line-width 2 :style released-button))) (((type x w32 mswindows mac) (class color) (background dark)) (:background "LavenderBlush4" :box (:line-width 2 :style released-button))) (((class color) (background light)) (:foreground "blue" :underline t)) (((class color) (background dark)) (:foreground "cyan" :underline t)) (t (:underline t))) "Default face used for MIME buttons." :group 'vm-faces) (defface vm-attachment-button-mouse '((((type x w32 mswindows mac) (class color)) (:inherit highlight :box (:line-width 2 :style released-button))) (((class color)) (:inherit highlight)) (t (:inherit highlight))) "*Face to fontify focused MIME buttons." :group 'vm-faces) (defface vm-attachment-button-pressed-face '((((type x w32 mswindows mac) (class color)) (:inherit vm-attachment-button :box (:line-width 2 :style pressed-button))) (((class color)) (:inherit vm-attachment-button)) (t (:inherit vm-attachment-button))) "*Face to fontify pressed MIME buttons. (This is not yet used in VM.)" :group 'vm-faces) (defcustom vm-attachment-button-face 'vm-attachment-button "*Face used for text in buttons that trigger the display of MIME objects." :group 'vm-faces :type 'symbol) (defcustom vm-attachment-button-mouse-face 'vm-attachment-button-mouse "*Face used for text in MIME buttons when mouse is hovering." :group 'vm-faces :type 'symbol) (defcustom vm-mime-button-format-alist '(("text" . "%-60.60(%t (%c): %f, %d%) %10.10([%a]%)") ("multipart/alternative" . "%-50.50(%d%) %20.20([%a]%)") ("multipart/digest" . "%-50.50(%d, %n message%s%) %20.20([%a]%)") ("multipart" . "%-50.50(%d, %n part%s%) %20.20([%a]%)") ("message/partial" . "%-50.50(%d, part %N (of %T)%) %20.20([%a]%)") ("message/external-body" . "%-55.55(%d%) [%a (%x)]") ("message" . "%-50.50(%d%) %20.20([%a]%)") ("audio" . "%-55.55(%t: %f, %d%) %10.10([%a]%)") ("video" . "%-55.55(%t: %f, %d%) %10.10([%a]%)") ("image" . "%-55.55(%t: %f, %d%) %10.10([%a]%)") ("application" . "%-55.55(%t: %f, %d%) %10.10([%a]%)")) ;; old definition ;; '(("text" . "%-35.35(%d, %c%) [%k to %a]") ;; ("multipart/alternative" . "%-35.35(%d%) [%k to %a]") ;; ("multipart/digest" . "%-35.35(%d, %n message%s%) [%k to %a]") ;; ("multipart" . "%-35.35(%d, %n part%s%) [%k to %a]") ;; ("message/partial" . "%-35.35(%d, part %N (of %T)%) [%k to %a]") ;; ("message/external-body" . "%-35.35(%d%) [%k to %a (%x)]") ;; ("message" . "%-35.35(%d%) [%k to %a]") ;; ("audio" . "%-35.35(%d%) [%k to %a]") ;; ("video" . "%-35.35(%d%) [%k to %a]") ;; ("image" . "%-35.35(%d%) [%k to %a]") ;; ("application/octet-stream" . "%-35.35(%d, %f%) [%k to %a]")) "*List of types and formats for MIME buttons. When VM does not display a MIME object immediately, it displays a button or tag line in its place that describes the object and what you have to do to display it. The value of `vm-mime-button-format-alist' determines the format of the text in those buttons. The format of the list is ((TYPE . FORMAT) (TYPE . FORMAT) ...) The list is searched sequentially and the FORMAT corresponding to the first TYPE that matches the type of the button's object is used. TYPE should be a string specifying a top level type or a type/subtype pair. If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. FORMAT should be a string specifying the text of the button. The string should not include a newline. The string may contain the printf-like `%' conversion specifiers which substitute information about the MIME object into the button. Recognized specifiers are: a - the default action of the button. E.g. \"display image\" for images, \"display text\" for text objects and so on. c - the character set of the object. Usually only specified for text objects. Displays as \"us-ascii\" if the MIME object does not specifiy a character set. d - the content description of the object taken from the Content-Description header, if present. If the header isn't present, a generic description is provided. e - the content transfer encoding, either \"base64\" or \"quoted-printable\". f - the suggested file name to save the object into, as specified either in the Content-Disposition header, or the \"name\" parameter for objects of type \"application\". k - how to activate the button. Usually \"Press RETURN\" or \"Click mouse-2\". n - for multipart types this is the number of bundled parts, messages, whatever. N - for message/partial objects, the part number. s - an empty string if %n would display \"1\", otherwise \"s\". t - the content type of the object, e.g. \"text/enriched\". T - for message/partial objects, the total number of expected parts. \"?\" is displayed if the object doesn't specify the total number of parts expected. x - the content type of the external body of a message/external-body object. ( - starts a group, terminated by %). Useful for specifying the field width and precision for the concatentation of group of format specifiers. Example: \"%.25(%d, %t, %f%)\" specifies a maximum display width of 25 characters for the concatenation of the content description, content type and suggested file name. ) - ends a group. Use %% to get a single %. A numeric field width may be given between the `%' and the specifier; this causes right justification of the substituted string. A negative field width causes left justification. The field width may be followed by a `.' and a number specifying the maximum allowed length of the substituted string. If the string is longer than this value the right end of the string is truncated. If the value is negative, the string is truncated on the left instead of the right." :group 'vm-mime :type '(repeat (cons (string :tag "MIME Type") (string :tag "Format")))) (defcustom vm-mime-parts-display-separator "\n----------------------------------------------------------------------\n" "*Separator string to insert between mime parts when displayed one after another." :group 'vm-mime :type 'string) (defcustom vm-mime-7bit-composition-charset "us-ascii" "*Character set that VM should assume if it finds no character codes > 128 in a composition buffer. Composition buffers are assumed to use this character set unless the buffer contains a byte with the high bit set. This variable specifies what character set VM should assume if no such a character is found. This variable is unused in XEmacs/MULE. Since multiple character sets can be displayed in a single buffer under MULE, VM will map the file coding system of the composition buffer to a single MIME character set that can display all the buffer's characters." :group 'vm-mime :type 'string) (defcustom vm-mime-8bit-composition-charset nil "*Character set that VM should assume if it finds non-US-ASCII characters in a composition buffer. Composition buffers are assumed to use US-ASCII unless the buffer contains a byte with the high bit set. This variable specifies what character set VM should assume if such a character is found. This variable is unused in XEmacs/MULE and FSF Emacs starting with version 20. Since multiple character sets can be displayed in a single buffer under MULE, VM will map the file coding system of the buffer to a single MIME character set that can display all the buffer's characters." :group 'vm-mime :type '(choice (const nil) (string :tag "iso-8859-1" "iso-8859-1") (string :tag "iso-2022-jp" "iso-2022-jp") (string :tag "User defined") (const :tag "Auto select" nil))) (defcustom vm-mime-8bit-text-transfer-encoding 'quoted-printable "*Symbol specifying what kind of transfer encoding to use on 8bit text. Characters with the high bit set cannot safely pass through all mail gateways and mail transport software. MIME has two transfer encodings that convert 8-bit data to 7-bit for safe transport. Quoted-printable leaves the text mostly readable even if the recipient does not have a MIME-capable mail reader. BASE64 is unreadable without a MIME-capable mail reader, unless your name is U3BvY2s=. A value of 'quoted-printable, means to use quoted-printable encoding. A value of 'base64 means to use BASE64 encoding. A value of '8bit means to send the message as is. Note that this variable usually only applies to textual MIME content types. Images, audio, video, etc. typically will have some attribute that makes VM consider them to be \"binary\", which moves them outside the scope of this variable. For example, messages with line lengths of 1000 characters or more are considered binary, as are messages that contain carriage returns (ascii code 13) or NULs (ascii code 0)." :group 'vm-mime :type '(choice (const quoted-printable) (const base64) (const 8bit))) (defcustom vm-mime-composition-armor-from-lines nil "*Non-nil value means \"From \" lines should be armored before sending. A line beginning with \"From \" is considered a message separator by many mail delivery agents. These agents will often insert a > before the word \"From\" to prevent mail readers from being confused. This is proper behavior, but it breaks digitally signed messages, which require bit-perfect transport in order for the message contents to be considered genuine. If `vm-mime-composition-armor-from-lines' is non-nil, a line beginning with \"From \" will cause VM to encode the message using either quoted-printable or BASE64 encoding so that the From line can be protected." :group 'vm-mime :type 'boolean) (defcustom vm-mime-attachment-auto-type-alist '( ("\\.jpe?g$" . "image/jpeg") ("\\.gif$" . "image/gif") ("\\.png$" . "image/png") ("\\.tiff?$" . "image/tiff") ("\\.svg$" . "image/svg+xml") ("\\.pcx$" . "image/x-pcx") ("\\.txt$" . "text/plain") ("\\.html?$" . "text/html") ("\\.css$" . "text/css") ("\\.csv$" . "text/csv") ("\\.xml$" . "text/xml") ("\\.vcf$" . "text/x-vcard") ("\\.vcard$" . "text/x-vcard") ("\\.au$" . "audio/basic") ("\\.mp4$" . "audio/mp4") ("\\.m4[abpr]$". "audio/mp4") ("\\.wma$" . "audio/x-ms-wma") ("\\.wax$" . "audio/x-ms-wax") ("\\.ram?$" . "audio/vnd.ra-realaudio") ("\\.ogg$" . "audio/vorbis") ("\\.oga$" . "audio/vorbis") ("\\.wav$" . "audio/vnd.wave") ("\\.mpe?g$" . "video/mpeg") ("\\.m4v$" . "video/mp4") ("\\.mov$" . "video/quicktime") ("\\.ogc$" . "video/ogg") ("\\.wmv$" . "video/x-ms-wmv") ("\\.webm$" . "video/webm") ("\\.zip$" . "application/zip") ("\\.gz$" . "application/x-gzip") ("\\.tar$" . "application/x-tar") ("\\.rar$" . "application/x-rar-compressed") ("\\.e?ps$" . "application/postscript") ("\\.pdf$" . "application/pdf") ("\\.dvi$" . "application/x-dvi") ("\\.tex$" . "application/x-latex") ("\\.ttf$" . "application/x-font-ttf") ("\\.swf$" . "application/x-shockwave-flash") ("\\.tex$" . "application/x-latex") ("\\.js$" . "application/javascript") ("\\.dtd$" . "application/xml-dtd") ("\\.pdf$" . "application/pdf") ("\\.rtf$" . "application/rtf") ("\\.doc$" . "application/msword") ("\\.xls$" . "application/vnd.ms-excel") ("\\.ppt$" . "application/vnd.ms-powerpoint") ("\\.mdb$" . "application/vnd.ms-access") ("\\.odt$" . "application/vnd.oasis.opendocument.text") ("\\.odp$" . "application/vnd.oasis.opendocument.presentation") ("\\.ods$" . "application/vnd.oasis.opendocument.spreadsheet") ("\\.odg$" . "application/vnd.oasis.opendocument.graphics") ("\\.odf$" . "application/vnd.oasis.opendocument.formulae") ("\\.odb$" . "application/vnd.oasis.opendocument.databases") ("\\.docx$" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document") ("\\.docm$" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document") ("\\.pptx$" . "application/vnd.openxmlformats-officedocument.presentationml.presentation") ("\\.pptm$ " . "application/vnd.openxmlformats-officedocument.presentationml.presentation") ("\\.xlsx$" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") ("\\.xlsm$" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") ("\\.hqx$" . "application/mac-binhex40") ) "*Alist used to guess a MIME content type based on a file name. The list format is ((REGEXP . TYPE) ...) REGEXP is a string that specifies a regular expression. TYPE is a string specifying a MIME content type. When a file is attached to a MIME composition buffer using `vm-attach-file', this list will be scanned until a REGEXP matches the file's name. The corresponding TYPE will be offered as a default when you are prompted for the file's type. The value of this variable is also used to guess the MIME type of application/octet-stream objects for display purposes if the value of `vm-infer-mime-types' is non-nil." :group 'vm-mime :type '(repeat (cons regexp (string :tag "MIME Type")))) (defcustom vm-mime-attachment-auto-suffix-alist '( ("image/jpeg" . ".jpg") ("image/gif" . ".gif") ("image/png" . ".png") ("image/tiff" . ".tif") ("text/html" . ".html") ("audio/basic" . ".au") ("video/mpeg" . ".mpg") ("video/quicktime" . ".mov") ("application/zip" . ".zip") ("application/postscript" . ".ps") ("application/pdf" . ".pdf") ("application/msword" . ".doc") ("application/vnd.ms-excel" . ".xls") ("application/vnd.ms-powerpoint" . ".ppt") ("application/mac-binhex40" . ".hqx") ) "*Alist used to select a filename suffix for MIME object temporary files. The list format is ((TYPE . SUFFIX) ...) TYPE is a string specifying a MIME top-level type or a type/subtype pair. If a top-level type is listed without a subtype, all subtypes of that type are matched. SUFFIX is a string specifying the suffix that should be used for the accompanying type. When a MIME object is displayed using an external viewer VM must first write the object to a temporary file. The external viewer opens and displays that file. Some viewers will not open a file unless the filename ends with some extention that it recognizes such as '.html' or '.jpg'. You can use this variable to map MIME types to extensions that your external viewers will recognize. VM will search the list for a matching type. The suffix associated with the first type that matches will be used." :group 'vm-mime :type '(repeat (cons (string :tag "MIME Type") (string :tag "File Suffix")))) (defcustom vm-mime-encode-headers-regexp "Subject\\|\\(\\(Resent-\\)?\\(From\\|To\\|CC\\|BCC\\)\\)\\|Organization" "*A regexp matching the headers which should be encoded." :group 'vm-mime :type '(regexp)) (defcustom vm-mime-encode-headers-words-regexp (let ((8bit-word "\\([^ ,\t\n\r]*[^\x0-\x7f]+[^ ,\t\n\r]*\\)+")) (concat "[ ,\t\n\r]\\(" 8bit-word "\\(\\s-+" 8bit-word "\\)*\\)")) "*A regexp matching a set of consecutive words which must be encoded." :group 'vm-mime :type '(regexp)) (defcustom vm-mime-encode-headers-type 'Q "*The encoding type to use for encoding headers." :group 'vm-mime :type '(choice (const :tag "Quoted-printable" Q) (const :tag "Binary" B) (regexp :tag "BASE64 on match of " "[^- !#-'*+/-9=?A-Z^-~]"))) (defcustom vm-mime-encode-words-regexp "[^\x0-\x7f]+" "*A regexp matching a sequence of 8 bit chars." :group 'vm-mime :type '(regexp)) (defcustom vm-mime-max-message-size nil "*Largest MIME message that VM should send without fragmentation. The value should be an integer which specifies the size in bytes. A message larger than this value will be split into multiple parts for transmission using the MIME message/partial type." :group 'vm-mime :type '(choice (const nil) integer)) (defcustom vm-mime-attachment-save-directory (expand-file-name "~/") "*Non-nil value is a default directory for saving MIME attachments. When VM prompts you for a target file name when saving a MIME body, any relative pathnames will be relative to this directory." :group 'vm-mime :type '(choice (const nil) directory)) (defcustom vm-mime-attachment-source-directory (expand-file-name "~/") "*Non-nil value is a default source directory for MIME attachments. When `vm-attach-file' prompts you for the name of a file to attach, any relative pathnames will be relative to this directory." :group 'vm-mime :type '(choice (const nil) directory)) (defcustom vm-mime-all-attachments-directory nil "*Directory to where the attachments should go or come from." :group 'vm-mime :type '(choice (directory :tag "Directory:") (const :tag "Use `vm-mime-attachment-save-directory'" nil))) (defvar vm-mime-save-all-attachments-history nil "Directory history to where the attachments should go.") (defvar vm-mime-yank-attachments nil "*This variable, originally from vm-pine, is deprecated. It is replaced by `vm-include-mime-attachments'.") (defvaralias 'vm-mime-yank-attachments 'vm-include-mime-attachments) (make-obsolete-variable 'vm-mime-yank-attachments 'vm-include-mime-attachments "8.2.0") (defcustom vm-include-mime-attachments nil "*Non-nil value enables attachments to be included in quoted text in a reply message. Otherwise only the button label will be included." :group 'vm-compose :type 'boolean) (defcustom vm-infer-mime-types nil "*Non-nil value means that VM should try to infer a MIME object's type from its filename when deciding whether the object should be displayed and how it should be displayed. This will be done only for objects of type application/octet-stream. The object's filename is checked against the regexps in `vm-mime-attachment-auto-type-alist' and the type corresponding to the first match found is used." :group 'vm-mime :type 'boolean) (defcustom vm-infer-mime-types-for-text nil "*Non-nil value means VM should try to infer a MIME object's type from its filename also for text attachments, not only for application/octet-stream." :group 'vm-mime :type 'boolean) (defvaralias 'vm-mime-attachment-infer-type-for-text-attachments 'vm-infer-mime-types-for-text) (make-obsolete-variable 'vm-mime-attachment-infer-type-for-text-attachments 'vm-infer-mime-types-for-text "8.2.0") (defcustom vm-mime-avoid-folding-content-type t "*Non-nil means don't send folded Content- headers in MIME messages. `Folded' headers are headers broken into multiple lines as specified in RFC822 for readability and to avoid excessive line lengths. At least one major UNIX vendor ships a version of sendmail that believes a folded Content-Type header is a syntax error, and returns any such message to sender. A typical error message from such a sendmail version is, 553 header syntax error, line \" charset=us-ascii\" If you see one of these, setting `vm-mime-avoid-folding-content-type' non-nil may let your mail get through." :group 'vm-mime :type 'boolean) (defcustom vm-mime-base64-decoder-program (vm-locate-executable-file "base64-decode") "*Non-nil value should be a string that names a MIME base64 decoder. If the program is in your executable search path, you need not specify a full pathname. The program should expect to read base64 data on its standard input and write the converted data to its standard output." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mime-base64-decoder-switches nil "*List of command line flags passed to the command named by `vm-mime-base64-decoder-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mime-base64-encoder-program (vm-locate-executable-file "base64-encode") "*Non-nil value should be a string that names a MIME base64 encoder. If the program is in your executable search path, you need not specify a full pathname. The program should expect arbitrary data on its standard input and write base64 data to its standard output." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mime-base64-encoder-switches nil "*List of command line flags passed to the command named by `vm-mime-base64-encoder-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mime-qp-decoder-program (vm-locate-executable-file "qp-decode") "*Non-nil value should be a string that names a MIME quoted-printable decoder. If the program is in your executable search path, you need not specify a full pathname. The program should expect to read quoted-printable data on its standard input and write the converted data to its standard output." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mime-qp-decoder-switches nil "*List of command line flags passed to the command named by `vm-mime-qp-decoder-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mime-qp-encoder-program (vm-locate-executable-file "qp-encode") "*Non-nil value should be a string that names a MIME quoted-printable encoder. If the program is in your executable search path, you need not specify a full pathname. The program should expect arbitrary data on its standard input and write quoted-printable data to its standard output." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mime-qp-encoder-switches nil "*List of command line flags passed to the command named by `vm-mime-qp-encoder-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mime-uuencode-decoder-program "uudecode" "*Non-nil value should be a string that names UUENCODE decoder. If the program is in your executable search path, you need not specify a full pathname. The program should expect to read uuencoded data on its standard input and write the converted data to the file specified in the ``begin'' line at the start of the data." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mime-uuencode-decoder-switches nil "*List of command line flags passed to the command named by `vm-mime-uuencode-decoder-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-auto-next-message t "*Non-nil value causes VM to use `vm-next-message' to advance to the next message in the folder if the user attempts to scroll past the end of the current messages. A nil value disables this behavior." :group 'vm-summary :type 'boolean) (defcustom vm-honor-page-delimiters nil "*Non-nil value causes VM to honor page delimiters (as specified by the Emacs page-delimiter variable) when scrolling through a message. This means that when VM encounters a page delimiter when displaying a message all the screen lines below that delimiter will be blank until you scroll past that delimiter. When you scroll past the delimiter the text lines between the delimiter and the next delimiter will be displayed. Scrolling backward past a page delimiter reverses this process. A nil value means ignore page-delimiters." :group 'vm-presentation :type 'boolean) (defcustom vm-page-continuation-glyph "...press SPACE to see more..." "*Glyph VM uses to indicate there is more text on the next page. When VM honors page delimiters (see `vm-honor-page-delimiters') and when VM is previewing a message (see `vm-preview-lines') VM indicates that there is more text by placing the glyph specified by this variable at the end of the displayed text. Under XEmacs, the value of `vm-page-continuation-glyph' can be a string or a glyph object. Under FSF Emacs, `vm-page-continuation-glyph' must be a string." :group 'vm-presentation :type 'boolean) (defconst vm-default-window-configuration ;; startup = folder on bottom, summary on top ;; quitting = full screen folder ;; reading-message = folder on bottom, summary on top ;; composing-message = full screen composition ;; editing-message = full screen edit ;; vm-summarize = folder on bottom, summary on top ;; vm-pipe-message-to-command = summary on top, shell output on bottom '( (startup ((((top . 70) (left . 70))) (((- (0 0 80 10) (0 10 80 40)) ((nil summary) (nil message)) ((nil nil nil t) (nil nil nil nil)))))) (quitting ((((top . 70) (left . 70))) (((0 0 80 40) ((nil message)) ((nil nil nil t)))))) (reading-message ((((top . 70) (left . 70))) (((- (0 0 80 10) (0 10 80 40)) ((nil summary) (nil message)) ((nil nil nil t) (nil nil nil nil)))))) (composing-message ((((top . 70) (left . 70))) (((0 0 80 40) ((nil composition)) ((nil nil nil t)))))) (editing-message ((((top . 70) (left . 70))) (((0 0 80 40) ((nil edit)) ((nil nil nil t)))))) (vm-summarize ((((top . 70) (left . 70))) (((- (0 0 80 10) (0 10 80 40)) ((nil summary) (nil message)) ((nil nil nil t) (nil nil nil nil)))))) (vm-folders-summarize ((((top . 70) (left . 70))) (((- (0 0 80 10) (0 10 80 40)) ((nil folders-summary) (nil message)) ((nil nil nil t) (nil nil nil nil)))))) ) "Default window configuration for VM if the user does not specify one. If you want to completely turn off VM's window configuration feature, set this variable and `vm-window-configuration-file' to nil in your .vm file. If you want to have a different window configuration setup than this, you should not set this variable directly. Rather you should set the variable `vm-window-configuration-file' to point at a file, and use the command `vm-save-window-configuration' (normally bound to `WS') to modify part of this configuration to your liking. WARNING: Don't point `vm-window-configuration-file' at your .vm or .emacs file. Your window configuration file should start out as an empty or nonexistent file. VM will repeatedly overwrite this file as you update your window configuration settings, so anything else you put into this file will go away.") (defcustom vm-window-configuration-file "~/.vm.windows" "*Non-nil value should be a string that tells VM where to load and save your window configuration settings. Your window configuration settings are loaded automatically the first time you run VM in an Emacs session, and tells VM how to set up windows depending on what you are doing inside VM. The commands `vm-save-window-configuration' (normally bound to `WS') and `vm-delete-window-configuration' (bound to `WD') let you update this information; see their documentation for more information. You cannot change your window configuration setup without giving `vm-window-configuration-file' a non-nil value. A nil value causes VM to use the default window setup specified by the value of `vm-default-window-configuration'. WARNING: Don't point `vm-window-configuration-file' at your .vm or .emacs file. Your window configuration file should start out as an empty or nonexistent file. VM will repeatedly overwrite this file as you update your window configuration settings, so anything else you put into this file will go away." :group 'vm-frames :type 'file) (defcustom vm-expunge-before-quit nil "*Non-nil value causes VM to expunge deleted messages before quitting. You can use `vm-quit-no-expunge' and `vm-quit-no-change' to override this behavior." :group 'vm-misc :type 'boolean) (defcustom vm-expunge-before-save nil "*Non-nil value causes VM to expunge deleted messages before saving a folder." :group 'vm-dispose :type 'boolean) (defcustom vm-confirm-quit 'if-something-will-be-lost "*Value of t causes VM to always ask for confirmation before quitting a VM visit of a folder. A nil value means VM will ask only when messages will be lost unwittingly by quitting, i.e. not removed by intentional delete and expunge. A value that is not nil and not t causes VM to ask only when there are unsaved changes to message attributes, or when messages will be unwittingly lost." :group 'vm-misc :type '(choice (const :tag "Always ask" t) (const :tag "Only ask if messages will be lost" nil) (const :tag "Only ask if there are unsaved changes" 'if-something-will-be-lost))) (defcustom vm-confirm-new-folders nil "*Non-nil value causes interactive calls to `vm-save-message' to ask for confirmation before creating a new folder." :group 'vm-folders :type 'boolean) (defcustom vm-delete-empty-folders t "*Non-nil value means remove empty (zero length) folders after saving. A value of t means always remove the folders. A value of nil means never remove empty folders. A value that's not t or nil means ask before removing empty folders." :group 'vm-folders :type '(choice (const :tag "Never" nil) (const :tag "Always" t) (const :tag "Ask" ask))) (defcustom vm-folder-file-precious-flag t "*Value that `file-precious-flag' should have in visited folders. A non-nil value causes folders to be saved by writing to a temporary file and then replacing the folder with that file. A nil value causes folders to be saved by writing directly to the folder without the use of a temporary file." :group 'vm-folders :type 'boolean) (defcustom vm-flush-interval 90 "*Non-nil value specifies how often VM flushes its cached internal data using a timer task. A numeric value gives the number of seconds between flushes. A value of t means flush every time there is a change. Nil means don't do flushing until a message or folder is saved. Normally when a message attribute is changed. VM keeps the record of the change in its internal memory and doesn't insert the changed data into the folder buffer until a particular message or the whole folder is saved to disk. This makes normal Emacs auto-saving useless for VM folder buffers because the information you'd want to auto-save, i.e. the attribute changes are not in the buffer when it is auto-saved. Setting `vm-flush-interval' to a numeric value will cause the VM's internal memory caches to be periodically flushed to the folder buffer. This is done non-obtrusively, so that if you type something while flushing is occurring, the flush will abort cleanly and Emacs will respond to your keystrokes as usual." :group 'vm-folders :type '(choice (const :tag "Flush after folder/message saved" nil) (const :tag "Flush after every change" t) (integer :tag "Seconds"))) (defcustom vm-visit-when-saving 'not-always "*Value determines whether VM will visit folders when saving messages. `Visiting' means that VM will read the folder into Emacs and append the message to the buffer instead of appending to the folder file directly. This behavior is ideal when folders are encrypted or compressed since appending plaintext directly to such folders is a ghastly mistake. A value of t means VM will always visit folders when saving. A nil value means VM will never visit folders before saving to them, and VM will generate an error if you attempt to save messages to a folder that is being visited. The latter restriction is necessary to insure that the buffer and disk copies of the folder being visited remain consistent. A value other than nil or t means that VM will save to the folder buffer if it is visited or to the file otherwise." :group 'vm-dispose :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Not always" not-always))) (defcustom vm-auto-folder-alist nil "*Non-nil value should be an alist that VM will use to choose a default folder name when messages are saved. The alist should be of the form \((HEADER-NAME-REGEXP (REGEXP . FOLDER-NAME) ... ) ...) where HEADER-NAME-REGEXP and REGEXP are strings, and FOLDER-NAME is a string or an s-expression that evaluates to a string. If any part of the contents of the first message header whose name is matched by HEADER-NAME-REGEXP is matched by the regular expression REGEXP, VM will evaluate the corresponding FOLDER-NAME and use the result as the default folder for saving the message. If the resulting folder name is a relative pathname, then it will be rooted in the directory named by `vm-folder-directory', or the default-directory of the currently visited folder if `vm-folder-directory' is nil. If the resulting folder name is an IMAP maildrop specification, then the corresponding IMAP folder is used for saving. When FOLDER-NAME is evaluated, the current buffer will contain only the contents of the header matched by HEADER-NAME-REGEXP. It is safe to modify this buffer. You can use the match data from any \\( ... \\) grouping constructs in REGEXP along with the function buffer-substring to build a folder name based on the header information. If the result of evaluating FOLDER-NAME is a list, then the list will be treated as another auto-folder-alist and will be descended recursively. Whether REGEXP is matched case sensitively depends on the value of the variable `vm-auto-folder-case-fold-search'. Header names are always matched case insensitively." :group 'vm-dispose :type '(choice (const :tag "None" nil) (repeat (cons (regexp :tag "Header Regexp") (repeat (cons (regexp :tag "Content Regexp") (choice (string :tag "Folder Name") (sexp :tag "Folder Expresion")))))))) (defcustom vm-auto-folder-case-fold-search nil "*Non-nil value means VM will ignore case when matching header contents while doing automatic folder selection via the variable `vm-auto-folder-alist'." :group 'vm-dispose :type 'boolean) (defcustom vm-virtual-folder-alist nil "*Non-nil value should be a list of virtual folder definitions. A virtual folder is a mapping of messages from one or more real folders into what appears to be a single folder. A virtual folder definition specifies which real folders should be searched for prospective messages and what the inclusion criteria are. Each virtual folder definition should have the following form: (VIRTUAL-FOLDER-NAME ( (FOLDER-NAME ...) (SELECTOR [ARG ...]) ... ) ... ) VIRTUAL-FOLDER-NAME is the name of the virtual folder being defined. This is the name by which you and VM will refer to this folder. FOLDER-NAME should be the name of a real folder. There may be more than one FOLDER-NAME listed, the SELECTORs within that sublist will apply to them all. If FOLDER-NAME is a directory, VM will assume this to mean that all the folders in that directory should be searched. The SELECTOR is a Lisp symbol that tells VM how to decide whether a message from one of the folders specified by the FOLDER-NAMEs should be included in the virtual folder. Some SELECTORs require an argument ARG; unless otherwise noted ARG may be omitted. The recognized SELECTORs are: author - matches message if ARG matches the author; ARG should be a regular expression. author-or-recipient - matches message if ARG matches the author of the message or any of its recipients; ARG should be a regular expression. and - matches the message if all its argument selectors match the message. Example: (and (author \"Derek McGinty\") (new)) matches all new messages from Derek McGinty. `and' takes any number of arguments. any - matches any message. deleted - matches message if it is flagged for deletion. edited - matches message if it has been edited. filed - matches message if it has been saved with its headers. forwarded - matches message if it has been forwarded using a variant of `vm-forward-message' or `vm-send-digest'. header - matches message if ARG matches any part of the header portion of the message; ARG should be a regular expression. header-field - matches message if the header field named ARG1 has the regular expression pattern ARG2. header-or-text - matches message if ARG matches any part of the headers or the text portion of the message; ARG should be a regular expression. label - matches message if message has a label named ARG. less-chars-than - matches message if message has less than ARG characters. ARG should be a number. less-lines-than - matches message if message has less than ARG lines. ARG should be a number. more-chars-than - matches message if message has more than ARG characters. ARG should be a number. more-lines-than - matches message if message has more than ARG lines. ARG should be a number. marked - matches message if it is marked, as with `vm-mark-message'. new - matches message if it is new. not - matches message only if its selector argument does NOT match the message. Example: (not (deleted)) matches messages that are not deleted. or - matches the message if any of its argument selectors match the message. Example: (or (author \"Dave Weckl\") (subject \"drum\")) matches messages from Dave Weckl or messages with the word \"drum\" in their Subject header. `or' takes any number of arguments. read - matches message if it is neither new nor unread. recent - matches message if it is new. recipient - matches message if ARG matches any part of the recipient list of the message. ARG should be a regular expression. redistributed - matches message if it has been redistributed using `vm-resend-message'. replied - matches message if it has been replied to. sent-after - matches message if it was sent after the date ARG. A fully specified date looks like this: \"31 Dec 1999 23:59:59 GMT\" although the parts can appear in any order. You can leave out any part and it will default to the current date's value for that part, with the exception of the hh:mm:ss part which defaults to midnight. sent-before - matches message if it was sent before the date ARG. A fully specified date looks like this: \"31 Dec 1999 23:59:59 GMT\" although the parts can appear in any order. You can leave out any part and it will default to the current date's value for that part, with the exception of the hh:mm:ss part which defaults to midnight. subject - matches message if ARG matches any part of the message's subject; ARG should be a regular expression. text - matches message if ARG matches any part of the text portion of the message; ARG should be a regular expression. unanswered - matches message if it has not been replied to. Same as the `unreplied' selector. undeleted - matches message if it has not been deleted. unedited - matches message if it has not been edited. unfiled - matches message if it has not been saved with its headers. unforwarded - matches message if it has not been forwarded using `vm-forward-message' or `vm-send-digest' or one of their variants. unread - matches message if it is not new and hasn't been read. unseen - matches message if it is not new and hasn't been read. Same as `unread' selector. unredistributed - matches message if it has not been redistributed using `vm-resend-message'. unreplied - matches message if it has not been replied to. virtual-folder-member - matches message if the message is already a member of some virtual folder currently being visited. written - matches message if it has been saved without its headers. " :group 'vm-folders :type '(choice (const :tag "none" nil) (repeat (group (string :tag "Virtual Folder Name") (repeat :tag "Folder List" string) (sexp :tag "Selectors"))))) (defcustom vm-virtual-mirror t "*Non-nil value causes the attributes of messages in virtual folders to mirror the changes in the attributes of the underlying real messages. Similarly, changes in the attributes of virtual messages will change the attributes of the underlying real messages. A nil value causes virtual messages to have their own distinct set of attributes, apart from the underlying real message. This variable automatically becomes buffer-local when set in any fashion. You should set this variable only in your .vm or .emacs file. Use setq-default. Once VM has been started, you should not set this variable directly, rather you should use the command `vm-toggle-virtual-mirror', normally bound to `V M'." :group 'vm-folders :type 'boolean) (make-variable-buffer-local 'vm-virtual-mirror) (defvar vm-folder-read-only nil "*Non-nil value causes a folder to be considered unmodifiable by VM. Commands that modify message attributes or messages themselves are disallowed. Commands that add or remove messages from the folder are disallowed. Commands that scan or allow the reading of messages are allowed but the `new' and `unread' message flags are not changed by them. This variable automatically becomes buffer-local when set in any fashion. You should set this variable only in your .vm or .emacs file. Use setq-default. Once VM has been started, you should not set this variable directly, rather you should use the command `vm-toggle-read-only', normally bound to C-x C-q.") (make-variable-buffer-local 'vm-folder-read-only) (defcustom vm-included-text-prefix " > " "*String used to prefix included text in replies." :group 'vm-compose :type 'string) (defcustom vm-keep-sent-messages 1 "*Non-nil value N causes VM to keep the last N messages sent from within VM. `Keep' means that VM will not kill the composition buffer after you send a message with C-c C-c (`vm-mail-send-and-exit'). A value of 0 or nil causes VM never to keep such buffers. A value of t causes VM never to kill such buffers. Note that these buffers will vanish once you exit Emacs. To keep a permanent record of your outgoing mail, use the `mail-archive-file-name' variable." :group 'vm-compose :type '(choice (const :tag "Keep" Keep) (const :tag "Don't Keep" nil) (integer :tag "Keep N"))) (defcustom vm-confirm-mail-send nil "*Non-nil means ask before sending a mail message. This affects `vm-mail-send' and `vm-mail-send-and-exit' in Mail mode." :group 'vm-compose :type 'boolean) (defcustom vm-mail-auto-save-directory nil "*Directory where messages being composed are auto-saved. If it is nil, `vm-folder-directory' is used for this purpose." :group 'vm-compose :type '(choice (const nil) directory)) (defcustom vm-mail-header-from nil "*Non-nil value should be a string that will be appear as the body of the From header in outbound mail messages. A nil value means don't insert a From header. This variable also controls the inclusion and format of the Resent-From header, when resending a message with `vm-resend-message'." :group 'vm-compose :type '(choice (const nil) string)) (defcustom vm-mail-use-sender-address nil "*If this set to `t', \\[vm-mail] will use the sender of the current message as the recipient for the new message composition." :group 'vm-compose :type 'boolean) (defcustom vm-mail-header-insert-date t "*Non-nil value causes VM to insert a Date header into a message when it is sent. If the message has a Date header, it will be removed before the new one is inserted. If the message being sent is a resent message (i.e. has a Resent- recipient header) then the Resent-Date header will be removed/inserted instead. This is useful if you set mail-archive-file-name, because your archived message will contain a Date header. A nil value means don't insert a Date header." :group 'vm-compose :type 'boolean) (defcustom vm-mail-header-insert-message-id t "*Non-nil value causes VM to insert a Message-ID header into a message when it is sent. If the message has a Message-ID header, it will be removed before the new one is inserted. If the message being sent is a resent message (i.e. has a Resent- recipient header) a Resent-Message-ID header will be removed/inserted instead. This is useful if you set mail-archive-file-name, because your archived messages will contain a Message-ID header, which may be useful later for threading messages. A nil value means don't insert a Message-ID header." :group 'vm-compose :type 'boolean) (defcustom vm-mail-mode-hidden-headers '("References" "X-Mailer") "*A list of headers to hide in `vm-mail-mode'." :group 'vm-compose :type '(repeat :tag "Header" string)) (defcustom vm-mail-header-order '("From:" "Organization:" "Subject:" "Date:" "Priority:" "X-Priority:" "Importance:" "Message-ID:" "MIME-Version:" "Content-Type:" "To:" "Newsgroups:" "CC:" "BCC:" "Reply-To:") "*Order of headers when calling `vm-reorder-message-headers' interactively in a composition buffer." :group 'vm-compose :type '(repeat :tag "Header" string)) (defcustom vm-mail-reorder-message-headers nil "*Reorder message headers before sending." :group 'vm-compose :type 'boolean) (defcustom vm-do-fcc-before-mime-encode nil "*Non-nil means to FCC before encoding. This allows saving of messages unencoded, specifically not to waste storage for attachments which are stored on disk anyway." :group 'vm-compose :type 'boolean) (defcustom vm-reply-subject-prefix nil "*Non-nil value should be a string that VM should add to the beginning of the Subject header in replies, if the string is not already present. Nil means don't prefix the Subject header." :group 'vm-compose :type '(choice (const nil) string)) (defcustom vm-reply-ignored-addresses nil "*Non-nil value should be a list of regular expressions that match addresses that VM should automatically remove from the recipient headers of replies. These addresses are removed from the headers before you are placed in the message composition buffer. So if you see an address in the header you don't want you should remove it yourself. Case is ignored when matching the addresses." :group 'vm-compose :type '(choice (const nil) (repeat regexp))) (defcustom vm-reply-ignored-reply-tos nil "*Non-nil value should be a list of regular expressions that match addresses that, if VM finds in a message's Reply-To header, VM should ignore the Reply-To header and not use it for replies. VM will use the From header instead. Case is ignored when matching the addresses. This variable exists solely to provide an escape chute from mailing lists that add a Reply-To: mailing list header, thereby leaving no way to reply to just the author of a message." :group 'vm-compose :type '(choice (const nil) (repeat regexp))) (defcustom vm-in-reply-to-format "%i" "*String which specifies the format of the contents of the In-Reply-To header that is generated for replies. See the documentation for the variable `vm-summary-format' for information on what this string may contain. The format should *not* end with a newline. Nil means don't put an In-Reply-To header in replies. If the format includes elements with non-ASCII characters, then \"In-Reply-To\" should be added to `vm-mime-encode-headers-regexp'." :group 'vm-compose :type '(choice (const nil) string)) (defcustom vm-included-text-attribution-format "%F writes:\n" "*String which specifies the format of the attribution that precedes the included text from a message in a reply. See the documentation for the variable `vm-summary-format' for information on what this string may contain. Nil means don't attribute included text in replies." :group 'vm-compose :type '(choice (const nil) string)) (defcustom vm-include-text-basic nil "*If true a reply will include the basic text of a message. This is an old method for citing messages and should not be used normally." :group 'vm-compose :type 'boolean) (defvar vm-include-text-from-presentation nil "*If true `vm-reply-include-text' will include the presentation of a message as shown in the Presentation buffer, instead of the normal text generated by the default VM method. This is an exeperimental feature that should not be used normally, but it might give better results when using filling or MIME encoded messages, e.g. HTML message. You can only include the presentation of the current message in your reply using this method. Marked messages, threads and prefix argument counts are not available.") (make-obsolete-variable 'vm-load-headers-only nil "8.2.0") (defcustom vm-included-mime-types-list nil "*If non-nil, the list of mime type/subtype pairs that should be included in quoted text in a reply message in addition to the default types. This variable currently has an effect only if `vm-include-text-basic' is true. It has no effect for the default text quotation mechanism based on MIME decoding. The defaut value is nil." :group 'vm-compose :type '(choice (const nil) (repeat string))) (defcustom vm-included-text-headers nil "*List of headers that should be retained in a message included in a reply. These should be listed in the order you wish them to appear in the included text. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-included-text-discard-header-regexp' is nil, the headers matched by `vm-included-text-headers' are the only headers that will be retained. If `vm-included-text-discard-header-regexp' is non-nil, then the headers matched by that variable will be omitted; all the others will be included. `vm-included-text-headers' determines the header order in that case, with headers not matching any in the `vm-included-text-headers' list appearing last in the header section of the included text." :group 'vm-compose :type '(choice (const nil) (repeat regexp))) (defcustom vm-included-text-discard-header-regexp nil "*Non-nil value should be a regular expression that tells what headers should not be retained in a message included in a reply. This variable along with `vm-included-text-headers' determines which headers are retained. If the value of `vm-included-text-discard-header-regexp' is nil, the headers matched by `vm-included-text-headers' are the only headers that will be retained. If `vm-included-text-discard-header-regexp' is non-nil, then only headers matched by this variable will not be retained; all others will be included. `vm-included-text-headers' determines the header order in that case, with headers not matching any in the `vm-included-text-headers' list appearing last in the header section of the included text." :group 'vm-compose :type '(choice (const nil) regexp)) (defcustom vm-forwarding-subject-format "forwarded message from %F" "*String which specifies the format of the contents of the Subject header that is generated for a forwarded message. See the documentation for the variable `vm-summary-format' for information on what this string may contain. The format should *not* end with nor contain a newline. Nil means leave the Subject header empty when forwarding." :group 'vm-compose :type '(choice (const nil) (string))) (defcustom vm-forwarded-message-preamble-format "\n---------- Original Message ----------\n" "*String which specifies the preamble for a forwarded message." :group 'vm-compose :type 'string) (defcustom vm-forwarded-headers nil "*List of headers that should be forwarded by `vm-forward-message'. The headers should be listed in the order you wish them to appear in the forwarded message. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case-insensitively. If the value of `vm-unforwarded-header-regexp' is nil, the headers matched by `vm-forwarded-headers' are the only headers that will be forwarded. If `vm-unforwarded-header-regexp' is non-nil, then the headers matched by that variable will be omitted and all the others will be forwarded. `vm-forwarded-headers' determines the forwarding order in that case, with headers not matching any in the `vm-forwarded-headers' list appearing last in the header section of the forwarded message." :group 'vm-compose :type '(repeat regexp)) (defcustom vm-unforwarded-header-regexp "none-to-be-dropped" "*Non-nil value should be a regular expression that tells what headers should not be forwarded by `vm-forward-message' and `vm-send-digest'. This variable along with `vm-forwarded-headers' determines which headers are forwarded. If the value of `vm-unforwarded-header-regexp' is nil, the headers matched by `vm-forwarded-headers' are the only headers that will be forwarded. If `vm-unforwarded-header-regexp' is non-nil, then only the headers matched by this variable will be omitted; all the others will be forwarded. `vm-forwarded-headers' determines the forwarding order in that case, with headers not matching any in the `vm-forwarded-headers' list appearing last in the header section of the forwarded message." :group 'vm-compose :type '(choice (const :tag "Only forward headers listed in vm-forward-headers" nil) (const :tag "Forward all headers" "none-to-be-dropped") regexp)) (defcustom vm-forwarded-headers-plain '("From:" "To:" "Newsgroups:" "Cc:" "Subject:" "Date:" "In-Reply-To:") "*List of headers that should be forwarded by `vm-forward-message-plain'. The headers should be listed in the order you wish them to appear in the forwarded message. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g., \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case-insensitively. If the value of `vm-unforwarded-header-regexp-plain' is nil, the headers matched by `vm-forwarded-headers' are the only headers that will be forwarded. If `vm-unforwarded-header-regexp-plain' is non-nil, then the headers matched by that variable will be omitted and all the others will be forwarded. In this case, `vm-forwarded-headers-plain' determines the forwarding order in that case, with headers not matching any in the `vm-forwarded-headers-plain' list appearing last in the header section of the forwarded message." :group 'vm-compose :type '(repeat regexp)) (defcustom vm-unforwarded-header-regexp-plain nil "*Non-nil value should be a regular expression that tells what headers should not be forwarded by `vm-forward-message-plain'. This variable along with `vm-forwarded-headers-plain' determines which headers are forwarded. If the value of `vm-unforwarded-header-regexp-plain' is nil, the headers matched by `vm-forwarded-headers-plain' are the only headers that will be forwarded. If `vm-unforwarded-header-regexp-plain' is non-nil, then only the headers matched by this variable will be omitted; all the others will be forwarded. `vm-forwarded-headers-plain' determines the forwarding order in that case, with headers not matching any in the `vm-forwarded-headers-plain' list appearing last in the header section of the forwarded message." :group 'vm-compose :type '(choice (const :tag "Only forward headers listed in vm-forward-headers-plain" nil) (const :tag "Forward all headers" "none-to-be-dropped") regexp)) (defconst vm-forwarded-mime-headers '("MIME" "Content") "List of MIME headers that are always included in messages forwarded with encapsulation.") (defcustom vm-forwarding-digest-type "mime" "*Non-nil value should be a string that specifies the type of message encapsulation format to use when forwarding messages. Legal values of this variable are: \"mime\" \"rfc934\" \"rfc1153\" nil A nil value means to use plain text forwarding." :group 'vm-compose :type '(choice (const "mime") (const "rfc934") (const "rfc1153") (const nil :tag "Forward in plain text"))) (defcustom vm-mime-forward-local-external-bodies nil "*Non-nil value means forward messages that contain message/external-body parts that use the `local-file' access method. A nil value means copy the externally referenced objects into the message before forwarding. This copying is only done for objects accessed with the `local-file' access method. Objects referenced with other methods are not copied. Messages that use the mesage/external-body type contain a reference to an object (image, audio, etc.) instead of the object itself. So instead of the data that makes up an image, there might be a reference to a local file that contains the image. If the recipient doesn't have access to your local filesystems then they will not be able to use the message/external-body reference. That is why the default value of this variable is nil, which forces such referneces to be converted to objects present in the message itself." :group 'vm-mime :type 'boolean) (defcustom vm-burst-digest-messages-inherit-labels t "*Non-nil values means messages from a digest inherit the digest's labels. Labels are added to messages with `vm-add-message-labels', normally bound to `l a'." :group 'vm-digest :type 'boolean) (defcustom vm-digest-preamble-format "\"%s\" (%F)" "*String which specifies the format of the preamble lines generated by `vm-send-digest' when it is invoked with a prefix argument. One line will be generated for each message put into the digest. See the documentation for the variable `vm-summary-format' for information on what this string may contain. The format should *not* end with nor contain a newline." :group 'vm-digest :type 'string) (defcustom vm-digest-center-preamble t "*Non-nil value means VM will center the preamble lines that precede the start of a digest. How the lines will be centered depends on the ambient value of fill-column. A nil value suppresses centering." :group 'vm-digest :type 'boolean) (defcustom vm-digest-identifier-header-format "X-Digest: %s\n" "*Header to insert into messages burst from a digest. Value should be a format string of the same type as `vm-summary-format' that describes a header to be inserted into each message burst from a digest. The format string must end with a newline." :group 'vm-digest :type 'string) (defcustom vm-digest-burst-type "guess" "*Value specifies the default digest type offered by `vm-burst-digest' when it asks you what type of digest you want to unpack. Allowed values of this variable are: \"rfc934\" \"rfc1153\" \"mime\" \"guess\" rfc1153 digests have a preamble, followed by a line of exactly 70 dashes, with digested messages separated by lines of exactly 30 dashes. rfc934 digests separate messages on any line that begins with a few dashes, but doesn't require lines with only dashes or lines with a specific number of dashes. In the text of the message, any line beginning with dashes is textually modified to be preceded by a dash and a space to prevent confusion with message separators. MIME digests use whatever boundary that is specified by the boundary parameter in the Content-Type header of the digest. If the value is \"guess\", and you take the default response when `vm-burst-digest' queries you, VM will try to guess the digest type." :group 'vm-digest :type '(choice (const "rfc934") (const "rfc1153") (const "mime") (const "guess"))) (defcustom vm-digest-send-type "mime" "*String that specifies the type of digest `vm-send-digest' will use. Legal values of this variable are: \"rfc934\" \"rfc1153\" \"mime\" nil A nil value means to use plain text digests." :group 'vm-digest :type '(choice (const "mime") (const "rfc934") (const "rfc1153") (const nil "Plain text digests"))) (defcustom vm-rfc934-digest-headers '("Resent-" "From:" "Sender:" "To:" "Newsgroups:" "Cc:" "Subject:" "Date:" "Message-ID:" "Keywords:") "*List of headers that should be appear in RFC 934 digests created by VM. These should be listed in the order you wish them to appear in the digest. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-rfc934-digest-discard-header-regexp' is nil, the headers matched by `vm-rfc934-digest-headers' are the only headers that will be kept. If `vm-rfc934-digest-discard-header-regexp' is non-nil, then only headers matched by that variable will be discarded; all others will be kept. `vm-rfc934-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-rfc934-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(repeat regexp)) (defcustom vm-rfc934-digest-discard-header-regexp nil "*Non-nil value should be a regular expression that tells what headers should not appear in RFC 934 digests created by VM. This variable along with `vm-rfc934-digest-headers' determines which headers are kept and which are discarded. If the value of `vm-rfc934-digest-discard-header-regexp' is nil, the headers matched by `vm-rfc934-digest-headers' are the only headers that will be kept. If `vm-rfc934-digest-discard-header-regexp' is non-nil, then only headers matched by this variable will be discarded; all others will be kept. `vm-rfc934-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-rfc934-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(choice (const nil) regexp)) (defcustom vm-rfc1153-digest-headers '("Resent-" "Date:" "From:" "Sender:" "To:" "Newsgroups:" "Cc:" "Subject:" "Message-ID:" "Keywords:") "*List of headers that should be appear in RFC 1153 digests created by VM. These should be listed in the order you wish them to appear in the digest. Regular expressions are allowed. There is no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-rfc1153-digest-discard-header-regexp' is nil, the headers matched by `vm-rfc1153-digest-headers' are the only headers that will be kept. If `vm-rfc1153-digest-discard-header-regexp' is non-nil, then only headers matched by that variable will be discarded; all others will be kept. `vm-rfc1153-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-rfc1153-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(repeat regexp)) (defcustom vm-rfc1153-digest-discard-header-regexp "\\(X400-\\)?Received:" "*Non-nil value should be a regular expression that tells what headers should not appear in RFC 1153 digests created by VM. This variable along with `vm-rfc1153-digest-headers' determines which headers are kept and which headers are discarded. If the value of `vm-rfc1153-digest-discard-header-regexp' is nil, the headers matched by `vm-rfc1153-digest-headers' are the only headers that will be kept. If `vm-rfc1153-digest-discard-header-regexp' is non-nil, then only headers matched by this variable will be discarded; all others will be kept. `vm-rfc1153-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-rfc1153-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(choice (const nil) regexp)) (defcustom vm-mime-digest-headers '("Resent-" "From:" "Sender:" "To:" "Newsgroups:" "Cc:" "Subject:" "Date:" "Message-ID:" "Keywords:" "MIME-Version:" "Content-") "*List of headers that should be appear in MIME digests created by VM. These should be listed in the order you wish them to appear in the messages in the digest. Regular expressions are allowed. There's no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-mime-digest-discard-header-regexp' is nil, the headers matched by `vm-mime-digest-headers' are the only headers that will be kept. If `vm-mime-digest-discard-header-regexp' is non-nil, then only headers matched by that variable will be discarded; all others will be kept. `vm-mime-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-mime-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(repeat regexp)) (defcustom vm-mime-digest-discard-header-regexp nil "*Non-nil value should be a regular expression that tells which headers should not appear in MIME digests created by VM. This variable along with `vm-mime-digest-headers' determines which headers are kept and which are discarded. If the value of `vm-mime-digest-discard-header-regexp' is nil, the headers matched by `vm-mime-digest-headers' are the only headers that will be kept. If `vm-mime-digest-discard-header-regexp' is non-nil, then only headers matched by this variable will be discarded; all others will be kept. `vm-mime-digest-headers' determines the order of appearance in that case, with headers not matching any in the `vm-mime-digest-headers' list appearing last in the headers of the digestified messages." :group 'vm-digest :type '(choice (const nil) regexp)) (defcustom vm-resend-bounced-headers '("MIME-Version:" "Content-" "From:" "Sender:" "Reply-To:" "To:" "Newsgroups:" "Cc:" "Subject:" "Newsgroups:" "In-Reply-To:" "References:" "Keywords:" "X-") "*List of headers that should be appear in messages resent with `vm-resend-bounced-message'. These should be listed in the order you wish them to appear in the message. Regular expressions are allowed. There is no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-resend-bounced-discard-header-regexp' is nil, the headers matched by `vm-resend-bounced-headers' are the only headers that will be kept. If `vm-resend-bounced-discard-header-regexp' is non-nil, then only headers matched by that variable will be discarded; all others will be kept. `vm-resend-bounced-headers' determines the order of appearance in that case, with headers not matching any in the `vm-resend-bounced-headers' list appearing last in the headers of the message." :group 'vm-compose :type '(repeat regexp)) (defcustom vm-resend-bounced-discard-header-regexp nil "*Non-nil value should be a regular expression that tells what headers should not appear in a resent bounced message. This variable along with `vm-resend-bounced-headers' determines which headers are kept and which headers are discarded. If the value of `vm-resend-bounced-discard-header-regexp' is nil, the headers matched by `vm-resend-bounced-headers' are the only headers that will be kept. If `vm-resend-bounced-discard-header-regexp' is non-nil, then only headers matched by this variable will be discarded; all others will be kept. `vm-resend-bounced-headers' determines the order of appearance in that case, with headers not matching any in the `vm-resend-bounced-headers' list appearing last in the headers of the message." :group 'vm-compose :type '(choice (const nil) regexp)) (defcustom vm-resend-headers nil "*List of headers that should be appear in messages resent with `vm-resend-message'. These should be listed in the order you wish them to appear in the message. Regular expressions are allowed. There is no need to anchor patterns with \"^\", as searches always start at the beginning of a line. Put a colon at the end of patterns to get exact matches. (E.g. \"Date\" matches \"Date\" and \"Date-Sent\".) Header names are always matched case insensitively. If the value of `vm-resend-discard-header-regexp' is nil, the headers matched by `vm-resend-headers' are the only headers that will be kept. If `vm-resend-discard-header-regexp' is non-nil, then only headers matched by that variable will be discarded; all others will be kept. `vm-resend-headers' determines the order of appearance in that case, with headers not matching any in the `vm-resend-headers' list appearing last in the headers of the message." :group 'vm-compose :type '(choice (const nil) repeat regexp)) (defcustom vm-resend-discard-header-regexp "\\(\\(X400-\\)?Received:\\|Resent-\\)" "*Non-nil value should be a regular expression that tells what headers should not appear in a resent message. This variable along with `vm-resend-headers' determines which headers are kept and which headers are discarded. If the value of `vm-resend-discard-header-regexp' is nil, the headers matched by `vm-resend-headers' are the only headers that will be kept. If `vm-resend-discard-header-regexp' is non-nil, then only headers matched by this variable will be discarded; all others will be kept. `vm-resend-headers' determines the order of appearance in that case, with headers not matching any in the `vm-resend-headers' list appearing last in the headers of the message." :group 'vm-compose :type '(choice (const nil) regexp)) (defcustom vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c %I\"%s\"\n" "*String which specifies the message summary line format. The string may contain the printf-like `%' conversion specifiers which substitute information about the message into the final summary line. Recognized specifiers are: p - indicator for postponed messages P - indicator for attachments, see `vm-summary-attachment-indicator' a - attribute indicators (always four characters wide) The first char is `D', `N', `U', ` ' or `!' for deleted, new, unread, read and flagged messages respectively. The second char is `F', `W' or ` ' for filed (saved) or written messages. The third char is `R', `Z' or ` ' for messages replied to, and forwarded messages. The fourth char is `E' if the message has been edited, ` ' otherwise. A - longer version of attributes indicators (seven characters wide) The first char is `D', `N', `U', ` ' or `!' for deleted, new, unread read and flagged messages respectively. The second is `r' or ` ', for message replied to. The third is `z' or ` ', for messages forwarded. The fourth is `b' or ` ', for messages redistributed. The fifth is `f' or ` ', for messages filed. The sixth is `w' or ` ', for messages written. The seventh is `e' or ` ', for messages that have been edited. b - shorter version of attribute indicators (1 character wide) The first char is `D', `N', `U', ` ' or `!' for deleted, new, unread read and flagged messages respectively. c - number of characters in message (ignoring headers) S - human readable size of the message d - numeric day of month message sent f - author's address F - author's full name (same as f if full name not found) h - hour:min:sec message sent H - hour:min message sent i - message ID I - thread indentation l - number of lines in message (ignoring headers) L - labels (as a comma list) m - month message sent M - numeric month message sent (January = 1) n - message number s - message subject t - addresses of the recipients of the message, in a comma-separated list T - full names of the recipients of the message, in a comma-separated list If a full name cannot be found, the corresponding address is used instead. U - user defined specifier. The next character in the format string should be a letter. VM will call the function vm-summary-function- (e.g. vm-summary-function-A for \"%UA\") in the folder buffer with the message being summarized bracketed by (point-min) and (point-max). The function will be passed a message struct as an argument. The function should return a string, which VM will insert into the summary as it would for information from any other summary specifier. w - day of the week message sent y - year message sent z - timezone of date when the message was sent * - `*' if the message is marked, ` ' otherwise ( - starts a group, terminated by %). Useful for specifying the field width and precision for the concatentation of group of format specifiers. Example: \"%.35(%I%s%)\" specifies a maximum display width of 35 characters for the concatenation of the thread indentation and the subject. ) - ends a group. Use %% to get a single %. A numeric field width may be given between the `%' and the specifier; this causes right justification of the substituted string. A negative field width causes left justification. The field width may be followed by a `.' and a number specifying the maximum allowed length of the substituted string. If the string is longer than this value the right end of the string is truncated. If the value is negative, the string is truncated on the left instead of the right. The summary format need not be one line per message but it must end with a newline, otherwise the message pointer will not be displayed correctly in the summary window." :group 'vm-summary :type 'string) (defcustom vm-restore-saved-summary-formats nil "*If t, the summary format is stored in each folder and restored after visiting it again." :group 'vm-summary :type 'boolean) (defcustom vm-summary-postponed-indicator "P" "*Indicator shown for postponed messages." :group 'vm-summary :type 'string) (defcustom vm-summary-attachment-indicator "$" "*Indicator shown for messages containing an attachments." :group 'vm-summary :type '(choice (string :tag "A string to display" "$") (symbol :tag "Number of attachments prefixed by" ?$))) (defcustom vm-summary-attachment-mime-types nil "*List of MIME types which should be listed as attachment. Mime parts with a disposition of attachment or a filename/name disposition parameter will be automatically considered as attachment." :group 'vm-summary :type '(repeat (string :tag "MIME type" nil))) (defcustom vm-summary-attachment-mime-type-exceptions nil "*List of MIME types which should not be listed as attachment." :group 'vm-summary :type '(repeat (string :tag "MIME type" nil))) (defcustom vm-summary-arrow "->" "*String that is displayed to the left of the summary of the message VM consider to be the current message. The value takes effect when the summary buffer is created. Changing this variable's value has no effect on existing summary buffers." :group 'vm-summary :type 'string) (defface vm-summary-highlight '((t (:inherit bold))) "Default face to use to highlight the summary entry for the current message." :group 'vm-faces) ;; (copy-face 'bold 'vm-summary-highlight) (defcustom vm-summary-highlight-face 'vm-summary-highlight "*Face to use to highlight the summary entry for the current message. Nil means don't highlight the current message's summary entry." :group 'vm-faces :type 'symbol) (defcustom vm-mouse-track-summary t "*Non-nil value means highlight summary lines as the mouse passes over them." :group 'vm-summary :type 'boolean) (defcustom vm-summary-show-threads nil "*Non-nil value means VM should display and maintain message thread trees in the summary buffer. This means that messages with a common ancestor will be displayed contiguously in the summary. (If you have `vm-move-messages-physically' set non-nil the folder itself will be reordered to match the thread ordering.) If you use the `%I' summary format specifier in your `vm-summary-format', indentation will be provided as described in the documentation for `vm-summary-thread-indent-level' (which see). A nil value means don't display thread information. The `%I' specifier does nothing in the summary format. This variable automatically becomes buffer-local when set in any fashion. You should set this variable only in your .vm or .emacs file. Use setq-default. Once VM has been started, you should not set this variable directly, rather you should use the command `vm-toggle-threads-display', normally bound to C-t." :group 'vm-summary :type 'boolean) (make-variable-buffer-local 'vm-summary-show-threads) (defcustom vm-summary-thread-indentation-by-references t "*If non-nil, threaded messages are indented according to their nesting level determined by their references headers. This is likely to be their original nesting level in the discussion. If it is nil, then the indentation level is determined by the number of thread ancestors within the folder. When some messages in the thread are missing or deleted, this is likely to be less than the original nesting level." :group 'vm-summary :type 'boolean) (defcustom vm-summary-thread-indent-level 2 "*Value should be a number that specifies how much indentation the '%I' summary format specifier should provide per thread level. A message's `thread level' refers to the number of direct ancestors from the message to the oldest ancestor the message has that is in the current folder. For example, the first message of a thread is generally a message about a new topic, e.g. a message that is not a reply to some other message. Therefore it has no ancestor and would cause %I to generate no indentation. A reply to this message will be indented by the value of `vm-summary-thread-indent-level'. A reply to that reply will be indented twice the value of `vm-summary-thread-indent-level'." :group 'vm-summary :type 'integer) (defcustom vm-summary-maximum-thread-indentation 20 "*The maximum number of thread nesting levels that should be displayed by indentation in the folder summary." :group 'vm-summary :type 'integer) (defcustom vm-thread-using-subject t "*Non-nil value causes VM to use the Subject header to thread messages. Messages with the same subject will be grouped together. A nil value means VM will disregard the Subject header when threading messages." :group 'vm-summary :type 'boolean) (defcustom vm-sort-subthreads t "*Non-nil values causes VM to sort threads as well as their subthreads by chosen sorting criteria. Nil value causes it to sort all the messages in a thread without grouping them into subthreads. This might be useful for very long threads." :group 'vm-summary :type 'boolean) ;; This variable is not used any more because threads can be sorted by ;; "activity". USR, 2011-02-09. ;; (defcustom vm-sort-threads-by-youngest-date t ;; "*Non-nil values causes VM to sort threads by their youngest date, ;; i.e., a thread A will appear before B if the youngest message in the ;; thread A is dated before the youngest message in the thread B. If the ;; variable is nil, threads are sorted by their oldest date." ;; :group 'vm-summary ;; :type 'boolean) (make-obsolete 'vm-sort-threads-by-youngest-date 'vm-sort-messages "8.2.0") (defcustom vm-summary-uninteresting-senders nil "*Non-nil value should be a regular expression that matches addresses that you don't consider interesting enough to appear in the summary. When such senders would be displayed by the %F or %f summary format specifiers VM will substitute the value of `vm-summary-uninteresting-senders-arrow' (default \"To: \") followed by what would be shown by the %T and %t specifiers respectively." :group 'vm-summary :type '(choice (const nil) regexp)) (defcustom vm-summary-uninteresting-senders-arrow "To: " "*String to display before the string that is displayed instead of an \"uninteresting\" sender. See `vm-summary-uninteresting-senders'." :group 'vm-summary :type 'string) (defcustom vm-auto-center-summary nil "*Value controls whether VM will keep the summary arrow vertically centered within the summary window. A value of t causes VM to always keep arrow centered. A value of nil means VM will never bother centering the arrow. A value that is not nil and not t causes VM to center the arrow only if the summary window is not the only existing window." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Always" t) (const :tag "Yes, if not only window" yes-if-not-only-window))) (defcustom vm-verbosity 8 "*Level of chattiness in progress messages displayed in the minibuffer. Indicative levels are: 1 - extremely quiet 5 - normally level 7 - detailed level 10 - debugging information" :group 'vm-misc :type 'integer) ;; These flags and variables are for debugging purposes (defvar vm-debug nil "*Flag used by developers to control localized debugging features.") (defvar vm-virtual-debug nil "*Flag used by developers to control localized debugging of virtual folders.") (defvar vm-traced-message-ids nil "*List of message ID's whose activity is debugged. This is for developers' use only.") (defvar vm-traced-message-subjects nil "*List of message subjectss whose activity is debugged. This is for developers' use only.") (defvar vm-summary-debug nil "*Flag used by developers for tracing summary generation") (defvar vm-summary-traced-messages nil "*List of message numbers whose activity is debugged during summary generation. This is for developers' use only.") (defvar vm-thread-debug nil "*Flag that enables the integrity checking of threads. This is for developers' use only.") (defcustom vm-subject-ignored-prefix "^\\(re: *\\)+" "*Non-nil value should be a regular expression that matches strings at the beginning of the Subject header that you want VM to ignore when threading, sorting, marking, and killing messages by subject. Matches are done case-insensitively." :group 'vm-summary :type 'regexp) (defcustom vm-subject-ignored-suffix "\\( (fwd)\\| \\)+$" "*Non-nil value should be a regular expression that matches strings at the end of the Subject header that you want VM to ignore when threading, sorting, marking and killing messages by subject. Matches are done case-insensitively." :group 'vm-summary :type 'regexp) (defcustom vm-subject-significant-chars nil "*Number of characters in the normalized message subject considered significant in message threading and sorting. The normalized subject is the contents of the Subject header after ignored prefixes and suffixes have been removed and after consecutive whitespace has been collapsed into single spaces. The first `vm-subject-significant-chars' will be considered significant. Characters beyond this point in the subject string will be ignored. A nil value for this variable means all characters in the message subject are significant." :group 'vm-summary :type '(choice (const :tag "All Characters" nil) (integer :tag "Number of characters"))) (defcustom vm-folders-summary-database "~/.vm.folders.db" "*Name of Berkeley DB file used to store summary information about folders. This file is consulted to produce the folders summary." :group 'vm-summary :type 'file) (defcustom vm-folders-summary-format " %12f %4t total, %n new, %u unread, %s spooled\n" "*String that specifies the folders summary format. The string may contain the printf-like `%' conversion specifiers which substitute information about the folder into the final summary line. Recognized specifiers are: d - the number of deleted messages in the folder f - the name of the folder without the directory part n - the number of new messages in the folder t - the total number of messages in the folder u - the number of old but still unread messages in the folder ( - starts a group, terminated by %). Useful for specifying the field width and precision for the concatentation of group of format specifiers. Example: \"%.35(%d, %t, %f%)\" specifies a maximum display width of 35 characters for the concatenation of the content description, content type and suggested file name. ) - ends a group. Use %% to get a single %. A numeric field width may be given between the `%' and the specifier; this causes right justification of the substituted string. A negative field width causes left justification. The field width may be followed by a `.' and a number specifying the maximum allowed length of the substituted string. If the string is longer than this value the right end of the string is truncated. If the value is negative, the string is truncated on the left instead of the right. The summary format need not be one line per folder, but it should end with a newline." :group 'vm-summary :type 'string) (defcustom vm-folders-summary-directories (list (or vm-folder-directory (file-name-directory vm-primary-inbox))) "*List of directories containing folders to be listed in the folders summary. List the directories in the order you wish them to appear in the summary." :group 'vm-summary :type '(repeat directory)) (defcustom vm-mutable-window-configuration pop-up-windows "*This variable's value controls VM's window usage. A non-nil value gives VM free run of the Emacs display; it will commandeer the entire screen for its purposes. A value of nil restricts VM's window usage to the window from which it was invoked. VM will not create, delete, or use any other windows, nor will it resize its own window." :group 'vm-frames :type 'boolean) (defvaralias 'vm-mutable-windows 'vm-mutable-window-configuration) (defcustom vm-mutable-frame-configuration t "*Non-nil value means VM is allowed to create and destroy frames to display and undisplay buffers. Whether VM actually does so depends on the value of the variables with names prefixed by ``vm-frame-per-''. VM can create a frame to display a buffer, and delete frame to undisplay a buffer. A nil value means VM should not create or delete frames. This variable does not apply to the VM commands whose names end in -other-frame, which always create a new frame." :group 'vm-frames :type 'boolean) (defvaralias 'vm-mutable-frames 'vm-mutable-frame-configuration) (defcustom vm-raise-frame-at-startup t "*Specifies whether VM should raise its frame at startup. A value of nil means never raise the frame. A value of t means always raise the frame. Other values are reserved for future use." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-folder t "*Non-nil value causes the folder visiting commands to visit in a new frame. Nil means the commands will use the current frame. This variable does not apply to the VM commands whose names end in -other-frame, which always create a new frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs supports multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-summary nil "*Non-nil value causes VM to display the folder summary in its own frame. Nil means the `vm-summarize' command will use the current frame. This variable does not apply to `vm-summarize-other-frame', which always create a new frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs supports multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-folders-summary nil "*Non-nil value causes VM to display the 'all folders' summary in its own frame. Nil means the `vm-folders-summarize' command will use the current frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs supports multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-composition t "*Non-nil value causes the mail composition commands to open a new frame. Nil means the commands will use the current frame. This variable does not apply to the VM commands whose names end in -other-frame, which always create a new frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs supports multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-edit t "*Non-nil value causes `vm-edit-message' to open a new frame. Nil means the `vm-edit-message' will use the current frame. This variable does not apply to `vm-edit-message-other-frame', which always create a new frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs support multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-help nil "*Non-nil value causes VM to open a new frame to display help buffers. Nil means the VM will use the current frame. This variable has no meaning if you're not running under an Emacs capable of displaying multiple real or virtual frames. Note that Emacs supports multiple virtual frames on dumb terminals, and VM will use them." :group 'vm-frames :type 'boolean) (defcustom vm-frame-per-completion t "*Non-nil value causes VM to open a new frame on mouse initiated completing reads. A mouse initiated completing read occurs when you invoke a VM command using the mouse, either with a menu or a toolbar button. That command must then prompt you for information, and there must be a limited set of valid responses. If these conditions are met and `vm-frame-per-completion''s value is non-nil, VM will create a new frame containing a list of responses that you can select with the mouse. A nil value means the current frame will be used to display the list of choices. This variable has no meaning if you're not running Emacs native under X Windows or some other window system that allows multiple real Emacs frames. Note that Emacs supports virtual frames under ttys but VM will not use these to display completion information." :group 'vm-frames :type 'boolean) (defcustom vm-frame-parameter-alist nil "*Non-nil value is an alist of types and lists of frame parameters. This list tells VM what frame parameters to associate with each new frame it creates of a specific type. The alist should be of this form ((SYMBOL PARAMLIST) (SYMBOL2 PARAMLIST2) ...) SYMBOL must be one of ``completion'', ``composition'', ``edit'', ``folder'', ``primary-folder'' or ``summary''. It specifies the type of frame that the following PARAMLIST applies to. ``completion'' specifies parameters for frames that display lists of choices generated by a mouse-initiated completing read. (See `vm-frame-per-completion'.) ``composition'' specifies parameters for mail composition frames. ``edit'' specifies parameters for message edit frames (e.g. created by `vm-edit-message-other-frame') ``folder'' specifies parameters for frames created by `vm' and the ``vm-visit-'' commands. ``folders-summary'' specifies parameters for frames created by the ``vm-folder-summarize'' command. ``primary-folder'' specifies parameters for the frame created by running `vm' without any arguments. ``summary'' specifies parameters for frames that display a summary buffer (e.g. created by `vm-summarize-other-frame') PARAMLIST is a list of pairs as described in the documentation for the function `make-frame'." :group 'vm-frames :type '(repeat (cons (choice (const completion) (const composition) (const edit) (const folder) (const folders-summary) (const primary-folder) (const summary)) (repeat (cons symbol sexp))))) (defcustom vm-search-other-frames t "*Non-nil means VM should search frames other than the selected frame when looking for a window that is already displaying a buffer that VM wants to display or undisplay." :group 'vm-frames :type 'boolean) (defvar vm-configure-datadir nil "A directory VM will search for data files. It will be set at build time and should not be used by the user.") (defvar vm-configure-pixmapdir nil "A directory VM will search for pixmaps. It will be set at build time and should not be used by the user.") (defvar vm-configure-docdir nil "A directory VM will search for documentation files. It will be set at build time and should not be used by the user.") (defvar vm-configure-infodir nil "A directory VM will search for info files. It will be set at build time and should not be used by the user.") (defun vm-pixmap-directory () "Return the directory where the pixmaps are. We look for the file followup-dn.xpm in order not to pickup the pixmaps of an older VM installation." (let* ((vm-dir (file-name-directory (locate-library "vm"))) (image-dirs (list (and vm-configure-pixmapdir (expand-file-name vm-configure-pixmapdir)) (and vm-configure-datadir (expand-file-name vm-configure-datadir)) (expand-file-name "pixmaps" vm-dir) (expand-file-name "../pixmaps" vm-dir) (let ((d (and vm-xemacs-p (xemacs-locate-data-directory "vm")))) (and d (expand-file-name "pixmaps" d))))) image-dir) (while image-dirs (setq image-dir (car image-dirs)) (if (and image-dir (file-exists-p (expand-file-name "visit-up.xpm" image-dir))) (setq image-dirs nil) (setq image-dirs (cdr image-dirs)))) image-dir)) (defcustom vm-image-directory nil "*The directory where VM finds the pixmaps for mime objects." :group 'vm-misc :type '(choice directory (const :tag "Automatic" nil))) (defun vm-image-directory () "Return the directory where the images for mime objects are." (or vm-image-directory (expand-file-name "mime" (vm-pixmap-directory)))) (defcustom vm-use-toolbar '(getmail next previous delete/undelete autofile file reply followup forward compose print visit quit help) "*Non-nil value causes VM to provide a toolbar interface. Value should be a list of symbols and integers that will determine which toolbar buttons will appear and in what order. If nil appears in the list, it should appear exactly once. All buttons after nil in the list will be displayed flushright in top/bottom toolbars and flushbottom in left/right toolbars. If a positive integer N appears in the list, a blank space will appear in the toolbar with a width of N pixels for top/bottom toolbars, and a height of N for left/right toolbars. See also `vm-toolbar-orientation' to control where the toolbar is placed." :group 'vm-toolbar :type '(repeat (choice integer (const autofile) (const compose) (const delete/undelete) (const file) (const getmail) (const help) (const mime) (const next) (const previous) (const print) (const quit) (const reply) (const followup) (const forward) (const visit) (const nil)))) (defcustom vm-toolbar-orientation 'top "*Value is a symbol that specifies where the VM toolbar is located. Legal values are `left', `right' `top' and `bottom'. Any other value will be interpreted as `top'. This variable only has meaning under XEmacs. Under FSF Emacs 21 the toolbar is always at the top of the frame." :group 'vm-toolbar :type '(choice (const left) (const right) (const top) (const bottom))) (defcustom vm-toolbar-pixmap-directory nil "*The directory VM should find its toolbar pixmaps." :group 'vm-toolbar :type '(choice directory (const :tag "Automatic" nil))) (defvar vm-gtk-emacs-p (or (featurep 'gtk) (string-match "'--with-gtk'" system-configuration-options) (and (boundp 'device-type) (eq (device-type) 'gtk))) "True when running in a GTK enabled Emacs.") (defun vm-toolbar-pixmap-directory () "Return the directory where the toolbar pixmaps are." (or vm-toolbar-pixmap-directory (if vm-gtk-emacs-p (concat (vm-pixmap-directory) "/gtk") (vm-pixmap-directory)))) (defcustom vm-toolbar nil "*Non-nil value should be a list of toolbar button descriptors. See the documentation for the variable default-toolbar for a definition of what a toolbar button descriptor is. If `vm-toolbar' is set non-nil VM will use its value as a toolbar instantiator instead of the usual behavior of building a button list based on the value of `vm-use-toolbar'. `vm-use-toolbar' still must be set non-nil for a toolbar to appear, however. Consider this variable experimental; it may not be supported forever." :group 'vm-toolbar :type 'sexp) (defcustom vm-use-menus (nconc (list 'folder 'motion 'send 'mark 'label 'sort 'virtual) (list 'undo) (list 'dispose) (list 'emacs) (list nil 'help)) "*Non-nil value causes VM to provide a menu interface. A value that is a list causes VM to install its own menubar. A value of 1 causes VM to install a \"VM\" item in the Emacs menubar. If the value of `vm-use-menus' is a list, it should be a list of symbols. The symbols and the order in which they are listed determine which menus will be in the menubar and how they are ordered. Valid symbol values are: dispose emacs folder help label mark motion send sort undo virtual nil If nil appears in the list, it should appear exactly once. All menus after nil in the list will be displayed flushright in menubar. This variable only has meaning in Emacs environments where menus are provided, which usually means Emacs has to be running under a window system." :group 'vm-toolbar :type '(choice (const 1) (repeat (choice (const dispose) (const emacs) (const folder) (const help) (const label) (const mark) (const motion) (const send) (const sort) (const undo) (const virtual) (const nil))))) (defcustom vm-use-menubar-buttons t "*Non-nil value means that VM should use buttons on menubars, such as [Emacs] and [VM], in environments that support such buttons." :group 'vm-toolbar :type 'boolean) (defcustom vm-popup-menu-on-mouse-3 t "*Non-nil value means VM should provide context-sensitive menus on mouse-3. A nil value means VM should not change the binding of mouse-3." :group 'vm-toolbar :type 'boolean) (defcustom vm-warp-mouse-to-new-frame nil "*Non-nil value causes VM to move the mouse cursor into newly created frames. This is useful to give the new frame the focus under some window managers that randomly place newly created frames. Nil means don't move the mouse cursor." :group 'vm-frames :type 'boolean) (defcustom vm-url-retrieval-methods '(lynx wget fetch curl w3m) "*Non-nil value specifies how VM is permitted to retrieve URLs. VM needs to do this when supporting the message/external-body MIME type, which provides a reference to an object instead of the object itself. The specification should be a list of symbols with the following meanings lynx - means VM should try to use the lynx program. wget - means VM should try to use the wget program. w3m - means VM should try to use the w3m program. fetch - means VM should try to use the fetch program. curl - means VM should try to use the curl program. The list can contain all these values and VM will try them all, but not in any particular order, except that the url-w3 method will likely be tried last since it is likely to be the slowest retrieval method. If `vm-url-retrieval-methods' value is nil, VM will not try to use any URL retrieval methods." :group 'vm-url :type '(set (const lynx) (const wget) (const w3m) (const fetch) (const curl) (const url-w3))) (defcustom vm-url-browser 'browse-url "*The default web browser to be used for following URLs (hyperlinks) in messages. Clicking mouse-2 on a URL will send it to the default browser. Moving point to a character within the URL and pressing RETURN will also send the URL to the default browser. If the value of `vm-url-browser' is a string, it should specify name of an external browser to run. The URL will be passed to the program as its first argument after the program switches specified by `vm-url-browser-switches', if any. If the value of `vm-url-browser' is a symbol, it should specify a Lisp function to call. The URL will be passed to the function as its first and only argument. The Emacs `browse-url' function is an excellent choice. It is the default value of the variable. VM also defines a number of browser functions of the form `vm-mouse-send-url-to-xxx', where xxx is the name of a browser. The `xxx' can be netscape, mmosaic, mosaic, opera, mozilla, konqueror, firefox, window-system or clipboard. If it is window-system then the URL is passed to the window system's \"copy\" mechanism so that it can be pasted somwhere else. If it is clipboard, the URL is sent to the X clipboard. A nil value means VM should not enable URL passing to browsers." :group 'vm-url :type '(choice (const :tag "Disable URL parsing" nil) (function :tag "Browser function") (string :tag "External browser"))) (defcustom vm-url-browser-switches nil "*List of command line flags passed to the command named by `vm-url-browser'. VM uses `vm-url-browser' to display URLs in messages when you click on them." :group 'vm-url :type '(repeat string)) (defface vm-highlight-url '((t (:inherit link))) "Default face used to highlight URLs." :group 'vm-faces) ;; (copy-face 'bold-italic 'vm-highlight-url) (defcustom vm-highlight-url-face 'vm-highlight-url "*Non-nil value should be a face to use display URLs found in messages. Nil means don't highlight URLs." :group 'vm-faces :type 'symbol) (defcustom vm-url-search-limit 12000 "*Non-nil numeric value tells VM how hard to search for URLs. The number specifies the maximum message size in characters that VM will search for URLs. For message larger than this value, VM will search from the beginning of the message to a point `vm-url-search-limit' / 2 characters into the message. Then VM will search from a point `vm-url-search-limit' / 2 characters from the end of the message to the end of message." :group 'vm-url :type '(choice (const nil) integer)) (defcustom vm-display-xfaces nil "*Non-nil means display images as specified in X-Face headers. This requires XEmacs with native xface support compiled in." :group 'vm-presentation :type 'boolean) (defcustom vm-startup-with-summary t "*Value tells VM whether to generate a summary when a folder is visited. Nil means don't automatically generate a summary. A value of t means always generate a summary. A positive numeric value N means only generate a summary if there are N or more messages. A negative numeric value -N means only generate a summary if there are N or less messages." :group 'vm-summary :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (integer :tag "Number of messages") )) (defcustom vm-follow-summary-cursor t "*Non-nil value causes VM to select the message under the cursor in the summary window before executing commands that operate on the current message. This occurs only when the summary buffer window is the selected window." :group 'vm-summary :type 'boolean) (defcustom vm-jump-to-new-messages t "*Non-nil value causes VM to jump to the first new message whenever such messages arrive in a folder or the first time a folder is visited. See also `vm-jump-to-unread-messages'." :group 'vm-summary :type 'boolean) (defcustom vm-jump-to-unread-messages t "*Non-nil value causes VM to jump to the first unread message whenever such messages arrive in a folder or the first time a folder is visited. New messages are considered unread in this context so new messages will be jumped to as well. The value of `vm-jump-to-new-messages' takes precedence over the setting of this variable. So if there are unread messages and new messages VM will jump to the first new message, even if an unread message appears before it in the folder, provided `vm-jump-to-new-messages' is non-nil." :group 'vm-summary :type 'boolean) (defcustom vm-skip-deleted-messages t "*Non-nil value causes VM's `n' and 'p' commands to skip over deleted messages. A value of t causes deleted messages to always be skipped. A value that is not nil and not t causes deleted messages to be skipped only if there are other messages that are not flagged for deletion in the desired direction of motion." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "Skip if some undeleted" skip-if-some-undeleted))) (defcustom vm-skip-read-messages nil "*Non-nil value causes VM's `n' and `p' commands to skip over messages that have already been read, in favor of new or unread messages. A value of t causes read messages to always be skipped. A value that is not nil and not t causes read messages to be skipped only if there are unread messages in the desired direction of motion." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "Skip if some unread" skip-if-some-unread))) (defcustom vm-move-after-deleting nil "*Non-nil value causes VM's `d' command to automatically invoke `vm-next-message' or `vm-previous-message' after deleting, to move past the deleted messages. A value of t means motion should honor the value of `vm-circular-folders'. A value that is not t and not nil means that motion should be done as if `vm-circular-folders' is set to nil." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "Skip if some undeleted" skip-if-some-undeleted))) (defcustom vm-move-after-undeleting nil "*Non-nil value causes VM's `u' command to automatically invoke `vm-next-message' or `vm-previous-message' after undeleting, to move past the undeleted messages. A value of t means motion should honor the value of `vm-circular-folders'. A value that is not t and not nil means that motion should be done as if `vm-circular-folders' is set to nil." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "Skip if some undeleted" skip-if-some-undeleted))) (defcustom vm-move-after-killing nil "*Non-nil value causes VM's `k' command to automatically invoke `vm-next-message' or `vm-previous-message' after killing messages, to try to move past the deleted messages. A value of t means motion should honor the value of `vm-circular-folders'. A value that is not t and not nil means that motion should be done as if `vm-circular-folders' is set to nil." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "Skip if some undeleted" skip-if-some-undeleted))) (defcustom vm-delete-after-saving nil "*Non-nil value causes VM automatically to mark messages for deletion after successfully saving them to a folder." :group 'vm-dispose :type 'boolean) (defcustom vm-delete-after-archiving nil "*Non-nil value causes VM automatically to mark messages for deletion after successfully auto-archiving them with the `vm-auto-archive-messages' command." :group 'vm-dispose :type 'boolean) (defcustom vm-delete-after-bursting nil "*Non-nil value causes VM automatically to mark a message for deletion after it has been successfully burst by the `vm-burst-digest' command." :group 'vm-dispose :type 'boolean) (defcustom vm-circular-folders nil "*Value determines whether VM folders will be considered circular by various commands. `Circular' means VM will wrap from the end of the folder to the start and vice versa when moving the message pointer, or deleting, undeleting or saving messages before or after the current message. A value of t causes all VM commands to consider folders circular. A value of nil causes all of VM commands to signal an error if the start or end of the folder would have to be passed to complete the command. For movement commands, this occurs after the message pointer has been moved as far as possible in the specified direction. For other commands, the error occurs before any part of the command has been executed, i.e. no deletions, saves, etc. will be done unless they can be done in their entirety. A value that is not nil and not t causes only VM's movement commands to consider folders circular. Saves, deletes and undelete commands will behave the same as if the value is nil." :group 'vm-summary :type '(choice (const :tag "No" nil) (const :tag "Yes" t) (const :tag "For movement commands only" for-movement-only))) (defcustom vm-search-using-regexps nil "*Non-nil value causes VM's search command to interpret user input as a regular expression instead of as a literal string." :group 'vm-misc :type 'boolean) (defcustom vm-move-messages-physically nil "*Non-nil value causes VM's commands that change the message order of a folder to always move the physical messages involved and not just change the presentation order. Nil means that commands just change the order in which VM displays messages and leave the folder itself undisturbed." :group 'vm-folders :type 'boolean) (defcustom vm-edit-message-mode 'text-mode "*Major mode to use when editing messages in VM." :group 'vm-dispose :type 'function) (defvar lpr-command) (defcustom vm-print-command (if (boundp 'lpr-command) lpr-command "lpr") "*Command VM uses to print messages." :group 'vm-print :type '(choice (string :tag "Command") (const nil))) (defvar lpr-switches) (defcustom vm-print-command-switches (if (boundp 'lpr-switches) lpr-switches nil) "*List of command line flags passed to the command named by `vm-print-command'. VM uses `vm-print-command' to print messages." :group 'vm-print :type '(repeat (const nil) (string :tag "Switch"))) (defcustom vm-berkeley-mail-compatibility (memq system-type '(berkeley-unix netbsd)) "*Non-nil means to read and write BSD Mail(1) style Status: headers. This makes sense if you plan to use VM to read mail archives created by Mail." :group 'vm-folders :type 'boolean) (defcustom vm-strip-reply-headers nil "*Non-nil value causes VM to strip away all comments and extraneous text from the headers generated in reply messages. If you use the \"fakemail\" program as distributed with Emacs, you probably want to set this variable to t, because as of Emacs v18.52 \"fakemail\" could not handle unstripped headers." :group 'vm-compose :type 'boolean) (defcustom vm-select-new-message-hook nil "*List of hook functions called every time a message with the 'new' attribute is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max)." :group 'vm-hooks :type 'hook) (defcustom vm-select-unread-message-hook nil "*List of hook functions called every time a message with the 'unread' attribute is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max)." :group 'vm-hooks :type 'hook) (defcustom vm-select-message-hook nil "*List of hook functions called every time a message is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max)." :group 'vm-hooks :type 'hook) (defcustom vm-showing-message-hook nil "*List of hook functions called every time a message is showed. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max)." :group 'vm-hooks :type 'hook) (defcustom vm-arrived-message-hook nil "*List of hook functions called once for each message gathered from the system mail spool, or from another folder with `vm-get-new-mail', or from a digest with `vm-burst-digest'. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max)." :group 'vm-hooks :type 'hook) (defcustom vm-spooled-mail-waiting-hook nil "*List of functions called when VM first notices mail is spooled for a folder. The folder buffer will be current when the hooks are run." :group 'vm-hooks :type 'hook) (defcustom vm-arrived-messages-hook nil "*List of hook functions called after VM has gathered a group of messages from the system mail spool, or from another folder with `vm-get-new-mail', or from a digest with `vm-burst-digest'. When the hooks are run, the new messages will have already been added to the message list but may not yet appear in the summary. Also, the current buffer will be the folder containing the messages." :group 'vm-hooks :type 'hook) (defcustom vm-reply-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created for a reply. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-forward-message-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created to forward a message. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-resend-bounced-message-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created to resend a bounced message. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-resend-message-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created to resend a message. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-send-digest-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created to send a digest. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-mail-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created to send a non specialized message, i.e. a message that is not a reply, forward, digest, etc. VM runs this hook and then runs `vm-mail-mode-hook' before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-summary-update-hook nil "*List of hook functions called just after VM updates an existing entry a folder summary." :group 'vm-hooks :type 'hook) (defcustom vm-summary-redo-hook nil "*List of hook functions called just after VM adds or deletes entries from a folder summary." :group 'vm-hooks :type 'hook) (defgroup vm-summary-faces nil "VM additional faces for the summary buffer." :group 'vm-faces) (defcustom vm-summary-faces-alist '( ;; Most important status info ((deleted) vm-summary-deleted) ((new) vm-summary-new) ((marked) vm-summary-marked) ((or (header "Priority: urgent") (header "Importance: high") (header "X-Priority: 1") (flagged) (label "!") (label "\\flagged") (header "X-VM-postponed-data:")) vm-summary-high-priority) ((unread) vm-summary-unread) ;; less important status info ((replied) vm-summary-replied) ((or (filed) (written)) vm-summary-saved) ((or (forwarded) (redistributed)) vm-summary-forwarded) ((edited) vm-summary-edited) ;; ((outgoing) vm-summary-outgoing) ((any) vm-summary-default)) "List of condition-face pairs for deciding the faces for summary lines. Each element of the list is a pair, i.e., a two-element list. The first element is a virtual folder condition as described in the documentation of `vm-virtual-folder-alist'. The second element is a face name. The order matters. The first condition that matches the message will decide the face." :type '(repeat (cons (sexp) (face))) :group 'vm-summary-faces) ;;--------------------------------------------------------------------------- ;; Color coding ;; ;; Face light bgd dark bgd monochrome ;; ---- --------- -------- ---------- ;; ;; deleted grey50 grey70 dim ;; high-priority red ;; low-priority grey50 ;; marked purple magenta underlined ;; new blue cyan italic ;; unread navy magenta italic ;; saved green ;; replied grey30 ;; forwarded grey20 ;; outgoing grey30 ;; expanded ;; collapsed ;; -------------------------------------------------------------------------- (defface vm-summary-selected '( (((type x w32 mswindows mac) (class color) (background light)) (:background "grey85")) (((type x w32 mswindows mac) (class color) (background dark)) (:background "SlateBlue3")) (((class color) (background light)) (:background "grey80")) (((class color) (background dark)) (:background "Blue3")) (t (:weight bold))) "The face used in VM Summary buffers for the selected message." :group 'vm-summary-faces) (put 'vm-summary-selected-face 'face-alias 'vm-summary-selected) (make-obsolete 'vm-summary-selected-face 'vm-summary-selected "8.2.0") (defface vm-summary-marked '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "Purple")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "Magenta")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "Purple")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "Magenta")) (((class color) (background light)) ; (min-colors 8) (:foreground "Magenta" :weight bold)) (((class color) (background dark)) (:foreground "Magenta" :weight bold)) (t (:underline t))) "The face used in VM Summary buffers for marked messages." :group 'vm-summary-faces) (put 'vm-summary-marked-face 'face-alias 'vm-summary-marked) (make-obsolete 'vm-summary-marked-face 'vm-summary-marked "8.2.0") (if vm-xemacs-p (defface vm-summary-deleted '( (((class color) (background light)) (:foreground "grey50" :strikethru t)) (((class color) (background dark)) (:foreground "grey70" :strikethru t)) (((type tty) (class color) (background light)) (:foreground "yellow")) (((type tty) (class color) (background dark)) (:foreground "yellow")) (((class grayscale) (background light)) (:foreground "grey50" :strikethru t)) (((class grayscale) (background dark)) (:foreground "grey70" :strikethru t)) (((class mono)) (:strikethru t)) (((type tty)) (:dim t)) (t ())) "The face used in VM Summary buffers for deleted messages." :group 'vm-summary-faces) (defface vm-summary-deleted '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "grey50" :strike-through "grey80")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "grey70" :strike-through "grey50")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "grey50" :strike-through "grey70")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "grey70" :strike-trhough "grey50")) (((class color) (background light)) ; (min-colors 8) (:foreground "yellow")) (((class color) (background dark)) (:foreground "yellow")) (((class grayscale) (background light)) (:foreground "grey50" :strike-through "grey70")) (((class grayscale) (background dark)) (:foreground "grey70" :strike-trhough "grey50")) (((class mono)) (:strike-through t)) (((type tty)) (:dim t)) (t ())) "The face used in VM Summary buffers for deleted messages." :group 'vm-summary-faces)) (put 'vm-summary-deleted-face 'face-alias 'vm-summary-deleted) (make-obsolete 'vm-summary-deleted-face 'vm-summary-deleted "8.2.0") (defface vm-summary-new '( (((class color) (background light)) (:foreground "blue")) (((class color) (background dark)) (:foreground "cyan")) (((class grayscale) (background light)) (:foreground "DimGray" :slant italic)) (((class grayscale) (background dark)) (:foreground "LightGray" :slant italic)) (t (:slant italic))) "The face used in VM Summary buffers for new messages." :group 'vm-summary-faces) (put 'vm-summary-new-face 'face-alias 'vm-summary-new) (make-obsolete 'vm-summary-new-face 'vm-summary-new "8.2.0") (defface vm-summary-unread '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "blue3")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "LightSkyBlue")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "blue")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "magenta")) (((class color) (background light)) ; (min-colors 8) (:foreground "blue")) (((class color) (background dark)) (:foreground "magenta")) (((class grayscale) (background light)) (:foreground "DimGray" :slant italic)) (((class grayscale) (background dark)) (:foreground "LightGray" :slant italic)) (t (:slant italic))) "The face used in VM Summary buffers for unread messages." :group 'vm-summary-faces) (put 'vm-summary-unread-face 'face-alias 'vm-summary-unread) (make-obsolete 'vm-summary-unread-face 'vm-summary-unread "8.2.0") (defface vm-summary-saved '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "green4")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "PaleGreen")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "green")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "green")) (((class color)) (:foreground "green"))) "The face used in VM Summary buffers for saved messages." :group 'vm-summary-faces) (put 'vm-summary-filed-face 'face-alias 'vm-summary-saved) (make-obsolete 'vm-summary-filed 'vm-summary-saved "8.2.0") (put 'vm-summary-written-face 'face-alias 'vm-summary-saved) (make-obsolete 'vm-summary-written 'vm-summary-saved "8.2.0") (defface vm-summary-replied '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "MediumOrchid4")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "plum1")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "Orchid")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "purple")) (((class color)) (:foreground "magenta")) (t ())) "The face used in VM Summary buffers for replied messages." :group 'vm-summary-faces) (put 'vm-summary-replied-face 'face-alias 'vm-summary-replied) (make-obsolete 'vm-summary-replied-face 'vm-summary-replied "8.2.0") (defface vm-summary-forwarded '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "MediumOrchid3")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "Thistle1")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "Orchid")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "Yellow")) (((class color)) (:foreground "Yellow")) (((class grayscale) (background light)) (:foreground "LightGray")) (((class grayscale) (background dark)) (:foreground "DimGray")) (t ())) "The face used in VM Summary buffers for forwarded messages." :group 'vm-summary-faces) (put 'vm-summary-forwarded-face 'face-alias 'vm-summary-forwarded) (make-obsolete 'vm-summary-forwarded-face 'vm-summary-forwarded "8.2.0") (put 'vm-summary-redistributed-face 'face-alias 'vm-summary-forwarded) (make-obsolete 'vm-summary-redistributed-face 'vm-summary-forwarded "8.2.0") (defface vm-summary-edited '((t ())) "The face used in VM Summary buffers for edited messages." :group 'vm-summary-faces) (put 'vm-summary-edited-face 'face-alias 'vm-summary-edited) (make-obsolete 'vm-summary-edited-face 'vm-summary-edited "8.2.0") (defface vm-summary-outgoing '( (((class color) (background light)) (:foreground "grey40")) (((class color) (background dark)) (:foreground "grey80")) (t ())) "The face used in VM Summary buffers for outgoing messages." :group 'vm-summary-faces) (put 'vm-summary-outgoing-face 'face-alias 'vm-summary-outgoing) (make-obsolete 'vm-summary-outgoing-face 'vm-summary-outgoing "8.2.0") (defface vm-summary-expanded '((t ())) "The face used in VM Summary buffers for the root messages of expanded threads." :group 'vm-summary-faces) (put 'vm-summary-expanded-face 'face-alias 'vm-summary-expanded) (make-obsolete 'vm-summary-expanded-face 'vm-summary-expanded "8.2.0") (defface vm-summary-collapsed '((t (:slant oblique))) "The face used in VM Summary buffers for the root messages of collapsed threads." :group 'vm-summary-faces) (put 'vm-summary-collapsed-face 'face-alias 'vm-summary-collapsed) (make-obsolete 'vm-summary-collapsed-face 'vm-summary-collapsed "8.2.0") (defface vm-summary-high-priority '( (((type x w32 mswindows mac) (class color) (background light)) (:foreground "Red1")) (((type x w32 mswindows mac) (class color) (background dark)) (:foreground "LightSalmon")) ;; (((class color) (min-colors 16) (background light)) ;; (:foreground "Red")) ;; (((class color) (min-colors 16) (background dark)) ;; (:foreground "Pink")) (((class color)) ; (min-colors 8) (:foreground "red")) (t (:inverse-video t :weight bold))) "The face used in VM Summary buffers for high-priority messages." :group 'vm-summary-faces) (put 'vm-summary-high-priority-face 'face-alias 'vm-summary-high-priority) (make-obsolete 'vm-summary-high-priority-face 'vm-summary-high-priority "8.2.0") (defface vm-summary-low-priority '( (((class color) (background light)) (:foreground "grey50")) (((class color) (background dark)) (:foreground "grey70")) (((type tty) (class color) (background light)) (:foreground "yellow")) (((type tty) (class color) (background dark)) (:foreground "yellow")) (((class grayscale) (background light)) (:foreground "grey50")) (((class grayscale) (background dark)) (:foreground "grey70")) (((class mono)) (:strikethru t)) (((type tty)) (:dim t)) (t ())) "The face used in VM Summary buffers for low-priority messages." :group 'vm-summary-faces) (defface vm-summary-default '((t ())) "The default face used in VM Summary buffers." :group 'vm-summary-faces) (put 'vm-summary-default-face 'face-alias 'vm-summary-default) (make-obsolete 'vm-summary-default-face 'vm-summary-default "8.2.0") (defcustom vm-visit-folder-hook nil "*List of hook functions called just after VM visits a folder. It doesn't matter if the folder buffer already exists, this hook is run each time `vm' or `vm-visit-folder' is called interactively. It is NOT run after `vm-mode' is called." :group 'vm-hooks :type 'hook) (defcustom vm-retrieved-spooled-mail-hook nil "*List of hook functions called just after VM has retrieved a group of messages from your system mailbox(es). When these hooks are run, the messages have been added to the folder buffer but not the message list or summary. When the hooks are run, the current buffer will be the folder where the messages were incorporated." :group 'vm-hooks :type 'hook) (defcustom vm-edit-message-hook nil "*List of hook functions to be run just before a message is edited. This is the last thing `vm-edit-message' does before leaving the user in the edit buffer." :group 'vm-hooks :type 'hook) (defcustom vm-mail-mode-hook nil "*List of hook functions to be run after a Mail mode composition buffer has been created. This is the last thing VM does before leaving the user in the Mail mode buffer." :group 'vm-hooks :type 'hook) (defcustom vm-mode-hook nil "*List of hook functions to run when a buffer enters `vm-mode'. These hook functions should generally be used to set key bindings and local variables." :group 'vm-hooks :type 'hook) (defcustom vm-mode-hooks nil "*Old name for `vm-mode-hook'. Supported for backward compatibility. You should use the new name." :group 'vm-hooks :type 'hook) (defcustom vm-summary-mode-hook nil "*List of hook functions to run when a VM summary buffer is created. The current buffer will be that buffer when the hooks are run." :group 'vm-hooks :type 'hook) (defcustom vm-summary-mode-hooks nil "*Old name for `vm-summary-mode-hook'. Supported for backward compatibility. You should use the new name." :group 'vm-hooks :type 'hook) (defcustom vm-folders-summary-mode-hook nil "*List of hook functions to run when a VM folders summary buffer is created. The current buffer will be that buffer when the hooks are run." :group 'vm-hooks :type 'hook) (defcustom vm-virtual-mode-hook nil "*List of hook functions to run when a VM virtual folder buffer is created. The current buffer will be that buffer when the hooks are run." :group 'vm-hooks :type 'hook) (defcustom vm-presentation-mode-hook nil "*List of hook functions to run when a VM presentation buffer is created. The current buffer will be the new presentation buffer when the hooks are run. Presentation buffers are used to display messages when some type of decoding must be done to the message to make it presentable. E.g. MIME decoding." :group 'vm-hooks :type 'hook) (defcustom vm-quit-hook nil "*List of hook functions to run when you quit VM. This applies to any VM quit command." :group 'vm-hooks :type 'hook) (defcustom vm-summary-pointer-update-hook nil "*List of hook functions to run when the VM summary pointer is updated. When the hooks are run, the current buffer will be the summary buffer." :group 'vm-hooks :type 'hook) (defcustom vm-display-buffer-hook nil "*List of hook functions that are run every time VM wants to display a buffer. When the hooks are run, the current buffer will be the buffer that VM wants to display. The hooks are expected to select a window and VM will display the buffer in that window. If you use display hooks, you should not use VM's builtin window configuration system as the result is likely to be confusing." :group 'vm-hooks :type 'hook) (defcustom vm-undisplay-buffer-hook nil "*List of hook functions that are run every time VM wants to remove a buffer from the display. When the hooks are run, the current buffer will be the buffer that VM wants to disappear. The hooks are expected to do the work of removing the buffer from the display. The hook functions should not kill the buffer. If you use undisplay hooks, you should not use VM's builtin window configuration system as the result is likely to be confusing." :group 'vm-hooks :type 'hook) (defcustom vm-iconify-frame-hook nil "*List of hook functions that are run whenever VM iconifies a frame." :group 'vm-hooks :type 'hook) (defcustom vm-menu-setup-hook nil "*List of hook functions that are run just after all menus are initialized." :group 'vm-hooks :type 'hook) (defcustom vm-mime-display-function nil "*If non-nil, this should name a function to be called inside `vm-decode-mime-message' to do the MIME display the current message. The function is called with no arguments, and at the time of the call the current buffer will be the `presentation' buffer for the folder, which is a temporary buffer that VM uses for the display of MIME messages. A copy of the current message will be in the presentation buffer at that time. The normal work that `vm-decode-mime-message' would do is not done, because this function is expected to subsume all of it." :group 'vm-mime :type '(choice (const :tag "None" nil) 'function)) (defcustom vm-mime-deleted-object-label "[Deleted %f (%t)]\n" "*The label that will be inserted instead of the original mime object. See `vm-mime-compile-format-1' for valid format specifiers." :group 'vm-mime :type 'string) (defvar vm-mime-show-alternatives nil "*This variable is deprecated. You can set `vm-mime-alternative-show-method' to 'all to get the same effect as setting this one to t.") (make-obsolete-variable 'vm-mime-show-alternatives 'vm-mime-alternative-show-method "8.2.0") (defcustom vm-emit-messages-for-mime-decoding t "*Flag to allow minibuffer messages about the progress of MIME decoding of messages. Only nontrivial decodings are normally reported. So there is normally no need to change this from the default." :group 'vm-mime :type 'boolean) (defcustom vm-imap-session-preauth-hook nil "*List of hook functions to call to generate an preauthenticated IMAP session process. This hook is only run if the authentication method for the IMAP mailbox is ``preauth''. Each hook is called with five arguments: HOST, PORT, MAILBOX, USER, PASSWORD. (See the documentation for `vm-spool-files' to find out about these arguments.) It is the responsibility of the hook function to create an Emacs process whose input/output streams are connected to an authenticated IMAP session, and to return this process. If the hook cannot accomplish this, it should return nil. If all the hooks return nil, VM will signal an error. At the time the hook is run, the current buffer will be the buffer any created process should be associated with. (The BUFFER argument to start-process or open-network-stream should be (current-bfufer).)" :group 'vm-hooks :type 'hook) (defcustom vm-mail-send-hook nil "*List of hook functions to call just before sending a message. The hooks are run after confirming that you want to send the message (see `vm-confirm-mail-send') but before MIME encoding and FCC processing." :group 'vm-hooks :type 'hook) ;; The following settings are disabled because they are defined in ;; mail-mode/sendmail.el. ;; (defvar mail-yank-hooks nil ;; "Hooks called after a message is yanked into a mail composition buffer. ;; (This hook is deprecated, you should use mail-citation-hook instead.) ;; The value of this hook is a list of functions to be run. ;; Each hook function can find the newly yanked message between point and mark. ;; Each hook function should return with point and mark around the yanked message. ;; See the documentation for `vm-yank-message' to see when VM will run ;; these hooks.") ;; (defcustom mail-citation-hook nil ;; "*Hook for modifying a citation just inserted in the mail buffer. ;; Each hook function can find the citation between (point) and (mark t). ;; And each hook function should leave point and mark around the citation ;; text as modified. ;; If this hook is entirely empty (nil), a default action is taken ;; instead of no action." ;; :group 'vm ;; :type 'hook) ;; (defcustom mail-default-headers nil ;; "*A string containing header lines, to be inserted in outgoing messages. ;; It is inserted before you edit the message, ;; so you can edit or delete these lines." ;; :group 'vm ;; :type '(choice (const nil) string)) ;; (defcustom mail-signature nil ;; "*Text inserted at end of mail buffer when a message is initialized. ;; If t, it means to insert the contents of the file `~/.signature'." ;; :group 'vm ;; :type '(choice (const nil) (const t) string)) (defconst vm-rename-current-buffer-function nil "*Non-nil value should be a function to call to rename a buffer. Value should be something that can be passed to `funcall'. If this variable is non-nil, VM will use this function instead of its own buffer renaming code. The buffer to be renamed will be the current buffer when the function is called.") (defvar mode-popup-menu nil "The mode-specific popup menu. Automatically buffer local. By default, when you press mouse-3 in VM, this menu is popped up.") (make-variable-buffer-local 'mode-popup-menu) (defcustom vm-movemail-program "movemail" "*Name of program to use to move mail from the system spool to another location. Normally this should be the movemail program distributed with Emacs. If you use another program, it must accept as its last two arguments the spool file (or maildrop) from which mail is retrieved, and the local file where the retrieved mail should be stored." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-movemail-program-switches nil "*List of command line flags to pass to the movemail program named by `vm-movemail-program'." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-netscape-program "netscape" "*Name of program to use to run Netscape. `vm-mouse-send-url-to-netscape' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-netscape-program-switches nil "*List of command line switches to pass to Netscape." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-opera-program "opera" "*Name of program to use to run Opera. `vm-mouse-send-url-to-opera' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-opera-program-switches nil "*List of command line switches to pass to Opera." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mozilla-program nil "*Name of program to use to run Mozilla. `vm-mouse-send-url-to-mozilla' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mozilla-program-switches nil "*List of command line switches to pass to Mozilla." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mosaic-program nil "*Name of program to use to run Mosaic. `vm-mouse-send-url-to-mosaic' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mosaic-program-switches nil "*List of command line switches to pass to Mosaic." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-mmosaic-program nil "*Name of program to use to run mMosaic. `vm-mouse-send-url-to-mosaic' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-mmosaic-program-switches nil "*List of command line switches to pass to mMosaic." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-konqueror-program "konqueror" "*Name of program to use to run Konqueror. `vm-mouse-send-url-to-konqueror' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-konqueror-program-switches nil "*List of command line switches to pass to Konqueror." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-konqueror-client-program "kfmclient" "*Name of program to use to issue requests to Konqueror. `vm-mouse-send-url-to-konqueror' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-konqueror-client-program-switches nil "*List of command line switches to pass to Konqueror client." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-firefox-program "firefox" "*Name of program to use to run Mozilla Firefox. `vm-mouse-send-url-to-firefox' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-firefox-program-switches nil "*List of command line switches to pass to Mozilla Firefox." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-firefox-client-program "firefox" "*Name of program to use to issue requests to Mozilla Firefox. `vm-mouse-send-url-to-firefox' uses this." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-firefox-client-program-switches '("-remote") "*List of command line switches to pass to Mozilla Firefox client." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-wget-program "wget" "*Name of program to use to run wget. This is used to retrieve URLs." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-w3m-program "w3m" "*Name of program to use to run w3m. This is used to retrieve URLs." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-fetch-program "fetch" "*Name of program to use to run fetch. This is used to retrieve URLs. Fetch is part of the standard FreeBSD installation." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-curl-program "curl" "*Name of program to use to run curl. This is used to retrieve URLs." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-lynx-program "lynx" "*Name of program to use to run lynx. This is used to retrieve URLs." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-grep-program "grep" "*Name of program to use to run grep. This is used to count message separators in folders. Set this to nil and VM will not use it." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-stunnel-program "stunnel" "*Name of program to use to run stunnel. This is used to make SSL connections to POP and IMAP servers that support SSL. If this is set to nil, VM will attempt to use the built-in SSL functionality of Emacs. Use this setting only if you know that your version of Emacs has SSL capability, or any attempt to contact the server will likely hang. If you do use an stunnel program, then see also the related variables `vm-stunnel-program-switches' and `vm-stunnel-program-additional-configuration-file'." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-stunnel-program-switches nil "*List of command line switches to pass to stunnel. Leave this set to nil unless you understand how VM uses stunnel and know that you need to change something to get stunnel working. This variable is ignored if you're running stunnel version 4 or later versions, since those versions of stunnel are configurable only with a configuration file." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-stunnel-program-additional-configuration-file nil "*Name of a configuration file to append to the config file VM creates when using stunnel version 4 or later. Leave this set to nil unless you understand how VM uses stunnel and know that you need to change something to get stunnel working. For stunnel version 4 and beyond stunnel relies on a configuration file to tell it what to do. VM builts the necessary configuration file for each instance of stunnel that it runs. If you have extra configuration options you want stunnel to use, put them in a file and set vm-stunnel-program-additional-configuration-file to the name of that file. This variable is ignored if you're running stunnel versions prior to version 4 as VM uses command line argument to control stunnel in those cases." :group 'vm-helpers :type '(choice (const :tag "None" nil) (file :must-match t))) (defcustom vm-stunnel-random-data-method 'generate "*Specifies what VM should do about sending the PRNG. The stunnel program uses the OpenSSL library which requires a certain amount of random data to seed its pseudo-random number generator. VM can generate this data using Emacs' random number generator or it can rely on stunnel to find the data by itself somehow. Some systems have a /dev/urandom device that stunnel can use. Some system have a entropy gathering daemon that can be tapped for random data. If sufficient random data cannot be found, the OpenSSL library will refuse to work and stunnel will not be able to establish an SSL connection. Setting `vm-stunnel-random-data-method' to the symbol `generate' tells VM to generate the random data. A nil value tells VM to do nothing and let stunnel find the data if it can." :group 'vm-helpers :type '(choice (const "Leave it to stunnel" nil) (const generate))) (defcustom vm-ssh-program "ssh" "*Name of program to use to run SSH. This is used to build an SSH tunnel to remote POP and IMAP servers. Set this to nil and VM will not use it." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-ssh-program-switches nil "*List of command line switches to pass to SSH." :group 'vm-helpers :type '(choice (const :tag "None" nil) (repeat string))) (defcustom vm-ssh-remote-command "echo ready; sleep 15" "*Shell command to run to hold open the SSH connection. This command must generate one line of output and then sleep long enough for VM to open a port-forwarded connection. The default should work on UNIX systems." :group 'vm-helpers :type '(string :tag "Shell command")) (defcustom vm-uncompface-program (and vm-fsfemacs-p (fboundp 'image-type-available-p) (vm-locate-executable-file "uncompface")) "*Program used to convert X-Face data to Sun icon format. Or if the program version is new enough, it will be called with -X to produce XBM data. This program is needed to support he display of X-Faces under Emacs 21." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defcustom vm-icontopbm-program (and vm-fsfemacs-p (fboundp 'image-type-available-p) (vm-locate-executable-file "icontopbm")) "*Program to convert Sun icon data to a PBM file. This program is needed to support the display of X-Faces under Emacs 21 if the uncompface program can't convert X-Face image data to XBM data." :group 'vm-helpers :type '(choice (const :tag "None" nil) file)) (defvar vm-uncompface-accepts-dash-x (and vm-fsfemacs-p (fboundp 'image-type-available-p) (stringp vm-uncompface-program) (eq 0 (string-match "#define" (shell-command-to-string (format "%s -X" vm-uncompface-program))))) "Non-nil if the uncompface command accepts a -X argument. This is only used for FSF Emacs currently.") (defvar vm-stunnel-wants-configuration-file 'unknown "Non-nil if stunnel is controlled by a configuration file. An older stunnel version used command line arguments instead.") (defcustom vm-tale-is-an-idiot nil "*Non-nil value causes `vm-mail-send' to check multi-line recipient headers of outbound mail for lines that don't end with a comma. If such a line is found, an error is signaled and the mail is not sent." :group 'vm-compose :type 'boolean) (defcustom vm-dnd-protocol-alist '(("^file:///" . vm-dnd-attach-file) ("^file://" . dnd-open-file) ("^file:" . vm-dnd-attach-file)) "The functions to call when a drop in `mail-mode' is made. See `dnd-protocol-alist' for more information. When nil, behave as in other buffers." :group 'vm-compose :type '(choice (repeat (cons (regexp) (function))) (const :tag "Behave as in other buffers" nil))) (defun vm-octal (n) (let ((val 0) digit (expo 1)) (while (> n 0) (setq digit (% n 10)) (if (>= digit 8) (error "invalid octal digit: %d" digit)) (setq val (+ val (* digit expo)) n (/ n 10) expo (* expo 8))) val )) (defcustom vm-default-folder-permission-bits (vm-octal 600) "*Default UNIX permission bits for newly created folders." :group 'vm-folders :type 'integer) (defcustom vm-coding-system-priorities nil ;'(iso-8859-1 iso-8859-15 utf-8) "*List of coding systems for VM to use, for outgoing mail, in order of preference. If you find that your outgoing mail is being encoded in `iso-2022-jp' and you'd prefer something more widely used outside of Japan be used instead, you could load the `latin-unity' and `un-define' libraries under XEmacs 21.4, and initialize this list to something like `(iso-8859-1 iso-8859-15 utf-8)'. " :group 'vm-compose :type '(choice (const nil) (repeat :tag "Coding system" symbol))) (defcustom vm-mime-ucs-list '(utf-8 iso-2022-jp ctext escape-quoted) "*List of coding systems that can encode all characters known to emacs." :group 'vm-mime :type '(repeat symbol)) (defcustom vm-drop-buffer-name-chars "[^ a-zA-Z0-9.,_\"'+-]" "*Regexp used to replace chars in composition buffer names. If non-nil buffer names will be cleaned to avoid save problems. If t, 8bit chars are replaced by a \"_\", if a string it should be a regexp matching all chars to be replaced by a \"_\"." :group 'vm-compose :type '(choice (const :tag "Disabled" nil) (regexp :tag "Enabled" "[^ a-zA-Z0-9.,_\"'+-]") (regexp :tag "Custom regexp"))) (defconst vm-buffer-name-limit 80 "*The limit for a generated buffer name.") (defconst vm-maintainer-address "viewmail-bugs@nongnu.org" "Where to send VM bug reports.") (defvar vm-use-v7-key-bindings nil "*Retain all the optional key bindings of VM as per version 7.19.") (defun vm-v8-key-bindings () "Install optional key bindings for VM modes, as per versions 8.2.0 and up." (interactive) (define-key vm-mode-map "!" 'vm-toggle-flag-message) (define-key vm-mode-map "<" 'vm-promote-subthread) (define-key vm-mode-map ">" 'vm-demote-subthread) (define-key vm-mode-virtual-map "O" 'vm-virtual-omit-message) (define-key vm-mode-virtual-map "U" 'vm-virtual-update-folders) (define-key vm-mode-virtual-map "D" 'vm-virtual-auto-delete-message) ;; (define-key vm-mode-virtual-map "S" 'vm-virtual-save-message) ;; (define-key vm-mode-virtual-map "A" 'vm-virtual-auto-archive-messages) (define-key vm-mode-virtual-map "?" 'vm-virtual-check-selector-interactive) ) (defalias 'vm-current-key-bindings 'vm-v8-key-bindings) (defun vm-v7-key-bindings () "Install optional key bindings for VM modes, as per version 7.19. These key bindings are considered optional. They can be rebound by the users or bound to other functions in future versions of VM." (interactive) (define-key vm-mode-map "<" 'vm-beginning-of-message) ; infrequent (define-key vm-mode-map ">" 'vm-end-of-message) ; infrequent (define-key vm-mode-map "b" 'vm-scroll-backward) ; redundant, use (define-key vm-mode-map "e" 'vm-edit-message) ; infrequent and dangerous (define-key vm-mode-map "w" 'vm-save-message-sans-headers) ; infrequent (define-key vm-mode-map "a" 'vm-set-message-attributes) ; infrequent (define-key vm-mode-map "i" 'vm-iconify-frame) ; redundant, C-x C-z (define-key vm-mode-map "*" 'vm-burst-digest) ; specialized (define-key vm-mode-map "!" 'shell-command) ; Emacs has a key binding (define-key vm-mode-map "=" 'vm-summarize) ; redundant, use `h' (define-key vm-mode-map "L" 'vm-load-init-file) ; infrequent (define-key vm-mode-map "\M-l" 'vm-edit-init-file) ; infrequent (define-key vm-mode-map "%" 'vm-change-folder-type) ; infrequent (define-key vm-mode-map "\M-g" 'vm-goto-message) ; redundant, use ) (defalias 'vm-legacy-key-bindings 'vm-v7-key-bindings) (defvar vm-mode-map (let ((map (make-keymap))) (defvar vm-mode-label-map (make-sparse-keymap)) (defvar vm-mode-virtual-map (make-sparse-keymap)) (defvar vm-mode-mark-map (make-sparse-keymap)) (defvar vm-mode-window-map (make-sparse-keymap)) (defvar vm-mode-mark-map (make-sparse-keymap)) (defvar vm-mode-mark-map (make-sparse-keymap)) (defvar vm-mode-pipe-map (make-sparse-keymap)) ;; unneeded now that VM buffers all have buffer-read-only == t. ;; but no harm in suppressing. USR, 2011-04-27 (suppress-keymap map) (define-key map "h" 'vm-summarize) (define-key map "H" 'vm-folders-summarize) (define-key map "\M-n" 'vm-next-unread-message) (define-key map "\M-p" 'vm-previous-unread-message) (define-key map "n" 'vm-next-message) (define-key map "p" 'vm-previous-message) (define-key map "N" 'vm-next-message-no-skip) (define-key map "P" 'vm-previous-message-no-skip) (define-key map "\C-\M-n" 'vm-move-message-forward) (define-key map "\C-\M-p" 'vm-move-message-backward) (define-key map "\t" 'vm-goto-message-last-seen) (define-key map "\r" 'vm-goto-message) (define-key map "\M-g" 'vm-optional-key) (define-key map "^" 'vm-goto-parent-message) (define-key map "t" 'vm-expose-hidden-headers) (define-key map " " 'vm-scroll-forward) (define-key map "b" 'vm-optional-key) (define-key map "\C-?" 'vm-scroll-backward) (define-key map [delete] 'vm-scroll-backward) (define-key map [backspace] 'vm-scroll-backward) (define-key map "D" 'vm-decode-mime-message) (define-key map "d" 'vm-delete-message) (define-key map "\C-d" 'vm-delete-message-backward) (define-key map "u" 'vm-undelete-message) (define-key map "U" 'vm-mark-message-unread) (define-key map "." 'vm-mark-message-read) (define-key map "e" 'vm-optional-key) (define-key map "\C-c\C-e" 'vm-edit-message) (define-key map "a" 'vm-optional-key) (define-key map "j" 'vm-discard-cached-data) (define-key map "k" 'vm-kill-subject) (define-key map "f" 'vm-followup) (define-key map "F" 'vm-followup-include-text) (define-key map "r" 'vm-reply) (define-key map "R" 'vm-reply-include-text) (define-key map "\M-r" 'vm-resend-bounced-message) (define-key map "B" 'vm-resend-message) (define-key map "z" 'vm-forward-message) (define-key map "Z" 'vm-forward-message-plain) (define-key map "c" 'vm-continue-composing-message) (define-key map "@" 'vm-send-digest) (define-key map "*" 'vm-optional-key) (define-key map "m" 'vm-mail) (define-key map "g" 'vm-get-new-mail) (define-key map "G" 'vm-sort-messages) (define-key map "v" 'vm-visit-folder) (define-key map "s" 'vm-save-message) (define-key map "w" 'vm-optional-key) (define-key map "A" 'vm-auto-archive-messages) (define-key map "S" 'vm-save-folder) ;; these two key bindings are experimental (define-key map "o" 'vm-load-message) (define-key map "O" 'vm-unload-message) (define-key map "|" vm-mode-pipe-map) (define-key vm-mode-pipe-map "|" 'vm-pipe-message-to-command) (define-key vm-mode-pipe-map "d" 'vm-pipe-message-to-command-discard-output) (define-key vm-mode-pipe-map "s" 'vm-pipe-messages-to-command) (define-key vm-mode-pipe-map "n" 'vm-pipe-messages-to-command-discard-output) (define-key map "#" (make-sparse-keymap)) (define-key map "##" (make-sparse-keymap)) (define-key map "###" 'vm-expunge-folder) (cond ((fboundp 'set-keymap-prompt) (set-keymap-prompt (lookup-key map "#") "(Type # twice more to expunge)") (set-keymap-prompt (lookup-key map "##") "(Type # once more to expunge)"))) (define-key map "q" 'vm-quit) (define-key map "x" 'vm-quit-no-change) (define-key map "i" 'vm-optional-key) (define-key map "?" 'vm-help) (define-key map "\C-_" 'vm-undo) (define-key map [(control /)] 'vm-undo) (define-key map "\C-xu" 'vm-undo) (define-key map "!" 'vm-optional-key) (define-key map "[" 'vm-move-to-previous-button) (define-key map "]" 'vm-move-to-next-button) (define-key map "\M-s" 'vm-isearch-forward) (define-key map "=" 'vm-optional-key) (define-key map "L" 'vm-optional-key) (define-key map "\M-l" 'vm-optional-key) (define-key map "l" vm-mode-label-map) (define-key vm-mode-label-map "a" 'vm-add-message-labels) (define-key vm-mode-label-map "e" 'vm-add-existing-message-labels) (define-key vm-mode-label-map "d" 'vm-delete-message-labels) (define-key map "V" vm-mode-virtual-map) (define-key vm-mode-virtual-map "V" 'vm-visit-virtual-folder) (define-key vm-mode-virtual-map "C" 'vm-create-virtual-folder) (define-key vm-mode-virtual-map "T" 'vm-create-virtual-folder-of-threads) (define-key vm-mode-virtual-map "X" 'vm-apply-virtual-folder) (define-key vm-mode-virtual-map "A" 'vm-create-virtual-folder-same-author) (define-key vm-mode-virtual-map "S" 'vm-create-virtual-folder-same-subject) (define-key vm-mode-virtual-map "M" 'vm-toggle-virtual-mirror) (define-key vm-mode-virtual-map "a" 'vm-create-author-virtual-folder) (define-key vm-mode-virtual-map "r" 'vm-create-author-or-recipient-virtual-folder) (define-key vm-mode-virtual-map "d" 'vm-create-date-virtual-folder) (define-key vm-mode-virtual-map "l" 'vm-create-label-virtual-folder) (define-key vm-mode-virtual-map "s" 'vm-create-subject-virtual-folder) (define-key vm-mode-virtual-map "t" 'vm-create-text-virtual-folder) (define-key vm-mode-virtual-map "!" 'vm-create-flagged-virtual-folder) (define-key vm-mode-virtual-map "n" 'vm-create-new-virtual-folder) (define-key vm-mode-virtual-map "u" 'vm-create-unseen-virtual-folder) (define-key vm-mode-virtual-map "?" 'vm-virtual-help) (define-key map "M" vm-mode-mark-map) (define-key vm-mode-mark-map "N" 'vm-next-command-uses-marks) (define-key vm-mode-mark-map "n" 'vm-next-command-uses-marks) (define-key vm-mode-mark-map "M" 'vm-mark-message) (define-key vm-mode-mark-map "U" 'vm-unmark-message) (define-key vm-mode-mark-map "m" 'vm-mark-all-messages) (define-key vm-mode-mark-map "u" 'vm-clear-all-marks) (define-key vm-mode-mark-map "C" 'vm-mark-matching-messages) (define-key vm-mode-mark-map "c" 'vm-unmark-matching-messages) (define-key vm-mode-mark-map "T" 'vm-mark-thread-subtree) (define-key vm-mode-mark-map "t" 'vm-unmark-thread-subtree) (define-key vm-mode-mark-map "S" 'vm-mark-messages-same-subject) (define-key vm-mode-mark-map "s" 'vm-unmark-messages-same-subject) (define-key vm-mode-mark-map "A" 'vm-mark-messages-same-author) (define-key vm-mode-mark-map "a" 'vm-unmark-messages-same-author) (define-key vm-mode-mark-map "R" 'vm-mark-summary-region) (define-key vm-mode-mark-map "r" 'vm-unmark-summary-region) (define-key vm-mode-mark-map "V" 'vm-toggle-all-marks) (define-key vm-mode-mark-map "X" 'vm-mark-matching-messages-with-virtual-folder) (define-key vm-mode-mark-map "x" 'vm-unmark-matching-messages-with-virtual-folder) (define-key vm-mode-mark-map "?" 'vm-mark-help) (define-key map "W" vm-mode-window-map) (define-key vm-mode-window-map "W" 'vm-apply-window-configuration) (define-key vm-mode-window-map "S" 'vm-save-window-configuration) (define-key vm-mode-window-map "D" 'vm-delete-window-configuration) (define-key vm-mode-window-map "?" 'vm-window-help) (define-key map "\C-t" 'vm-toggle-threads-display) (define-key map "\C-x\C-s" 'vm-save-buffer) (define-key map "\C-x\C-w" 'vm-write-file) (define-key map "\C-x\C-q" 'vm-toggle-read-only) (define-key map "%" 'vm-optional-key) (define-key map "\M-C" 'vm-show-copying-restrictions) (define-key map "\M-W" 'vm-show-no-warranty) (define-key map "\C-c\C-s" 'vm-save-all-attachments) (define-key map "\C-c\C-d" 'vm-delete-all-attachments) (define-key map "T" 'vm-toggle-thread) (define-key map "E" 'vm-expand-all-threads) (define-key map "C" 'vm-collapse-all-threads) (define-key map "K" 'vm-kill-thread-subtree) ;; suppress-keymap provides these, but now that we don't use ;; suppress-keymap anymore... (define-key map "0" 'digit-argument) (define-key map "1" 'digit-argument) (define-key map "2" 'digit-argument) (define-key map "3" 'digit-argument) (define-key map "4" 'digit-argument) (define-key map "5" 'digit-argument) (define-key map "6" 'digit-argument) (define-key map "7" 'digit-argument) (define-key map "8" 'digit-argument) (define-key map "9" 'digit-argument) (define-key map "-" 'negative-argument) (cond ((fboundp 'set-keymap-name) (set-keymap-name map 'vm-mode-map) (set-keymap-name (lookup-key map "l") "VM mode message labels map") (set-keymap-name (lookup-key map "V") "VM mode virtual folders map") (set-keymap-name (lookup-key map "M") "VM mode message marks map") (set-keymap-name (lookup-key map "W") "VM mode window configuration map") (set-keymap-name (lookup-key map "|") "VM mode pipe-to-application map"))) map ) "Keymap for VM mode. See also the following subsidiary keymaps: `vm-mode-label-map' VM mode message labels map (`l') `vm-mode-virtual-map' VM mode virtual folders map (`V') `vm-mode-mark-map' VM mode message marking map (`M') `vm-mode-window-map' VM mode window configuration map (`W') `vm-mode-pipe-map' VM mode pipe-to-application map (`|') ") (defun vm-optional-key () "Certain VM keys have optional bindings in VM, which differ from version to version. Include \"(vm-legacy-key-bindings)\" in your `vm-preferences-file' in order to bind them as in version 7.19. For other possibilities, see the NEWS file of VM." (interactive) (error "This key has an optional binding in VM. Do C-h k for help.")) (defcustom vm-summary-enable-thread-folding nil "*If non-nil, enables folding of threads in VM summary windows. (This functionality is still experimental.)" :group 'vm-summary :type 'boolean) (defcustom vm-summary-show-thread-count t "*If non-nil, thread folding displays the count of messages in a thread along with the message number of the thread root. Note that this takes up 3 extra characters in each summary line." :group 'vm-summary :type 'boolean) (defcustom vm-summary-thread-folding-on-motion nil "*If non-nil and thread folding is enabled, invoking vm-next/previous-message-no-skip (`N' or `P' respectively) will expand a thread upon moving into the thread and collapse it when you move out of the thread." :group 'vm-summary :type 'boolean) (defcustom vm-summary-visible '((new)) "*List of selectors identifying messages that should be visible in folded thread summaries, i.e., such messages remain visible even if their threads are shown collapsed. The selectors are the same as those used in `vm-virtual-folder-alist'." :group 'vm-summary :type '(repeat sexp)) (defcustom vm-enable-thread-operations nil "*If non-nil, VM operations on root messages of collapsed threads will apply to all the messages in the threads. \"Operations\" in this context include deleting, saving, setting attributes, adding/deleting labels etc. If the variable is set to t then thread operations are always carried out. If it is set to 'ask, then the user is asked for confirmation whether the operation should apply to all the messages in the thread. This can be overridden by invoking the operation with a prefix argument using `C-u' and no questions will be asked." :group 'vm-summary :type '(choice (const t) (const ask) (const nil))) (defvar vm-summary-threads-collapsed t "If non-nil, indicates that threads should be folded (collapsed) in VM summary windows.") (make-variable-buffer-local 'vm-summary-threads-collapsed) (defvar vm-summary-mode-map vm-mode-map "Keymap for VM Summary mode") (defvar vm-folders-summary-mode-map vm-mode-map "Keymap for VM Folders Summary mode") (defvar vm-mail-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-v" vm-mode-map) (define-key map "\C-c\C-p" 'vm-preview-composition) (define-key map "\C-c\C-d" 'vm-postpone-message) (define-key map "\C-c\C-e" 'vm-mime-encode-composition) (define-key map "\C-c\C-a" 'vm-attach-file) (define-key map "\C-c\C-b" 'vm-attach-buffer) (define-key map "\C-c\C-m" 'vm-attach-message) (define-key map "\C-c\C-y" 'vm-yank-message) (define-key map "\C-c\C-s" 'vm-mail-send) (define-key map "\C-c\C-c" 'vm-mail-send-and-exit) ;; The following is a temporary binding for Mac/NextStep ;; It should be removed when dnd-protocol-alist is implemented (define-key map [ns-drag-file] 'vm-ns-attach-file) (cond ((fboundp 'set-keymap-name) (set-keymap-name map 'vm-mail-mode-map))) map ) "Keymap for VM Mail mode buffers. Its parent keymap is mail-mode-map.") (defvar vm-edit-message-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-v" vm-mode-map) (define-key map "\C-c\e" 'vm-edit-message-end) (define-key map "\C-c\C-c" 'vm-edit-message-end) (define-key map "\C-c\C-]" 'vm-edit-message-abort) (cond ((fboundp 'set-keymap-name) (set-keymap-name map 'vm-edit-message-map))) map ) "Keymap for the buffers created by VM's `vm-edit-message' command.") (defvar vm-mime-reader-map (let ((map (make-sparse-keymap))) (define-key map "\r" 'vm-mime-run-display-function-at-point) (define-key map "$\r" 'vm-mime-reader-map-display-using-default) (define-key map "$e" 'vm-mime-reader-map-display-using-external-viewer) (define-key map "$c" 'vm-mime-reader-map-convert-then-display) (define-key map "$v" 'vm-mime-reader-map-display-object-as-type) (define-key map "$w" 'vm-mime-reader-map-save-file) (define-key map "$s" 'vm-mime-reader-map-save-message) (define-key map "$p" 'vm-mime-reader-map-pipe-to-printer) (define-key map "$|" 'vm-mime-reader-map-pipe-to-command) (define-key map "$a" 'vm-mime-reader-map-attach-to-composition) (define-key map "$d" 'vm-delete-mime-object) (cond ((vm-mouse-xemacs-mouse-p) (define-key map 'button3 'vm-menu-popup-mime-dispose-menu))) (cond ((fboundp 'set-keymap-name) (set-keymap-name map 'vm-mime-reader-map))) map ) "Keymap for the MIME buttons in VM folder buffers.") (defvar vm-folder-history nil "List of folders visited this Emacs session.") ;; Do we need this variable in addition to the above? (defvar vm-switch-to-folder-history nil "List of folders used with `vm-switch-to-folder'.") ;; for sixth arg of read-file-name in early version of Emacs 21. (defun vm-folder-history (&rest ignored) t) ;; internal vars (defvar vm-skip-collapsed-sub-threads t) (defvar vm-folder-type nil) (make-variable-buffer-local 'vm-folder-type) (defvar vm-folder-access-method nil "Indicates how a VM folder is accessed: 'pop for POP folders, 'imap for IMAP folders and nil for local folders.") (make-variable-buffer-local 'vm-folder-access-method) (defvar vm-folder-access-data nil "Holds a vector of data about the mailbox on a mail server that this folder is meant to access.") (make-variable-buffer-local 'vm-folder-access-data) (defconst vm-folder-pop-access-data-length 2) (defconst vm-folder-imap-access-data-length 13) (defvar vm-message-list nil) (make-variable-buffer-local 'vm-message-list) (defvar vm-fetched-messages nil) (make-variable-buffer-local 'vm-fetched-messages) (defvar vm-fetched-message-count 0) (make-variable-buffer-local 'vm-fetched-message-count) (defvar vm-virtual-folder-definition nil "The virtual folder definition of the folder in the current buffer, which is normally an entry in `vm-virtual-folder-alist'. It is of the form: (VIRTUAL-FOLDER-NAME ((FOLDER-NAME ...) (SELECTOR [ARG ...]) ...) ... ) A FOLDER-NAME entry can be - the name of a local folder, or - an s-expression which, when evaluated, yields a folder buffer loaded in VM." ) (make-variable-buffer-local 'vm-virtual-folder-definition) (defvar vm-virtual-buffers nil) (make-variable-buffer-local 'vm-virtual-buffers) (defvar vm-real-buffers nil) (make-variable-buffer-local 'vm-real-buffers) (defvar vm-component-buffers nil "An a-list of folder buffers that make up the components of the current virtual folder, and a flag indicating whether they are being visited as a part of visiting this virtual folder. All such folders will be closed when the virtual folder is closed.") (make-variable-buffer-local 'vm-component-buffers) (defvar vm-message-pointer nil "A pointer into the `vm-message-list' indicating the position of the current message.") (make-variable-buffer-local 'vm-message-pointer) (defvar vm-message-order-changed nil) (make-variable-buffer-local 'vm-message-order-changed) (defvar vm-message-order-header-present nil) (make-variable-buffer-local 'vm-message-order-header-present) (defvar vm-last-message-pointer nil "A pointer into the `vm-message-list' indicating the position of the message last viewed.") (make-variable-buffer-local 'vm-last-message-pointer) (defvar vm-folders-summary-hash nil) (defvar vm-folders-summary-spool-hash nil) (defvar vm-folders-summary-folder-hash nil) (defvar vm-folders-summary-buffer nil) (defvar vm-mail-buffer nil "The folder buffer of the current buffer.") (make-variable-buffer-local 'vm-mail-buffer) (defvar vm-fetch-buffer nil "The fetch buffer, where message bodies are fetched, for the current folder. (Not in use.)") (make-variable-buffer-local 'vm-fetch-buffer) (defvar vm-presentation-buffer nil "The message presentation buffer for the current folder.") (make-variable-buffer-local 'vm-presentation-buffer) (defvar vm-presentation-buffer-handle nil "The message presentation buffer for the current folder.") (make-variable-buffer-local 'vm-presentation-buffer-handle) (defvar vm-mime-decoded nil "The MIME decoding state of the current folder.") (make-variable-buffer-local 'vm-mime-decoded) (defvar vm-summary-buffer nil "The summary buffer for the current folder.") (make-variable-buffer-local 'vm-summary-buffer) (defvar vm-user-interaction-buffer nil "The buffer in which the current VM command was invoked.") (defvar vm-summary-pointer nil) (make-variable-buffer-local 'vm-summary-pointer) (defvar vm-system-state nil) (make-variable-buffer-local 'vm-system-state) (defvar vm-undo-record-list nil "The list of undo records for the folder.") (make-variable-buffer-local 'vm-undo-record-list) (defvar vm-saved-undo-record-list nil "A saved version of the undo record list used in `vm-toggle-virtual-mirror'.") (make-variable-buffer-local 'vm-saved-undo-record-list) (defvar vm-undo-record-pointer nil "A pointer into the `vm-undo-record-list'.") (make-variable-buffer-local 'vm-undo-record-pointer) (defvar vm-last-save-folder nil) (make-variable-buffer-local 'vm-last-save-folder) (defvar vm-last-save-imap-folder nil) (make-variable-buffer-local 'vm-last-save-imap-folder) (defvar vm-last-written-file nil) (make-variable-buffer-local 'vm-last-written-file) (defvar vm-last-visit-folder nil) (defvar vm-last-visit-pop-folder nil) (defvar vm-last-visit-imap-folder nil) (defvar vm-last-visit-imap-account nil) (defvar vm-last-pipe-command nil) (make-variable-buffer-local 'vm-last-pipe-command) (defvar vm-messages-not-on-disk 0 "Number of messages in the folder that are not on the disk copy of the folder. This is the count from the user's point of view but may include some messages that are really on disk.") (make-variable-buffer-local 'vm-messages-not-on-disk) (defvar vm-totals nil) (make-variable-buffer-local 'vm-totals) (defvar vm-modification-counter 0) (make-variable-buffer-local 'vm-modification-counter) (defvar vm-flushed-modification-counter nil) (make-variable-buffer-local 'vm-flushed-modification-counter) (defvar vm-tempfile-counter 0) (defvar vm-messages-needing-summary-update nil) (defvar vm-buffers-needing-display-update nil "Obarray containing the names of VM buffers that need display update.") (defvar vm-buffers-needing-undo-boundaries nil "Obarray containing the names of VM buffers that need undo boundaries.") ; whatever they are! (defvar vm-numbering-redo-start-point nil "A pointer into `vm-message-list' indicating the position from which messages may need to be renumbered.") (make-variable-buffer-local 'vm-numbering-redo-start-point) (defvar vm-numbering-redo-end-point nil "A pointer into `vm-message-list' indicating the stopping point for any needed message renumbering.") (make-variable-buffer-local 'vm-numbering-redo-end-point) (defvar vm-summary-redo-start-point nil "A pointer into `vm-message-list' indicating the position from which summary lines may need to be redisplayed.") (make-variable-buffer-local 'vm-summary-redo-start-point) (defvar vm-need-summary-pointer-update nil "A boolean indicating whether the summary pointer for the current folder needs to be updated.") (make-variable-buffer-local 'vm-need-summary-pointer-update) (defvar vm-thread-obarray 'bonk) (make-variable-buffer-local 'vm-thread-obarray) (defvar vm-thread-subject-obarray 'bonk) (make-variable-buffer-local 'vm-thread-subject-obarray) (defvar vm-label-obarray nil) (make-variable-buffer-local 'vm-label-obarray) (defvar vm-block-new-mail nil) (make-variable-buffer-local 'vm-block-new-mail) (defvar vm-global-block-new-mail nil) (defvar vm-saved-buffer-modified-p nil) (make-variable-buffer-local 'vm-saved-buffer-modified-p) (defvar vm-kept-mail-buffers nil) (defvar vm-inhibit-write-file-hook nil) ;; used to choose between the default and ;; mail-extract-address-components but I don't see the utility of ;; it anymore. It tries to be too smart. ;;(defvar vm-chop-full-name-function 'vm-choose-chop-full-name-function) (defvar vm-chop-full-name-function 'vm-default-chop-full-name) (defvar vm-session-beginning t) (defvar vm-init-file-loaded nil) (defvar vm-window-configurations nil) (defvar vm-window-configuration nil) (defvar vm-message-id-number 0) (defconst vm-spool-directory (or (and (boundp 'rmail-spool-directory) rmail-spool-directory) "/usr/spool/mail/")) (defconst vm-content-length-search-regexp "^Content-Length:.*\n\\|\\(\n\n\\)") (defconst vm-content-length-header "Content-Length:") (defconst vm-references-header-regexp "^References:\\(.*\n\\([ \t].*\n\\)*\\)") (defconst vm-attributes-header-regexp "^X-VM-\\(Attributes\\|v5-Data\\):\\(.*\n\\([ \t].*\n\\)*\\)") (defconst vm-attributes-header "X-VM-v5-Data:") (defconst vm-message-order-header-regexp "^X-VM-Message-Order:") (defconst vm-message-order-header "X-VM-Message-Order:") (defconst vm-bookmark-header-regexp "^X-VM-Bookmark:") (defconst vm-bookmark-header "X-VM-Bookmark:") (defconst vm-pop-retrieved-header-regexp "^X-VM-POP-Retrieved:") (defconst vm-pop-retrieved-header "X-VM-POP-Retrieved:") (defconst vm-imap-retrieved-header-regexp "^X-VM-IMAP-Retrieved:") (defconst vm-imap-retrieved-header "X-VM-IMAP-Retrieved:") (defconst vm-storage-header-regexp "^X-VM-Storage:") (defconst vm-storage-header "X-VM-Storage:") (defconst vm-last-modified-header-regexp "^X-VM-Last-Modified:") (defconst vm-last-modified-header "X-VM-Last-Modified:") (defconst vm-summary-header-regexp "^X-VM-Summary-Format:") (defconst vm-summary-header "X-VM-Summary-Format:") (defconst vm-vheader-header-regexp "^X-VM-VHeader:") (defconst vm-vheader-header "X-VM-VHeader:") (defconst vm-labels-header-regexp "^X-VM-Labels:") (defconst vm-labels-header "X-VM-Labels:") (defconst vm-berkeley-mail-status-header "Status: ") (defconst vm-berkeley-mail-status-header-regexp "^Status: \\(..?\\)\n") (defconst vm-internal-unforwarded-header-regexp "\\(X-VM-\\|X-Mozilla-\\|Status:\\|Content-Length:\\)") (defvar vm-matched-header-vector (make-vector 6 nil)) (defconst vm-supported-folder-types '("From_" "BellFrom_" "From_-with-Content-Length" "mmdf" "babyl")) (defconst vm-supported-window-configurations '( ("default") ("startup") ("quitting") ("composing-message") ("editing-message") ("marking-message") ("reading-message") ("searching-message") ("vm") ("vm-add-message-labels") ("vm-apply-virtual-folder") ("vm-auto-archive-messages") ("vm-beginning-of-message") ("vm-burst-digest") ("vm-burst-mime-digest") ("vm-burst-rfc1153-digest") ("vm-burst-rfc934-digest") ("vm-change-folder-type") ("vm-clear-all-marks") ("vm-continue-composing-message") ("vm-create-virtual-folder") ("vm-create-virtual-folder-same-author") ("vm-create-virtual-folder-same-subject") ("vm-decode-mime-message") ("vm-delete-duplicate-messages") ("vm-delete-message") ("vm-delete-message-backward") ("vm-delete-message-labels") ("vm-delete-mime-object") ("vm-discard-cached-data") ("vm-edit-message") ("vm-edit-message-abort") ("vm-edit-message-end") ("vm-edit-message-other-frame") ("vm-end-of-message") ("vm-expose-hidden-headers") ("vm-expunge-folder") ("vm-expunge-imap-messages") ("vm-expunge-pop-messages") ("vm-folders-summarize") ("vm-followup") ("vm-followup-include-text") ("vm-followup-include-text-other-frame") ("vm-followup-other-frame") ("vm-forward-message") ("vm-forward-message-encapsulated") ("vm-forward-message-all-headers") ("vm-forward-message-all-headers-other-frame") ("vm-forward-message-other-frame") ("vm-forward-message-encapsulated-other-frame") ("vm-get-new-mail") ("vm-goto-message") ("vm-goto-message-last-seen") ("vm-goto-parent-message") ("vm-help") ("vm-isearch-forward") ("vm-kill-subject") ("vm-load-init-file") ("vm-mail") ("vm-mail-other-frame") ("vm-mail-other-window") ("vm-mail-send") ("vm-mail-send-and-exit") ("vm-mark-all-messages") ("vm-mark-help") ("vm-mark-matching-messages") ("vm-mark-matching-messages-with-virtual-folder") ("vm-mark-message") ("vm-mark-messages-same-author") ("vm-mark-messages-same-subject") ("vm-mark-summary-region") ("vm-mark-thread-subtree") ("vm-attach-buffer") ("vm-attach-file") ("vm-attach-message") ("vm-attach-mime-file") ("vm-attach-object-to-composition") ("vm-attach-message-to-composition") ("vm-mode") ("vm-move-message-backward") ("vm-move-message-backward-physically") ("vm-move-message-forward") ("vm-move-message-forward-physically") ("vm-move-to-previous-button") ("vm-move-to-next-button") ("vm-next-command-uses-marks") ("vm-next-message") ("vm-next-message-no-skip") ("vm-next-message-no-skip") ("vm-next-message-same-subject") ("vm-next-unread-message") ("vm-other-frame") ("vm-other-window") ("vm-pipe-message-to-command") ("vm-previous-message") ("vm-previous-message-no-skip") ("vm-previous-message-no-skip") ("vm-previous-message-same-subject") ("vm-previous-unread-message") ("vm-quit") ("vm-quit-just-bury") ("vm-quit-just-iconify") ("vm-quit-no-expunge") ("vm-quit-no-change") ("vm-reply") ("vm-reply-include-text") ("vm-reply-include-text-other-frame") ("vm-reply-other-frame") ("vm-resend-bounced-message") ("vm-resend-bounced-message-other-frame") ("vm-resend-message") ("vm-resend-message-other-frame") ("vm-save-and-expunge-folder") ("vm-save-buffer") ("vm-save-folder") ("vm-save-message") ("vm-save-message-sans-headers") ("vm-save-message-to-imap-folder") ("vm-scroll-backward") ("vm-scroll-backward-one-line") ("vm-scroll-forward") ("vm-scroll-forward-one-line") ("vm-send-digest") ("vm-send-digest-other-frame") ("vm-send-mime-digest") ("vm-send-mime-digest-other-frame") ("vm-send-rfc1153-digest") ("vm-send-rfc1153-digest-other-frame") ("vm-send-rfc934-digest") ("vm-send-rfc934-digest-other-frame") ("vm-set-message-attributes") ("vm-show-copying-restrictions") ("vm-show-no-warranty") ("vm-sort-messages") ("vm-submit-bug-report") ("vm-summarize") ("vm-summarize-other-frame") ("vm-toggle-all-marks") ("vm-toggle-read-only") ("vm-toggle-threads-display") ("vm-undelete-message") ("vm-undo") ("vm-unmark-matching-messages") ("vm-unmark-matching-messages-with-virtual-folder") ("vm-unmark-message") ("vm-unmark-messages-same-author") ("vm-unmark-messages-same-subject") ("vm-unmark-summary-region") ("vm-unmark-thread-subtree") ("vm-mark-message-unread") ("vm-mark-message-read") ("vm-virtual-help") ("vm-visit-folder") ("vm-visit-folder-other-frame") ("vm-visit-folder-other-window") ("vm-visit-imap-folder") ("vm-visit-imap-folder-other-frame") ("vm-visit-imap-folder-other-window") ("vm-visit-pop-folder") ("vm-visit-pop-folder-other-frame") ("vm-visit-pop-folder-other-window") ("vm-visit-virtual-folder") ("vm-visit-virtual-folder-other-frame") ("vm-visit-virtual-folder-other-window") ("vm-write-file") ("vm-yank-message") ("vm-yank-message-other-folder") )) (defconst vm-vs-attachment-regexp "^Content-Disposition: attachment" "Regexp used to detect attachments in a message.") (defvar vm-spam-words nil "A list of words often contained in spam messages.") (defvar vm-spam-words-regexp nil "A regexp matching those words in `vm-spam-words'.") (defcustom vm-spam-words-file (expand-file-name "~/.spam-words") "A file storing a list of words contained in spam messages." :group 'vm-folders :type 'file) (defcustom vm-spam-score-headers '(("X-Spam-Score:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number) ("X-Spam-Status:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number) ("X-Spam-Level:" "\\*+" length)) "The value should be a list of lists, with each sublist of the form (HEADER-REGEXP SCORE-REGEXP SCORE-FN) - HEADER-REGEXP is a regular expression matching the spam score header line in email messages, - SCORE-REGEXP is a regular expression matching the score, and - SCORE-FN is a function that converts the score string into a number." :group 'vm-folders :type '(repeat (list (string :tag "Header regexp") (regexp :tag "Regexp matching the spam-score") (function :tag "Function to convert the spam-score string to a number")))) (defvaralias 'vm-vs-spam-score-headers 'vm-spam-score-headers) (defconst vm-supported-sort-keys '("date" "reversed-date" "activity" "reversed-activity" "author" "reversed-author" "full-name" "reversed-full-name" "subject" "reversed-subject" "recipients" "reversed-recipients" "line-count" "reversed-line-count" "byte-count" "reversed-byte-count" "spam-score" "reversed-spam-score" "physical-order" "reversed-physical-order")) (defconst vm-supported-interactive-virtual-selectors '(("any") ("sexp") ("eval") ;; ("member") ; - yet to be defined ("virtual-folder-member") ("header") ("label") ("uid") ("uidl") ("message-id") ("text") ("header-or-text") ("recipient") ("author") ("author-or-recipient") ("outgoing") ("uninteresting-senders") ("subject") ("sent-before") ("sent-after") ("older-than") ("newer-than") ("attachment") ("more-chars-than") ("less-chars-than") ("more-lines-than") ("less-lines-than") ("new") ("unread") ("read") ("unseen") ("recent") ("flagged") ("unflagged") ("deleted") ("replied") ("forwarded") ("redistributed") ("filed") ("written") ("edited") ("marked") ("undeleted") ("unreplied") ("unforwarded") ("unredistributed") ("unfiled") ("unwritten") ("unedited") ("unmarked") ("expanded") ("collapsed") ("spam-word") ("spam-score") )) (defconst vm-virtual-selector-function-alist '((any . vm-vs-any) ;; (member . vm-vs-member) ; yet to be defined (virtual-folder-member . vm-vs-virtual-folder-member) (and . vm-vs-and) (or . vm-vs-or) (not . vm-vs-not) (sexp . vm-vs-sexp) (eval . vm-vs-eval) (thread . vm-vs-thread) (thread-all . vm-vs-thread-all) (header . vm-vs-header) (header-field . vm-vs-header-field) (label . vm-vs-label) (uid . vm-vs-uid) (uidl . vm-vs-uidl) (message-id . vm-vs-message-id) (text . vm-vs-text) (header-or-text . vm-vs-header-or-text) (recipient . vm-vs-recipient) (author . vm-vs-author) (author-or-recipient . vm-vs-author-or-recipient) (outgoing . vm-vs-outgoing) (uninteresting-senders . vm-vs-uninteresting-senders) (subject . vm-vs-subject) (sortable-subject . vm-vs-sortable-subject) (sent-before . vm-vs-sent-before) (sent-after . vm-vs-sent-after) (older-than . vm-vs-older-than) (newer-than . vm-vs-newer-than) (attachment . vm-vs-attachment) (more-chars-than . vm-vs-more-chars-than) (less-chars-than . vm-vs-less-chars-than) (more-lines-than . vm-vs-more-lines-than) (less-lines-than . vm-vs-less-lines-than) (new . vm-vs-new) (unread . vm-vs-unread) (read . vm-vs-read) (unseen . vm-vs-unseen) (recent . vm-vs-recent) (flagged . vm-vs-flagged) (unflagged . vm-vs-unflagged) (deleted . vm-vs-deleted) (replied . vm-vs-replied) (answered . vm-vs-answered) (forwarded . vm-vs-forwarded) (redistributed . vm-vs-redistributed) (filed . vm-vs-filed) (written . vm-vs-written) (edited . vm-vs-edited) (marked . vm-vs-marked) (undeleted . vm-vs-undeleted) (unreplied . vm-vs-unreplied) (unanswered . vm-vs-unanswered) (unforwarded . vm-vs-unforwarded) (unredistributed . vm-vs-unredistributed) (unfiled . vm-vs-unfiled) (unwritten . vm-vs-unwritten) (unedited . vm-vs-unedited) (unmarked . vm-vs-unmarked) (spam-word . vm-vs-spam-word) (spam-score . vm-vs-spam-score) (expanded . vm-vs-expanded) (collapsed . vm-vs-collapsed) )) (defconst vm-supported-attribute-names '("new" "unread" "read" "deleted" "replied" "forwarded" "redistributed" "filed" "written" "edited" "undeleted" "unreplied" "unforwarded" "unredistributed" "unfiled" "unwritten" "unedited" "expanded" "collapsed" ;; for babyl cogniscenti "recent" "unseen" "flagged" "unflagged" "answered" "unanswered" )) (defvar vm-key-functions nil) (defconst vm-digest-type-alist '(("rfc934") ("rfc1153") ("mime"))) (defvar vm-completion-auto-correct t "Non-nil means that minibuffer-complete-file should aggressively erase the trailing part of a word that caused completion to fail, and retry the completion with the resulting word.") (defvar vm-minibuffer-completion-table nil "Completion table used by `vm-minibuffer-complete-word'. Should be just a list of strings, not an alist or an obarray.") (defvar vm-completion-auto-space t "Non-nil value means that `vm-minibuffer-complete-word' should automatically append a space to words that complete unambiguously.") (defconst vm-folder-summary-vector-length 15) (defconst vm-startup-message-lines '("Please use \\[vm-submit-bug-report] to report bugs." "For discussion about the VM mail reader, see the gnu.emacs.vm.info newsgroup" "You may give out copies of VM. Type \\[vm-show-copying-restrictions] to see the conditions" "VM comes with ABSOLUTELY NO WARRANTY; type \\[vm-show-no-warranty] for full details")) (defconst vm-startup-message-displayed nil) ;; for the mode line (defconst vm-mode-line-format-robf '("- " (vm-compositions-exist ("" vm-ml-composition-buffer-count " / ")) (vm-drafts-exist ("" vm-ml-draft-count " / ")) ((vm-spooled-mail-waiting "New mail for ") (vm-folder-read-only "read-only ") (vm-virtual-folder-definition (vm-virtual-mirror "mirrored ")) " %&%& " "%b" (vm-mail-buffer (vm-ml-sort-keys ("" " by " vm-ml-sort-keys))) (vm-message-list (" " vm-ml-message-number " (of " vm-ml-highest-message-number ")") (vm-folder-type " (unrecognized folder type)" " (no messages)"))) (vm-message-list (" %[ " vm-ml-message-attributes-alist (vm-ml-labels ("; " vm-ml-labels)) " %] ") (" %[%] ")) "%p" " (VM " vm-version ")" global-mode-string "%-")) (defconst vm-mode-line-format-classic '("" " %&%& " ("VM: " (vm-folder-read-only "read-only ") (vm-virtual-folder-definition (vm-virtual-mirror "mirrored ")) "%b" (vm-mail-buffer (vm-ml-sort-keys ("" " by " vm-ml-sort-keys))) (vm-message-list (" " vm-ml-message-number " (of " vm-ml-highest-message-number ")") (vm-folder-type " (unrecognized folder type)" " (no messages)"))) (vm-spooled-mail-waiting " Mail") (vm-message-list (" %[ " vm-ml-message-attributes-alist (vm-ml-labels ("; " vm-ml-labels)) " %] ") (" %[%] ")) "%p" " " global-mode-string)) (defconst vm-mode-line-format vm-mode-line-format-classic) (defconst vm-ml-message-attributes-alist '((vm-ml-message-new "new" (vm-ml-message-unread "unread" (vm-ml-message-read "read"))) (vm-ml-message-edited " edited") (vm-ml-message-filed " filed") (vm-ml-message-written " written") (vm-ml-message-replied " replied") (vm-ml-message-forwarded " forwarded") (vm-ml-message-redistributed " redistributed") (vm-ml-message-deleted " deleted") (vm-ml-message-marked " MARKED"))) (defvar vm-ml-message-number nil) (make-variable-buffer-local 'vm-ml-message-number) (defvar vm-ml-highest-message-number nil) (make-variable-buffer-local 'vm-ml-highest-message-number) (defvar vm-ml-sort-keys nil) (make-variable-buffer-local 'vm-ml-sort-keys) (defvar vm-ml-labels nil) (make-variable-buffer-local 'vm-ml-labels) ; unused now ;(defvar vm-ml-attributes-string nil) ;(make-variable-buffer-local 'vm-ml-attributes-string) (defvar vm-ml-message-new nil) (make-variable-buffer-local 'vm-ml-message-new) (defvar vm-ml-message-unread nil) (make-variable-buffer-local 'vm-ml-message-unread) (defvar vm-ml-message-read nil) (make-variable-buffer-local 'vm-ml-message-read) (defvar vm-ml-message-edited nil) (make-variable-buffer-local 'vm-ml-message-edited) (defvar vm-ml-message-replied nil) (make-variable-buffer-local 'vm-ml-message-replied) (defvar vm-ml-message-forwarded nil) (make-variable-buffer-local 'vm-ml-message-forwarded) (defvar vm-ml-message-redistributed nil) (make-variable-buffer-local 'vm-ml-message-redistributed) (defvar vm-ml-message-deleted nil) (make-variable-buffer-local 'vm-ml-message-deleted) (defvar vm-ml-message-filed nil) (make-variable-buffer-local 'vm-ml-message-filed) (defvar vm-ml-message-written nil) (make-variable-buffer-local 'vm-ml-message-written) (defvar vm-ml-message-marked nil) (make-variable-buffer-local 'vm-ml-message-marked) (defcustom vm-remember-passwords-insecurely nil "If set to `t', VM uses its own storage for remembering passwords for POP/IMAP accounts, which is insecure." :group 'vm-folders :type 'boolean) ;; to make the tanjed compiler shut up (defvar vm-pop-read-point nil) (defvar vm-pop-ok-to-ask nil) (defvar vm-pop-passwords nil) ;; Keep a list of messages retrieved from the POP maildrops ;; Prune the list when messages are expunged on the server ;; This variable is also used for POP folders, to selectively mark ;; messages that need to be expunged on the server (defvar vm-pop-retrieved-messages nil) (make-variable-buffer-local 'vm-pop-retrieved-messages) ;; list of messages to be expunged on the server during the next save (defvar vm-pop-messages-to-expunge nil) (make-variable-buffer-local 'vm-pop-messages-to-expunge) (defvar vm-imap-read-point nil "Position in an IMAP process buffer where the next read must take place. In general, IMAP process reading functions move the point. No save-excursion's are used. This variable holds the position for the next read.") ;; Variable indicating whether IMAP session handling functions can ask ;; questions to the user, typically if they are run from interactive ;; commands. (defvar vm-imap-ok-to-ask nil) ;; Stored passwords for IMAP accounts during a VM session (defvar vm-imap-passwords nil) ;; Keep a list of messages retrieved from the IMAP maildrops ;; Prune the list when messages are expunged on the server ;; This variable is also used for IMAP folders, to selectively mark ;; messages that need to be expunged on the server (defvar vm-imap-retrieved-messages nil) (make-variable-buffer-local 'vm-imap-retrieved-messages) (defvar vm-imap-messages-to-expunge nil "Buffer local variable indicating messages to be expunged on the server. It is a list of pairs containing the UID and the UIDVALIDITY for each message to be expunged.") (make-variable-buffer-local 'vm-imap-messages-to-expunge) (defvar vm-imap-capabilities nil) (make-variable-buffer-local 'vm-imap-capabilities) (defvar vm-imap-auth-methods nil) (make-variable-buffer-local 'vm-imap-auth-methods) ;; The number of old ('failed') trace buffers to remember for debugging ;; purposes ;; These are now subsumed in vm-...-keep-trace-buffer variables. USR, 2011-11 ;; (defvar vm-pop-keep-failed-trace-buffers 20) ;; (defvar vm-imap-keep-failed-trace-buffers 20) ;; Lists of trace buffers remembered for debugging purposes (defvar vm-kept-pop-buffers nil "* Variable that holds the old trace buffers of POP sessions for debugging purposes.") ;; (make-variable-buffer-local 'vm-kept-pop-buffers) (defvar vm-kept-imap-buffers nil "* Variable that holds the old trace buffers of IMAP sessions for debugging purposes.") ;; (make-variable-buffer-local 'vm-kept-imap-buffers) ;; Flag to make POP/IMAP code remember old trace buffers (defcustom vm-pop-keep-trace-buffer 1 "* The number of POP session trace buffers that should be retained for debugging purposes. If it is nil, then no trace buffers are kept." :group 'vm-pop :type '(choice (integer :tag "Number of session buffers kept" (const :tag "No session buffers kept" nil)))) (defcustom vm-imap-keep-trace-buffer 1 "* The number of IMAP session trace buffers that should be retained for debugging purposes. If it is nil, then no trace buffers are kept." :group 'vm-imap :type '(choice (integer :tag "Number of session buffers kept" (const :tag "No session buffers kept" nil)))) (defvar vm-imap-session-done nil) (defvar vm-reply-list nil "Buffer local variable in Composition buffers that holds the set of messages to which this composition is a reply.") (defvar vm-forward-list nil "Buffer local variable in Composition buffers that holds the set of messages that are forwarded in this composition.") (defvar vm-redistribute-list nil "Buffer local variable in Composition buffers that holds the set of messages that are redistributed in this composition.") ;; For verification of assertions (defvar vm-assertion-checking-off t "* Set this to nil to enable assertion checking") ;; For verification of the correct buffer protocol ;; Possible values are 'folder, 'presentation, 'summary, 'process (defvar vm-buffer-types (cons nil nil)) (defvar vm-imap-session-type nil "This buffer-local variable holds the status of the IMAP session. Possible values are 'active - active session present 'valid - message sequence numbers are valid validity is preserved by FETCH, STORE and SEARCH operations 'inactive - session is inactive") (make-variable-buffer-local 'vm-imap-session-type) (eval-when-compile (defvar current-itimer nil) (defvar current-menubar nil) (defvar scrollbar-height nil) (defvar top-toolbar nil) (defvar top-toolbar-height nil) (defvar bottom-toolbar nil) (defvar bottom-toolbar-height nil) (defvar right-toolbar nil) (defvar right-toolbar-width nil) (defvar left-toolbar nil) (defvar left-toolbar-width nil)) (defvar vm-fsfemacs-toolbar-installed-p nil) ;; this defvar matches the XEmacs one so it doesn't matter if VM ;; is loaded before highlight-headers.el (defconst highlight-headers-regexp "Subject[ \t]*:") (defconst vm-url-regexp "\n]+\\)>\\|\\(\\(file\\|sftp\\|ftp\\|gopher\\|http\\|https\\|news\\|wais\\|www\\)://[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)\\|\\(mailto:[^ \t\n\f\r\"<>|()]*[^] \t\n\f\r\"<>|.!?(){}]\\)\\|\\(file:/[^ \t\n\f\r\"<>|()]*[^ \t\n\f\r\"<>|.!?(){}]\\)" "Regular expression that matches an absolute URL. The URL itself must be matched by a \\(..\\) grouping. VM will extract the URL by copying the lowest number grouping that has a match.") (defconst vm-month-alist '(("jan" "January" "1") ("feb" "February" "2") ("mar" "March" "3") ("apr" "April" "4") ("may" "May" "5") ("jun" "June" "6") ("jul" "July" "7") ("aug" "August" "8") ("sep" "September" "9") ("oct" "October" "10") ("nov" "November" "11") ("dec" "December" "12"))) (defconst vm-weekday-alist '(("sun" "Sunday" "0") ("mon" "Monday" "1") ("tue" "Tuesday" "2") ("wed" "Wednesday" "3") ("thu" "Thursday" "4") ("fri" "Friday" "5") ("sat" "Saturday" "6"))) (defvar pop-up-frames nil) (defvar vm-parse-date-workspace (make-vector 6 nil)) ;; cache so we don't call timezone-make-date-sortable so much. ;; messages have their own cache; this is for the virtual folder ;; alist selectors. (defvar vm-sortable-date-alist nil) (make-variable-buffer-local 'vm-sortable-date-alist) (defvar vm-summary-=> nil) (defvar vm-summary-no-=> nil) (defvar vm-summary-overlay nil) (make-variable-buffer-local 'vm-summary-overlay) (defvar vm-summary-tokenized-compiled-format-alist nil) (defvar vm-summary-untokenized-compiled-format-alist nil) (defvar vm-folders-summary-compiled-format-alist nil) (defvar vm-folders-summary-overlay nil) (defvar vm-spool-file-message-count-hash (make-vector 61 0)) (defvar vm-page-end-overlay nil) (make-variable-buffer-local 'vm-page-end-overlay) (defvar vm-begin-glyph-property (if (fboundp 'extent-property) 'begin-glyph 'before-string)) (defvar vm-thread-loop-obarray (make-vector 641 0)) (defvar vm-delete-duplicates-obarray (make-vector 29 0)) (defvar vm-image-obarray (make-vector 29 0)) (defvar vm-mail-mode-map-parented nil) (defvar vm-xface-cache (make-vector 29 0)) (defvar vm-mf-default-action nil) (defvar vm-mime-compiled-format-alist nil) (defconst vm-mime-default-action-string-alist ;; old definition ;; '(("text" . "display text") ;; ("multipart/alternative" . "display selected part") ;; ("multipart/digest" . "read digest") ;; ("multipart/parallel" . "display parts in parallel") ;; ("multipart" . "display parts") ;; ("message/partial" . "attempt message assembly") ;; ("message/external-body" . "retrieve the object") ;; ("message" . "display message") ;; ("audio" . "play audio") ;; ("video" . "display video") ;; ("image" . "display image") ;; ("model" . "display model") ;; ("application/postscript" . "display PostScript") ;; ("application/msword" . "display Word document") ;; ("application" . "display attachment")) '(("text" . "display") ("multipart/alternative" . "display selected part") ("multipart/digest" . "read digest") ("multipart/parallel" . "display parts in parallel") ("multipart" . "display parts") ("message/partial" . "attempt message assembly") ("message/external-body" . "retrieve") ("message" . "display") ("audio" . "play") ("video" . "play") ("image" . "display") ("model" . "display") ("application" . "display"))) (defconst vm-mime-type-description-alist '(("multipart/digest" . "digest") ("multipart/alternative" . "multipart alternative") ("multipart/parallel" . "multipart parallel") ("multipart" . "multipart message") ("text/plain" . "plain text") ("text/enriched" . "enriched text") ("text/html" . "HTML") ("text/calendar" . "Calendar event") ("text/directory" . "VCard") ("text/x-vcard" . "VCard") ("image/gif" . "GIF image") ("image/tiff" . "TIFF image") ("image/jpeg" . "JPEG image") ("image/png" . "PNG image") ("message/rfc822" . "mail message") ("message/news" . "news article") ("message/partial" . "message fragment") ("message/external-body" . "external") ("application/pdf" . "PDF") ("application/postscript" . "PostScript") ("application/msword" . "Document") ("application/vnd.ms-excel" . "Spreadsheet") ("application/vnd.ms-powerpoint" . "Presentation") ("application/vnd-ms-access" . "Database") ("application/vnd.oasis.opendocument.text" . "Open Doc") ("application/vnd.oasis.opendocument.presentation" . "Prsentation") ("application/vnd.oasis.opendocument.spreadsheet" . "Spreadsheet") ("application/vnd.oasis.opendocument.graphics" . "Graphics") ("application/vnd.oasis.opendocument.formulae" . "Formulae") ("application/vnd.oasis.opendocument.databases" . "Database") ("application/vnd.openxmlformats-officedocument.wordprocessingml.document" . "Document") ("application/vnd.openxmlformats-officedocument.wordprocessingml.document" . "Document") ("application/vnd.openxmlformats-officedocument.presentationml.presentation" . "Presentation") ("application/vnd.openxmlformats-officedocument.presentationml.presentation" . "Presentation") ("application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" . "Spreadsheet") ("application/vnd.openxmlformats-officedocument.spreadsheetml.sheet" . "Spreadsheet") ("application/x-dvi" . "DVI") ("application/octet-stream" . "Untyped binary data") ("application/mac-binhex40" . "Untyped Mac data"))) (defconst vm-mime-base64-alphabet (concat [ 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 48 49 50 51 52 53 54 55 56 57 43 47 ] )) (defconst vm-mime-base64-alphabet-decoding-vector [ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 62 0 0 0 63 52 53 54 55 56 57 58 59 60 61 0 0 0 0 0 0 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 0 0 0 0 0 0 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 0 0 0 0 0 ]) ;;(defconst vm-mime-base64-alphabet-decoding-alist ;; '( ;; ( 65 . 00) ( 66 . 01) ( 67 . 02) ( 68 . 03) ( 69 . 04) ( 70 . 05) ;; ( 71 . 06) ( 72 . 07) ( 73 . 08) ( 74 . 09) ( 75 . 10) ( 76 . 11) ;; ( 77 . 12) ( 78 . 13) ( 79 . 14) ( 80 . 15) ( 81 . 16) ( 82 . 17) ;; ( 83 . 18) ( 84 . 19) ( 85 . 20) ( 86 . 21) ( 87 . 22) ( 88 . 23) ;; ( 89 . 24) ( 90 . 25) ( 97 . 26) ( 98 . 27) ( 99 . 28) (100 . 29) ;; (101 . 30) (102 . 31) (103 . 32) (104 . 33) (105 . 34) (106 . 35) ;; (107 . 36) (108 . 37) (109 . 38) (110 . 39) (111 . 40) (112 . 41) ;; (113 . 42) (114 . 43) (115 . 44) (116 . 45) (117 . 46) (118 . 47) ;; (119 . 48) (120 . 49) (121 . 50) (122 . 51) ( 48 . 52) ( 49 . 53) ;; ( 50 . 54) ( 51 . 55) ( 52 . 56) ( 53 . 57) ( 54 . 58) ( 55 . 59) ;; ( 56 . 60) ( 57 . 61) ( 43 . 62) ( 47 . 63) ;; )) ;; ;;(defvar vm-mime-base64-alphabet-decoding-vector ;; (let ((v (make-vector 123 nil)) ;; (p vm-mime-base64-alphabet-decoding-alist)) ;; (while p ;; (aset v (car (car p)) (cdr (car p))) ;; (setq p (cdr p))) ;; v )) (defvar vm-message-garbage-alist nil "An association list of files created for this message and the actions to be taken to destroy them.") (make-variable-buffer-local 'vm-message-garbage-alist) (defvar vm-folder-garbage-alist nil "An association list of files created for this message and the actions to be taken to destroy them.") (make-variable-buffer-local 'vm-folder-garbage-alist) (defvar vm-global-garbage-alist nil "An association list of files created for this VM session and the actions to be taken to destroy them.") (defconst vm-mime-header-list '("MIME-Version:" "Content-")) (defconst vm-mime-header-regexp "\\(MIME-Version:\\|Content-\\)") (defconst vm-mime-mule-charset-to-coding-alist (cond (vm-fsfemacs-mule-p (let ((coding-systems (coding-system-list)) (alist nil) val) (while coding-systems (setq val (coding-system-get (car coding-systems) 'mime-charset)) (if val (setq alist (cons (list (symbol-name val) (car coding-systems)) alist))) (setq coding-systems (cdr coding-systems))) (setq alist (append '(("us-ascii" raw-text) ("unknown" iso-8859-1)) alist)) alist)) (t '( ("us-ascii" no-conversion) ("iso-8859-1" no-conversion) ("iso-8859-2" iso-8859-2) ("iso-8859-3" iso-8859-3) ("iso-8859-4" iso-8859-4) ("iso-8859-5" iso-8859-5) ; ("iso-8859-6" iso-8859-6) ("iso-8859-7" iso-8859-7) ("iso-8859-8" iso-8859-8) ("iso-8859-8-i" iso-8859-8) ("iso-8859-9" iso-8859-9) ("iso-2022-jp" iso-2022-jp) ("big5" big5) ("koi8-r" koi8-r) ("ks_c_5601-1987" euc-kr) ("euc-jp" euc-jp) ;; probably not correct, but probably better than nothing. ("iso-2022-jp-2" iso-2022-jp) ("iso-2022-int-1" iso-2022-int-1) ("iso-2022-kr" iso-2022-kr) ("euc-kr" iso-2022-kr) ) )) "Alist that maps MIME character sets to MULE coding systems. The information is generated from the 'mime-charset property of coding systems, if it is defined in the Emacs version. Otherwise, a default alist is used.") (defconst vm-mime-mule-charset-to-charset-alist '( (latin-iso8859-1 "iso-8859-1") (latin-iso8859-2 "iso-8859-2") (latin-iso8859-3 "iso-8859-3") (latin-iso8859-4 "iso-8859-4") (cyrillic-iso8859-5 "iso-8859-5") (arabic-iso8859-6 "iso-8859-6") (greek-iso8859-7 "iso-8859-7") (hebrew-iso8859-8 "iso-8859-8") (latin-iso8859-9 "iso-8859-9") (japanese-jisx0208 "iso-2022-jp") (korean-ksc5601 "iso-2022-kr") (chinese-gb2312 "iso-2022-jp") (sisheng "iso-2022-jp") (thai-tis620 "iso-2022-jp") ) "Alist that maps MULE character sets to matching MIME character sets.") (defconst vm-mime-mule-coding-to-charset-alist (cond (vm-fsfemacs-mule-p (let ((coding-systems (coding-system-list)) (alist nil) val) (while coding-systems (setq val (coding-system-get (car coding-systems) 'mime-charset)) (if val (setq alist (cons (list (car coding-systems) (symbol-name val)) alist))) (setq coding-systems (cdr coding-systems))) (setq alist (append '((raw-text "us-ascii")) alist)) alist)) (t '( (iso-2022-8 "iso-2022-jp") (iso-2022-7-unix "iso-2022-jp") (iso-2022-7-dos "iso-2022-jp") (iso-2022-7-mac "iso-2022-jp") ))) "Alist that maps MULE coding systems to MIME character sets. The information is generated from the 'mime-charset property of coding systems, if it is defined in the Emacs version. Otherwise, a default alist is used.") (defcustom vm-mime-charset-completion-alist (mapcar (lambda (a) (list (car a))) vm-mime-mule-charset-to-coding-alist) "The completion alist of MIME charsets known to VM. The default information is derived from `vm-mime-mule-charset-to-coding-alist' (which see)." :group 'vm-mime :type '(repeat (list string))) (defconst vm-mime-type-completion-alist '( ("text/plain") ("text/enriched") ("text/html") ("audio/basic") ("image/jpeg") ("image/png") ("image/gif") ("image/tiff") ("video/mpeg") ("application/postscript") ("application/octet-stream") ("message/rfc822") ("message/news") )) (defconst vm-mime-encoded-word-regexp "=\\?\\([^?*]+\\)\\(\\*\\([^?*]+\\)\\)?\\?\\([BbQq]\\)\\?\\([^?]+\\)\\?=") ;; for MS-DOS and Windows NT ;; nil value means text file ;; t value means binary file ;; presumably it controls whether LF -> CRLF mapping is done ;; when writing to files. (defvar buffer-file-type) (defvar vm-mf-attachment-file nil) (defvar vm-frame-list nil) (if (not (boundp 'shell-command-switch)) (defvar shell-command-switch "-c")) (defvar vm-stunnel-random-data-file nil) (defvar vm-stunnel-configuration-file nil) (defvar vm-fsfemacs-cached-scroll-bar-width nil) (defvar vm-update-composition-buffer-name-timer nil) (defcustom vm-enable-addons '(check-recipients check-for-empty-subject encode-headers) "*A list of addons to enable, t for all and nil to disable all. Most addons are from `vm-rfaddons-infect-vm'. You must restart VM after a change to cause any effects." :group 'vm-rfaddons :type '(set (const :tag "Enable shrinking of multi-line headers to one line." shrunken-headers) (const :tag "Open a line when typing in quoted text" open-line) (const :tag "Check the recipients before sending a message" check-recipients) (const :tag "Check for an empty subject before sending a message" check-for-empty-subject) (const :tag "MIME encode headers before sending a message" encode-headers) (const :tag "Clean up subject prefixes before sending a message" clean-subject) (const :tag "Do not replace Date: header when sending a message" fake-date) (const :tag "Bind '.' on attachment buttons to 'vm-mime-take-action-on-attachment'" take-action-on-attachment) (const :tag "Automatically save attachments of new messages" auto-save-all-attachments) (const :tag "Delete external attachments of a message when expunging it." auto-delete-message-external-body) (const :tag "Enable all addons" t))) (defcustom vm-summary-enable-faces nil "A non-NIL value enables the use of faces in the summary buffer. You should set this variable in the init-file. For interactive use, the command `vm-summary-faces-mode' should be used." :group 'vm-faces :type 'boolean) (defcustom vm-disable-modes-before-encoding '(auto-fill-mode font-lock-mode ispell-minor-mode flyspell-mode abbrev-mode adaptive-fill-mode) "*A list of minor modes to disable before encoding a message. These modes may slow down (font-lock and *spell) encoding and may cause trouble (abbrev-mode)." :group 'vm-compose :type '(repeat :tag "Mode" symbol)) (defvar vm-summary-faces-mode nil "Records whether VM Summary Faces mode is in use.") (make-obsolete-variable 'vm-summary-faces-mode 'vm-summary-enable-faces "8.2.0") ;; Duplicate defintion. See above. TX ;; (defcustom vm-mail-mode-hidden-headers '("References" "In-Reply-To" "X-Mailer") ;; "*A list of headers to hide in `vm-mail-mode'." ;; :group 'vm ;; :type '(choice (const :tag "Disabled" nil) ;; (set :tag "Header list" ;; (string "References") ;; (string "In-Reply-To") ;; (string "X-Mailer")))) ;; define this here so that the user can invoke it right away, if needed. (defun vm-load-init-file (&optional init-only) (interactive "P") (when (or (not vm-init-file-loaded) (interactive-p)) (when vm-init-file (load vm-init-file (not (interactive-p)) (not (interactive-p)) t)) (when (and vm-preferences-file (not init-only)) (load vm-preferences-file t t t))) (setq vm-init-file-loaded t) (vm-display nil nil '(vm-load-init-file) '(vm-load-init-file))) ;;; vm-vars.el ends here vm-8.2.0b/lisp/vm-undo.el0000755000175000017500000006340611676442160015460 0ustar srivastasrivasta;;; vm-undo.el --- Commands to undo message attribute changes in VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1995 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-undo) (eval-when-compile (require 'vm-misc) (require 'vm-menu) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-page) (require 'vm-motion) ) ;; vm-undo-record-list is a buffer-local-variable containing ;; undo-records. ;; An undo-record has: ;; - action ;; - message ;; - args (defun vm-undo-boundary () (if (car vm-undo-record-list) (setq vm-undo-record-list (cons nil vm-undo-record-list)))) (defun vm-add-undo-boundaries () (save-excursion (mapatoms (function (lambda (b) (setq b (get-buffer (symbol-name b))) (when b (set-buffer b) (vm-undo-boundary)))) vm-buffers-needing-undo-boundaries) (fillarray vm-buffers-needing-undo-boundaries 0))) (defun vm-clear-expunge-invalidated-undos () (let ((udp vm-undo-record-list) udp-prev) (while udp (cond ((null (car udp)) (setq udp-prev udp)) ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p)) ;; delete flag == expunged is the ;; indicator of an expunged message (eq (vm-deleted-flag (car (cdr (car udp)))) 'expunged)) (cond (udp-prev (setcdr udp-prev (cdr udp))) (t (setq vm-undo-record-list (cdr udp))))) (t (setq udp-prev udp))) (setq udp (cdr udp)))) (vm-clear-modification-flag-undos)) (defun vm-clear-virtual-quit-invalidated-undos () (let ((udp vm-undo-record-list) udp-prev) (while udp (cond ((null (car udp)) (setq udp-prev udp)) ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p)) ;; message-id-number == "Q" is the ;; indicator of a dead message (equal (vm-message-id-number-of (car (cdr (car udp)))) "Q")) (cond (udp-prev (setcdr udp-prev (cdr udp))) (t (setq vm-undo-record-list (cdr udp))))) (t (setq udp-prev udp))) (setq udp (cdr udp)))) (vm-clear-modification-flag-undos)) (defun vm-clear-modification-flag-undos () (let ((udp vm-undo-record-list) udp-prev) (while udp (cond ((null (car udp)) (setq udp-prev udp)) ((eq (car (car udp)) 'vm-set-buffer-modified-p) (cond (udp-prev (setcdr udp-prev (cdr udp))) (t (setq vm-undo-record-list (cdr udp))))) (t (setq udp-prev udp))) (setq udp (cdr udp))) (vm-squeeze-consecutive-undo-boundaries))) ;; squeeze out consecutive record separators left by record deletions (defun vm-squeeze-consecutive-undo-boundaries () (let ((udp vm-undo-record-list) udp-prev) (while udp (cond ((and (null (car udp)) udp-prev (null (car udp-prev))) (setcdr udp-prev (cdr udp))) (t (setq udp-prev udp))) (setq udp (cdr udp))) (if (equal '(nil) vm-undo-record-list) (setq vm-undo-record-list nil))) ;; for the Undo button on the menubar, if present (when (and (null vm-undo-record-list) (vm-menu-support-possible-p) (vm-menu-xemacs-menus-p)) (vm-menu-set-menubar-dirty-flag))) (defun vm-undo-record (sexp) ;; for the Undo button on the menubar, if present (when (and (null vm-undo-record-list) (vm-menu-support-possible-p) (vm-menu-xemacs-menus-p)) (vm-menu-set-menubar-dirty-flag)) (setq vm-undo-record-list (cons sexp vm-undo-record-list))) (defun vm-undo-describe (record) (let ((cell (assq (car record) '((vm-set-new-flag "new" "old") (vm-set-unread-flag "unread" "read") (vm-set-deleted-flag "deleted" "undeleted") (vm-set-forwarded-flag "forwarded" "unforwarded") (vm-set-replied-flag "answered" "unanswered") (vm-set-redistributed-flag "redistributed" "unredistributed") (vm-set-filed-flag "filed" "unfiled") (vm-set-written-flag "written" "unwritten")))) (m (nth 1 record)) labels) (cond (cell (vm-inform 1 "VM Undo! %s/%s %s -> %s" (buffer-name (vm-buffer-of m)) (vm-number-of m) (if (nth 2 record) (nth 2 cell) (nth 1 cell)) (if (nth 2 record) (nth 1 cell) (nth 2 cell)))) ((eq (car cell) 'vm-set-labels) (setq labels (nth 2 record)) (vm-inform 1 "VM Undo! %s/%s %s%s" (buffer-name (vm-buffer-of m)) (vm-number-of m) (if (null labels) "lost all its labels" "labels set to ") (if (null labels) "" (mapconcat 'identity labels ", "))))))) (defun vm-undo-set-message-pointer (record) (if (and (not (eq (car record) 'vm-set-buffer-modified-p)) (not (eq (nth 1 record) vm-message-pointer))) (progn (vm-record-and-change-message-pointer vm-message-pointer (or (cdr (vm-reverse-link-of (nth 1 record))) vm-message-list)) ;; make folder read-only to avoid modifications when we ;; do this. (let ((vm-folder-read-only t)) (vm-present-current-message))))) ;;;###autoload (defun vm-undo () "Undo last change to message attributes in the current folder. Consecutive invocations of this command cause sequentially earlier changes to be undone. After an intervening command between undos, the undos themselves become undoable." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-folder-read-only) (vm-display nil nil '(vm-undo) '(vm-undo)) (let ((modified (buffer-modified-p))) (unless (eq last-command 'vm-undo) (setq vm-undo-record-pointer vm-undo-record-list)) (unless vm-undo-record-pointer (error "No further VM undo information available")) ;; skip current record boundary (setq vm-undo-record-pointer (cdr vm-undo-record-pointer)) (while (car vm-undo-record-pointer) (vm-undo-set-message-pointer (car vm-undo-record-pointer)) (vm-undo-describe (car vm-undo-record-pointer)) (eval (car vm-undo-record-pointer)) (setq vm-undo-record-pointer (cdr vm-undo-record-pointer))) (when (and modified (not (buffer-modified-p))) (delete-auto-save-file-if-necessary)) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-set-message-attributes (string count) "Set message attributes. Use this command to change attributes like `deleted' or `replied'. Interactively you will be prompted for the attributes to be changed, and only the attributes you enter will be altered. You can use completion to expand the attribute names. The names should be entered as a space separated list. A numeric prefix argument COUNT causes the current message and the next COUNT-1 message to have their attributes altered. A negative COUNT arg causes the current message and the previous COUNT-1 messages to be altered. COUNT defaults to one." (interactive (let ((last-command last-command) (this-command this-command)) ;; so the user can see what message they are about to ;; modify. (vm-follow-summary-cursor) (list (vm-read-string "Set attributes: " vm-supported-attribute-names t) (prefix-numeric-value current-prefix-arg)))) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (vm-display nil nil '(vm-set-message-attributes) '(vm-set-message-attributes)) (let ((name-list (vm-parse string "[ \t]*\\([^ \t]+\\)")) (m-list (vm-select-operable-messages count (vm-interactive-p) "Set attributes of")) n-list name m) (while m-list (setq m (car m-list) n-list name-list) (while n-list (setq name (car n-list)) (cond ((string= name "new") (vm-set-new-flag m t)) ((string= name "recent") (vm-set-new-flag m t)) ((string= name "unread") (vm-set-unread-flag m t)) ((string= name "unseen") (vm-set-unread-flag m t)) ((string= name "read") (vm-set-new-flag m nil) (vm-set-unread-flag m nil)) ((string= name "deleted") (vm-set-deleted-flag m t)) ((string= name "replied") (vm-set-replied-flag m t)) ((string= name "answered") (vm-set-replied-flag m t)) ((string= name "forwarded") (vm-set-forwarded-flag m t)) ((string= name "redistributed") (vm-set-redistributed-flag m t)) ((string= name "filed") (vm-set-filed-flag m t)) ((string= name "written") (vm-set-written-flag m t)) ((string= name "edited") (vm-set-edited-flag-of m t)) ((string= name "undeleted") (vm-set-deleted-flag m nil)) ((string= name "unreplied") (vm-set-replied-flag m nil)) ((string= name "unanswered") (vm-set-replied-flag m nil)) ((string= name "unforwarded") (vm-set-forwarded-flag m nil)) ((string= name "unredistributed") (vm-set-redistributed-flag m nil)) ((string= name "unfiled") (vm-set-filed-flag m nil)) ((string= name "unwritten") (vm-set-written-flag m nil)) ((string= name "unedited") (vm-set-edited-flag-of m nil))) (setq n-list (cdr n-list))) (setq m-list (cdr m-list))) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-add-message-labels (string count) "Attach some labels to a message. These are arbitrary user-defined labels, not to be confused with message attributes like `new' and `deleted'. Interactively you will be prompted for the labels to be added. You can use completion to expand the label names, with the completion list being all the labels that have ever been used in this folder. The names should be entered as a space separated list. Label names are compared case-insensitively. A numeric prefix argument COUNT causes the current message and the next COUNT-1 message to have the labels added. A negative COUNT arg causes the current message and the previous COUNT-1 messages to be altered. COUNT defaults to one." (interactive (let ((last-command last-command) (this-command this-command) (vm-completion-auto-correct nil) (completion-ignore-case t)) ;; so the user can see what message they are about to ;; modify. (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (vm-read-string "Add labels: " (vm-obarray-to-string-list vm-label-obarray) t) (prefix-numeric-value current-prefix-arg))))) (let ((m-list nil) (ignored-labels nil)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (setq m-list (vm-select-operable-messages count (vm-interactive-p) "Add labels to")) (setq ignored-labels (vm-add-or-delete-message-labels string m-list 'all)) (if ignored-labels (vm-inform 1 "Label %s could not be added" string)))) ;;;###autoload (defun vm-add-existing-message-labels (string count) "Attach some already existing labels to a message. Only labels that are currently attached to some message in this folder or labels that have previously been attached to messages in this folder will be added. Other labels will be silently ignored. These are arbitrary user-defined labels, not to be confused with message attributes like `new' and `deleted'. Interactively you will be prompted for the labels to be added. You can use completion to expand the label names, with the completion list being all the labels that have ever been used in this folder. The names should be entered as a space separated list. Label names are compared case-insensitively. A numeric prefix argument COUNT causes the current message and the next COUNT-1 messages to have the labels added. A negative COUNT arg causes the current message and the previous COUNT-1 messages to be altered. COUNT defaults to one." (interactive (let ((last-command last-command) (this-command this-command) (vm-completion-auto-correct nil) (completion-ignore-case t)) ;; so the user can see what message they are about to ;; modify. (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (vm-read-string "Add labels: " (vm-obarray-to-string-list vm-label-obarray) t) (prefix-numeric-value current-prefix-arg))))) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let* ((m-list (vm-select-operable-messages count (vm-interactive-p) "Add labels to")) (ignored-labels (vm-add-or-delete-message-labels string m-list 'existing-only))) (if ignored-labels (progn (set-buffer (get-buffer-create "*Ignored Labels*")) (erase-buffer) (insert "These labels do not exist and were not added:\n\n") (while ignored-labels (insert (car ignored-labels) "\n") (setq ignored-labels (cdr ignored-labels))) (display-buffer (current-buffer)))))) ;;;###autoload (defun vm-delete-message-labels (string count) "Delete some labels from a message. These are arbitrary user-defined labels, not to be confused with message attributes like `new' and `deleted'. Interactively you will be prompted for the labels to be deleted. You can use completion to expand the label names, with the completion list being all the labels that have ever been used in this folder. The names should be entered as a space separated list. Label names are compared case-insensitively. A numeric prefix argument COUNT causes the current message and the next COUNT-1 message to have the labels deleted. A negative COUNT arg causes the current message and the previous COUNT-1 messages to be altered. COUNT defaults to one." (interactive (let ((last-command last-command) (this-command this-command) (vm-completion-auto-correct nil) (completion-ignore-case t)) ;; so the user can see what message they are about to ;; modify. (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (vm-read-string "Delete labels: " (vm-obarray-to-string-list vm-label-obarray) t) (prefix-numeric-value current-prefix-arg))))) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((m-list (vm-select-operable-messages count (vm-interactive-p) "Delete labels to"))) (vm-add-or-delete-message-labels string m-list nil))) (defun vm-add-or-delete-message-labels (string m-list add) "Add or delete the labels given in STRING for all messages in M-LIST. The third parameter ADD is one of: nil delete the label 'all add the label in all cases 'existing-only add the label only if it is already existing in the folder USR, 2010-12-20 " (vm-display nil nil '(vm-add-message-labels vm-delete-message-labels) (list this-command)) (setq string (downcase string)) (let ((action-labels (vm-parse string "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*")) (ignored-labels nil) labels act-labels m mm-list) (when (and add m-list) (if (eq add 'all) (progn (setq act-labels action-labels) (while act-labels (intern (car act-labels) vm-label-obarray) (setq act-labels (cdr act-labels)))) (let ((newlist nil)) (setq act-labels action-labels) (while act-labels (if (intern-soft (car act-labels) vm-label-obarray) (setq newlist (cons (car act-labels) newlist)) (setq ignored-labels (cons (car act-labels) ignored-labels))) (setq act-labels (cdr act-labels))) (setq action-labels newlist)))) (unless action-labels (setq m-list nil)) (while m-list (setq m (car m-list)) (when (and add (vm-virtual-message-p m)) (let ((labels action-labels)) (with-current-buffer (vm-buffer-of (vm-real-message-of m)) (while labels (intern (car labels) vm-label-obarray) (setq labels (cdr labels)))))) (when add (dolist (mm (vm-virtual-messages-of m)) (let ((labels action-labels)) (when (buffer-name (vm-buffer-of mm)) (with-current-buffer (vm-buffer-of mm) (while labels (intern (car labels) vm-label-obarray) (setq labels (cdr labels)))))))) (setq act-labels action-labels labels (copy-sequence (vm-labels-of (car m-list)))) (if add (while act-labels (setq labels (cons (car act-labels) labels) act-labels (cdr act-labels))) (while act-labels (setq labels (vm-delqual (car act-labels) labels) act-labels (cdr act-labels)))) (when add (setq labels (vm-delete-duplicates labels))) (vm-set-labels (car m-list) labels) (vm-set-attribute-modflag-of (car m-list) t) ; added by USR (setq m-list (cdr m-list))) (vm-update-summary-and-mode-line) ignored-labels)) (defun vm-set-xxxx-flag (m flag norecord function attr-index) "A generic function to set the message flag of M at ATTR-INDEX to the value FLAG. The argument FUNCTION tells the specific non-generic function that invoked this one. A boolean flag is returned indicating success or failure of the operation. The flag is also set for all the virtual messages mirroring M as well as the real message underlying M. Normally, a record of the change is kept for the purpose of undo, and the changed attributes are stuffed into the folder, but NORECORD suppresses all of this. USR 2010-04-06" (let ((m-list nil) vmp) (when (and (not vm-folder-read-only) (or (not (vm-virtual-messages-of m)) (not (with-current-buffer (vm-buffer-of (vm-real-message-of m)) vm-folder-read-only))) ;; do nothing it is is already set (not (eq flag (aref (vm-attributes-of m) attr-index)))) (unless norecord (dolist (v-m (cons (vm-real-message-of m) (vm-virtual-messages-of m))) (if (eq (vm-attributes-of m) (vm-attributes-of v-m)) (setq m-list (cons v-m m-list)))) (if (null m-list) (setq m-list (cons m m-list))) (save-excursion (dolist (mm m-list) (when (buffer-name (vm-buffer-of mm)) (set-buffer (vm-buffer-of mm)) (cond ((not (buffer-modified-p)) (vm-mark-folder-modified-p (vm-buffer-of mm)) (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) (vm-undo-record (list function mm (not flag))) ;; (vm-undo-boundary) (vm-increment vm-modification-counter))))) (aset (vm-attributes-of m) attr-index flag) (vm-mark-for-summary-update m) (unless norecord (vm-set-attribute-modflag-of m t) (if (eq vm-flush-interval t) (vm-stuff-virtual-message-data m) (vm-set-stuff-flag-of m t))) ;; return success result t))) (defun vm-set-xxxx-cached-data-flag (m flag norecord function attr-index) "A generic function to set the cached-data flag of M at ATTR-INDEX to the value FLAG. The argument FUNCTION tells the specific non-generic function that invoked this one. The flag is also set for all the virtual messages mirroring M as well as the real message underlying M. Normally, a record of the change is kept for the purpose of undo, and the changed attributes are stuffed into the folder, but NORECORD suppresses all of this. USR 2010-04-06" (let ((m-list nil) vmp) (when (and (not vm-folder-read-only) (or (not (vm-virtual-messages-of m)) (not (with-current-buffer (vm-buffer-of (vm-real-message-of m)) vm-folder-read-only))) ;; do nothing it is is already set (not (eq flag (aref (vm-cached-data-of m) attr-index)))) (unless norecord (dolist (v-m (cons (vm-real-message-of m) (vm-virtual-messages-of m))) (if (eq (vm-cached-data-of m) (vm-cached-data-of v-m)) (setq m-list (cons v-m m-list)))) (if (null m-list) (setq m-list (cons m m-list))) (save-excursion (dolist (mm m-list) (when (buffer-name (vm-buffer-of mm)) (set-buffer (vm-buffer-of mm)) (cond ((not (buffer-modified-p)) (vm-mark-folder-modified-p (vm-buffer-of mm)) (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) (vm-undo-record (list function mm (not flag))) ;; (vm-undo-boundary) (vm-increment vm-modification-counter))))) (aset (vm-cached-data-of m) attr-index flag) (vm-mark-for-summary-update m) (unless norecord (vm-set-attribute-modflag-of m t) (if (eq vm-flush-interval t) (vm-stuff-virtual-message-data m) (vm-set-stuff-flag-of m t)))))) (defun vm-set-labels (m labels) "Set the message labels of M to the value LABELS (a list of strings). The labels are also set for all the virtual messages mirroring M as well as the real message underlying M. A record of the change is kept for the purpose of undo, and the changed attributes are stuffed into the folder. USR 2010-04-06" (let ((m-list nil) (old-labels (vm-labels-of m))) (cond ((and (not vm-folder-read-only) (or (not (vm-virtual-messages-of m)) (not (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) vm-folder-read-only)))) (dolist (v-m (cons (vm-real-message-of m) (vm-virtual-messages-of m))) (if (eq (vm-attributes-of m) (vm-attributes-of v-m)) (setq m-list (cons v-m m-list)))) (if (null m-list) (setq m-list (cons m m-list))) (save-excursion (dolist (mm m-list) (when (buffer-name (vm-buffer-of mm)) (set-buffer (vm-buffer-of mm)) (cond ((not (buffer-modified-p)) (vm-mark-folder-modified-p (vm-buffer-of mm)) (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) (vm-undo-record (list 'vm-set-labels m old-labels)) ;; (vm-undo-boundary) (vm-increment vm-modification-counter)))) (vm-set-labels-of m labels) (vm-set-label-string-of m nil) (vm-mark-for-summary-update m) (if (eq vm-flush-interval t) (vm-stuff-virtual-message-data m) (vm-set-stuff-flag-of m t)))))) ;; This flag is defunct, replaced by body-to-be-discarded. USR, 2010-06-08 (defun vm-set-headers-to-be-retrieved-flag (m flag &optional norecord) nil) (defun vm-set-body-to-be-discarded-flag (m flag &optional norecord) (vm-set-xxxx-cached-data-flag m flag norecord 'vm-set-body-to-be-discarded-flag 21)) (defun vm-set-body-to-be-retrieved-flag (m flag &optional norecord) (vm-set-xxxx-cached-data-flag m flag norecord 'vm-set-body-to-be-retrieved-flag 22)) (defun vm-set-new-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-new-flag 0)) (defun vm-set-unread-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-unread-flag 1)) (defun vm-set-deleted-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-deleted-flag 2)) (defun vm-set-filed-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-filed-flag 3)) (defun vm-set-replied-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-replied-flag 4)) (defun vm-set-written-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-written-flag 5)) (defun vm-set-forwarded-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 6)) (defun vm-set-redistributed-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 8)) (defun vm-set-flagged-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 9)) (defun vm-set-folded-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 10)) (defun vm-set-watched-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 11)) (defun vm-set-ignored-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 12)) (defun vm-set-read-receipt-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 13)) (defun vm-set-read-receipt-sent-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 14)) (defun vm-set-attachments-flag (m flag &optional norecord) (vm-set-xxxx-flag m flag norecord 'vm-set-redistributed-flag 15)) ;; use these to avoid undo and summary update. (defun vm-set-new-flag-of (m flag) (aset (aref m 2) 0 flag)) (defun vm-set-unread-flag-of (m flag) (aset (aref m 2) 1 flag)) (defun vm-set-deleted-flag-of (m flag) (aset (aref m 2) 2 flag)) (defun vm-set-filed-flag-of (m flag) (aset (aref m 2) 3 flag)) (defun vm-set-replied-flag-of (m flag) (aset (aref m 2) 4 flag)) (defun vm-set-written-flag-of (m flag) (aset (aref m 2) 5 flag)) (defun vm-set-forwarded-flag-of (m flag) (aset (aref m 2) 6 flag)) (defun vm-set-redistributed-flag-of (m flag) (aset (aref m 2) 8 flag)) (defun vm-set-flagged-flag-of (m flag) (aset (aref m 2) 9 flag)) (defun vm-set-folded-flag-of (m flag) (aset (aref m 2) 10 flag)) (defun vm-set-watched-flag-of (m flag) (aset (aref m 2) 11 flag)) (defun vm-set-ignored-flag-of (m flag) (aset (aref m 2) 12 flag)) (defun vm-set-read-receipt-flag-of (m flag) (aset (aref m 2) 13 flag)) (defun vm-set-read-receipt-sent-flag-of (m flag) (aset (aref m 2) 14 flag)) (defun vm-set-attachments-flag-of (m flag) (aset (aref m 2) 15 flag)) ;; this is solely for the use of vm-stuff-message-data and ;; appears here only because this function should be grouped with ;; others of its kind for maintenance purposes. (defun vm-set-deleted-flag-in-vector (v flag) (aset v 2 flag)) ;; ditto. this is for vm-read-attributes. (defun vm-set-new-flag-in-vector (v flag) (aset v 0 flag)) ;;; vm-undo.el ends here vm-8.2.0b/lisp/vm-save.el0000755000175000017500000011634111676442160015446 0ustar srivastasrivasta;;; vm-save.el --- Saving and piping messages under VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989, 1990, 1993, 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;; (match-data) returns the match data as MARKERS, often corrupting it in the ;; process due to buffer narrowing, and the fact that buffers are indexed from ;; 1 while strings are indexed from 0. :-( ;;; Code: (provide 'vm-save) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-mime) (require 'vm-undo) (require 'vm-delete) (require 'vm-imap) ) (declare-function vm-session-initialization "vm" ()) ;;;###autoload (defun vm-auto-select-folder (mp auto-folder-alist) (condition-case error-data (catch 'match (let (header alist tuple-list) (setq alist auto-folder-alist) (while alist (setq header (vm-get-header-contents (car mp) (car (car alist)) ", ")) (when header (setq tuple-list (cdr (car alist))) (while tuple-list (when (let ((case-fold-search vm-auto-folder-case-fold-search)) (string-match (car (car tuple-list)) header)) ;; Don't waste time eval'ing an atom. (if (stringp (cdr (car tuple-list))) (throw 'match (cdr (car tuple-list))) (let* ((match-data (vm-match-data)) ;; allow this buffer to live forever (buf (get-buffer-create " *vm-auto-folder*")) (result)) ;; Set up a buffer that matches our cached ;; match data. (save-excursion (set-buffer buf) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for empty buffer (widen) (erase-buffer) (insert header) ;; It appears that get-buffer-create clobbers the ;; match-data. ;; ;; The match data is off by one because we matched ;; a string and Emacs indexes strings from 0 and ;; buffers from 1. ;; ;; Also store-match-data only accepts MARKERS!! ;; AUGHGHGH!! (store-match-data (mapcar (function (lambda (n) (and n (vm-marker n)))) (mapcar (function (lambda (n) (and n (1+ n)))) match-data))) (setq result (eval (cdr (car tuple-list)))) (while (consp result) (setq result (vm-auto-select-folder mp result))) (when result (throw 'match result)))))) (setq tuple-list (cdr tuple-list)))) (setq alist (cdr alist))) nil )) (error (error "error processing vm-auto-folder-alist: %s" (prin1-to-string error-data))))) ;;;###autoload (defun vm-auto-archive-messages (&optional arg) "Save all unfiled messages that auto-match a folder via `vm-auto-folder-alist' to their appropriate folders. Messages that are flagged for deletion are not saved. Prefix arg means to ask user for confirmation before saving each message. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are checked against `vm-auto-folder-alist'. The saved messages are flagged as `filed'." (interactive "P") (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((auto-folder) (archived 0)) (unwind-protect ;; Need separate (let ...) so vm-message-pointer can ;; revert back in time for ;; (vm-update-summary-and-mode-line). ;; vm-last-save-folder is tucked away here since archives ;; shouldn't affect its value. (let ((vm-message-pointer (if (eq last-command 'vm-next-command-uses-marks) (vm-select-operable-messages 0 (vm-interactive-p) "Archive"))) (done nil) stop-point (vm-last-save-folder vm-last-save-folder) (vm-move-after-deleting nil)) ;; Double check if the user really wants to archive (unless (or arg vm-message-pointer (y-or-n-p "Auto archive the entire folder? ")) (error "Aborted")) (setq vm-message-pointer (or vm-message-pointer vm-message-list)) (vm-inform 5 "Archiving...") ;; mark the place where we should stop. otherwise if any ;; messages in this folder are archived to this folder ;; we would file messages into this folder forever. (setq stop-point (vm-last vm-message-pointer)) (while (not done) (and (not (vm-filed-flag (car vm-message-pointer))) ;; don't archive deleted messages (not (vm-deleted-flag (car vm-message-pointer))) (setq auto-folder (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)) ;; Don't let user archive into the same folder ;; that they are visiting. (not (eq (vm-get-file-buffer auto-folder) (current-buffer))) (or (null arg) (y-or-n-p (format "Save message %s in folder %s? " (vm-number-of (car vm-message-pointer)) auto-folder))) (let ((vm-delete-after-saving vm-delete-after-archiving) (last-command 'vm-auto-archive-messages)) (vm-save-message auto-folder 1 nil 'quiet) (vm-increment archived) (vm-inform 6 "%d archived, still working..." archived))) (setq done (eq vm-message-pointer stop-point) vm-message-pointer (cdr vm-message-pointer)))) ;; fix mode line (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line)) (if (zerop archived) (vm-inform 5 "No messages were archived") (vm-inform 5 "%d message%s archived" archived (if (= 1 archived) "" "s"))))) ;;;--------------------------------------------------------------------------- ;; The following defun seems a lot less efficient than it might be, ;; but I don't have a better sense of how to access the folder buffer ;; and read its local variables. [2006/10/31:rpg] ;;--------------------------------------------------------------------------- (defun vm-imap-folder-p () "Is the current folder an IMAP folder?" (save-current-buffer (vm-select-folder-buffer) (eq vm-folder-access-method 'imap))) ;;;--------------------------------------------------------------------------- ;; New shell defun to handle both IMAP and local saving. ;;--------------------------------------------------------------------------- (defun vm-read-save-folder-name (&optional imap) (let (default default-is-imap default-imap directory file-name) (save-current-buffer ;; is this needed? USR, 2011-11-12 ;; (vm-session-initialization) (vm-select-folder-buffer) (vm-error-if-folder-empty) (setq default (or (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist) vm-last-save-folder)) (setq default-is-imap (and default (vm-imap-folder-spec-p default))) (setq default-imap (or (and default-is-imap default) vm-last-save-imap-folder vm-last-visit-imap-folder)) (setq directory (or vm-foreign-folder-directory vm-folder-directory default-directory))) (cond (imap (vm-read-imap-folder-name "Save to IMAP folder: " t nil default-imap)) ((and default (let ((default-directory directory)) (file-directory-p default))) (vm-read-file-name "Save in folder: " directory nil nil default)) (default-is-imap (let ((insert-default-directory nil)) (setq file-name (vm-read-file-name (format "Save in folder: (default %s) " (or (vm-imap-folder-for-spec default) (vm-safe-imapdrop-string default))) nil default ;; 'confirm ; -- this blocks the default )) (if (equal file-name "") default file-name))) (default (vm-read-file-name (format "Save in folder: (default %s) " default) directory default ;; 'confirm ; -- this blocks the default )) (t (vm-read-file-name "Save in folder: " directory nil 'confirm))))) ;;;###autoload (defun vm-save-message (folder &optional count mlist quiet) "Save the current message to another FOLDER, queried via the mini-buffer. The FOLDER may be a local file system folder or an IMAP folder. You can specify a preference by setting the variable `vm-imap-save-to-server'. Prefix arg COUNT means save this message and the next COUNT-1 messages. A negative COUNT means save this message and the previous COUNT-1 messages. When invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages in the current folder are saved; other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are saved." (interactive (list ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (vm-follow-summary-cursor) (vm-read-save-folder-name (and (vm-imap-folder-p) vm-imap-save-to-server))) (prefix-numeric-value current-prefix-arg))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (unless count (setq count 1)) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Save"))) (cond ((and (vm-imap-folder-p) vm-imap-save-to-server) (vm-save-message-to-imap-folder folder count mlist quiet)) ((vm-imap-folder-spec-p folder) (vm-save-message-to-imap-folder folder count mlist quiet)) (t (vm-save-message-to-local-folder folder count mlist quiet)))) ;;;###autoload (defun vm-save-message-to-local-folder (folder &optional count mlist quiet) "Save the current message to a mail folder. If the folder already exists, the message will be appended to it. Prefix arg COUNT means save this message and the next COUNT-1 messages. A negative COUNT means save this message and the previous COUNT-1 messages. When invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages in the current folder are saved; other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are saved. The saved messages are flagged as `filed'." (interactive (list ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (vm-follow-summary-cursor) (vm-read-save-folder-name)) (prefix-numeric-value current-prefix-arg))) (let (auto-folder unexpanded-folder ml) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (setq unexpanded-folder folder) (setq auto-folder (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)) (vm-display nil nil '(vm-save-message) '(vm-save-message)) (unless count (setq count 1)) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Save"))) (vm-retrieve-operable-messages count mlist) ;; Expand the filename, forcing relative paths to resolve ;; into the folder directory. (let ((default-directory (expand-file-name (or vm-foreign-folder-directory vm-folder-directory default-directory)))) (setq folder (expand-file-name folder))) ;; Confirm new folders, if the user requested this. (when (and vm-confirm-new-folders (not (file-exists-p folder)) (or (not vm-visit-when-saving) (not (vm-get-file-buffer folder))) (not (y-or-n-p (format "%s does not exist, save there anyway? " folder)))) (error "Save aborted")) ;; Check and see if we are currently visiting the folder ;; that the user wants to save to. (when (and (not vm-visit-when-saving) (vm-get-file-buffer folder)) (error "Folder %s is being visited, cannot save." folder)) (let ((coding-system-for-write (if (file-exists-p folder) (vm-get-file-line-ending-coding-system folder) (vm-new-folder-line-ending-coding-system))) (oldmodebits (and (fboundp 'default-file-modes) (default-file-modes))) (m nil) (save-count 0) folder-buffer target-type) (cond ((and mlist (eq vm-visit-when-saving t)) (setq folder-buffer (or (vm-get-file-buffer folder) ;; avoid letter bombs (let ((inhibit-local-variables t) (enable-local-eval nil) (enable-local-variables nil)) (find-file-noselect folder))))) ((and mlist vm-visit-when-saving) (setq folder-buffer (vm-get-file-buffer folder)))) (when (and mlist vm-check-folder-types) (setq target-type (or (vm-get-folder-type folder) vm-default-folder-type (and mlist (vm-message-type-of (car mlist))))) (when (eq target-type 'unknown) (error "Folder %s's type is unrecognized" folder))) (unwind-protect (save-excursion (when oldmodebits (set-default-file-modes vm-default-folder-permission-bits)) ;; if target folder is empty or nonexistent we need to ;; write out the folder header first. (when mlist (let ((attrs (file-attributes folder))) (when (or (null attrs) (= 0 (nth 7 attrs))) (if (null folder-buffer) (vm-write-string folder (vm-folder-header target-type)) (vm-write-string folder-buffer (vm-folder-header target-type)))))) (setq ml mlist) (while ml (setq m (vm-real-message-of (car ml))) (set-buffer (vm-buffer-of m)) ;; FIXME the following isn't really necessary (vm-assert (vm-body-retrieved-of m)) (vm-save-restriction (widen) ;; have to stuff the attributes in all cases because ;; the deleted attribute may have been stuffed ;; previously and we don't want to save that attribute. ;; also we don't want to save out the cached summary entry. (vm-stuff-message-data m t) (if (null folder-buffer) ;; write to disk (if (or (null vm-check-folder-types) (eq target-type (vm-message-type-of m))) (write-region (vm-start-of m) (vm-end-of m) folder t 'quiet) (if (null vm-convert-folder-types) (if (not (vm-virtual-message-p (car ml))) (error "Folder type mismatch: %s vs %s" (vm-message-type-of m) target-type) (error "Message %s type mismatches folder %s: %s vs %s" (vm-number-of (car ml)) folder (vm-message-type-of m) target-type)) (vm-write-string folder (vm-leading-message-separator target-type m t)) (if (eq target-type 'From_-with-Content-Length) (vm-write-string folder (concat vm-content-length-header " " (vm-su-byte-count m) "\n"))) (write-region (vm-headers-of m) (vm-text-end-of m) folder t 'quiet) (vm-write-string folder (vm-trailing-message-separator target-type)))) ;; write to folder-buffer (save-excursion (set-buffer folder-buffer) ;; if the buffer is a live VM folder ;; honor vm-folder-read-only. (when vm-folder-read-only (signal 'folder-read-only (list (current-buffer)))) (let ((buffer-read-only nil)) (vm-save-restriction (widen) (save-excursion (goto-char (point-max)) (if (or (null vm-check-folder-types) (eq target-type (vm-message-type-of m))) (insert-buffer-substring (vm-buffer-of m) (vm-start-of m) (vm-end-of m)) (if (null vm-convert-folder-types) (if (not (vm-virtual-message-p (car ml))) (error "Folder type mismatch: %s vs %s" (vm-message-type-of m) target-type) (error "Message %s type mismatches folder %s: %s vs %s" (vm-number-of (car ml)) folder (vm-message-type-of m) target-type)) (vm-write-string (current-buffer) (vm-leading-message-separator target-type m t)) (when (eq target-type 'From_-with-Content-Length) (vm-write-string (current-buffer) (concat vm-content-length-header " " (vm-su-byte-count m) "\n"))) (insert-buffer-substring (vm-buffer-of m) (vm-headers-of m) (vm-text-end-of m)) (vm-write-string (current-buffer) (vm-trailing-message-separator target-type))))) ;; vars should exist and be local ;; but they may have strange values, ;; so check the major-mode. (cond ((eq major-mode 'vm-mode) (vm-increment vm-messages-not-on-disk) (vm-clear-modification-flag-undos))))))) (save-excursion (narrow-to-region (vm-headers-of m) (vm-text-end-of m)) (run-hook-with-args 'vm-save-message-hook folder)) (unless (vm-filed-flag m) (when (vm-set-filed-flag m t) (vm-increment save-count) (vm-modify-folder-totals folder 'saved 1 m))) (vm-update-summary-and-mode-line) (setq ml (cdr ml))))) ;; unwind-protections (when oldmodebits (set-default-file-modes oldmodebits))) (when m (if folder-buffer (with-current-buffer folder-buffer (when (eq major-mode 'vm-mode) (vm-check-for-killed-summary) (vm-assimilate-new-messages) (if (null vm-message-pointer) (progn (setq vm-message-pointer vm-message-list vm-need-summary-pointer-update t) (intern (buffer-name) vm-buffers-needing-display-update) (vm-present-current-message)) (vm-update-summary-and-mode-line))) (unless quiet (vm-inform 7 "%d message%s saved to buffer %s" save-count (if (/= 1 save-count) "s" "") (buffer-name)))) (unless quiet (vm-inform 7 "%d message%s saved to %s" save-count (if (/= 1 save-count) "s" "") folder))))) (when (or (null vm-last-save-folder) (not (equal unexpanded-folder auto-folder))) (setq vm-last-save-folder unexpanded-folder)) (when (and vm-delete-after-saving (not vm-folder-read-only)) (vm-delete-message count mlist)) folder )) ;;;###autoload (defun vm-save-message-sans-headers (file &optional count quiet) "Save the current message to a file, without its header section. If the file already exists, the message body will be appended to it. Prefix arg COUNT means save the next COUNT message bodiess. A negative COUNT means save the previous COUNT bodies. When invoked on marked messages (via `vm-next-command-uses-marks'), only the next COUNT marked messages are saved; other intervening messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are saved. The saved messages are flagged as `written'. This command should NOT be used to save message to mail folders; use `vm-save-message' instead (normally bound to `s')." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (vm-read-file-name (if vm-last-written-file (format "Write text to file: (default %s) " vm-last-written-file) "Write text to file: ") nil vm-last-written-file nil) (prefix-numeric-value current-prefix-arg))))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-save-message-sans-headers) '(vm-save-message-sans-headers)) (unless count (setq count 1)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Save"))) (vm-retrieve-operable-messages count mlist) (setq file (expand-file-name file)) ;; Check and see if we are currently visiting the file ;; that the user wants to save to. (when (and (not vm-visit-when-saving) (vm-get-file-buffer file)) (error "File %s is being visited, cannot save." file)) (let ((oldmodebits (and (fboundp 'default-file-modes) (default-file-modes))) (coding-system-for-write (vm-get-file-line-ending-coding-system file)) (m nil) file-buffer) (cond ((and mlist (eq vm-visit-when-saving t)) (setq file-buffer (or (vm-get-file-buffer file) (find-file-noselect file)))) ((and mlist vm-visit-when-saving) (setq file-buffer (vm-get-file-buffer file)))) (unless (or (memq (vm-get-folder-type file) '(nil unknown)) (y-or-n-p "This file looks like a mail folder, append to it anyway? ")) (error "Aborted")) (unwind-protect (save-excursion (when oldmodebits (set-default-file-modes vm-default-folder-permission-bits)) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) ;; FIXME the following shouldn't be necessary any more (vm-assert (vm-body-retrieved-of m)) (vm-save-restriction (widen) (if (null file-buffer) (write-region (vm-text-of m) (vm-text-end-of m) file t 'quiet) (let ((start (vm-text-of m)) (end (vm-text-end-of m))) (save-excursion (set-buffer file-buffer) (save-excursion (let (buffer-read-only) (vm-save-restriction (widen) (save-excursion (goto-char (point-max)) (insert-buffer-substring (vm-buffer-of m) start end)))))))) (unless (vm-written-flag m) (vm-set-written-flag m t)) (vm-update-summary-and-mode-line) (setq mlist (cdr mlist))))) (and oldmodebits (set-default-file-modes oldmodebits))) (when (and m (not quiet)) (if file-buffer (vm-inform 5 "Message%s written to buffer %s" (if (/= 1 count) "s" "") (buffer-name file-buffer)) (vm-inform 5 "Message%s written to %s" (if (/= 1 count) "s" "") file))) (setq vm-last-written-file file)))) (defun vm-switch-to-command-output-buffer (command buffer discard-output) "Eventually switch to the output buffer of the command." (let ((output-bytes (save-excursion (set-buffer buffer) (buffer-size)))) (if (zerop output-bytes) (vm-inform 5 "Command '%s' produced no output." command) (if discard-output (vm-inform 5 "Command '%s' produced %d bytes of output." command output-bytes) (display-buffer buffer))))) (defun vm-pipe-message-part (m arg) "Return (START END) bounds for piping to external command, based on ARG." (cond ((equal prefix-arg '(4)) (list (vm-text-of m) (vm-text-end-of m))) ((equal prefix-arg '(16)) (list (vm-headers-of m) (vm-text-of m))) ((equal prefix-arg '(64)) (list (vm-vheaders-of m) (vm-text-end-of m))) (t (list (vm-headers-of m) (vm-text-end-of m))))) ;;;###autoload (defun vm-pipe-message-to-command (command &optional prefix-arg discard-output) "Runs a shell command with contents from the current message as input. By default, the entire message is used. Message separators are included if `vm-message-includes-separators' is non-Nil. With one \\[universal-argument] the text portion of the message is used. With two \\[universal-argument]'s the header portion of the message is used. With three \\[universal-argument]'s the visible header portion of the message plus the text portion is used. When invoked on marked messages (via `vm-next-command-uses-marks'), each marked message is successively piped to the shell command, one message per command invocation. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are piped. Output, if any, is displayed. The message is not altered." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (read-string "Pipe to command: " vm-last-pipe-command) current-prefix-arg)))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (setq vm-last-pipe-command command) (let ((buffer (get-buffer-create "*Shell Command Output*")) m (pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-operable-messages for marks and threads. (mlist (vm-select-operable-messages 1 (vm-interactive-p) "Pipe"))) (vm-retrieve-operable-messages 1 mlist) (save-excursion (set-buffer buffer) (erase-buffer)) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) (save-restriction (widen) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (selective-display nil) (region (vm-pipe-message-part m prefix-arg))) (call-process-region (nth 0 region) (nth 1 region) (or shell-file-name "sh") nil buffer nil shell-command-switch command))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-pipe-message-to-command) '(vm-pipe-message-to-command)) (vm-switch-to-command-output-buffer command buffer discard-output) buffer)) (defun vm-pipe-message-to-command-to-string (command &optional prefix-arg) "Run a shell command with contents from the current message as input. This function is like `vm-pipe-message-to-command', but will not display the output of the command, but return it as a string." (save-excursion (set-buffer (vm-pipe-message-to-command command prefix-arg t)) (buffer-substring-no-properties (point-min) (point-max)))) ;;;###autoload (defun vm-pipe-message-to-command-discard-output (command &optional prefix-arg) "Run a shell command with contents from the current message as input. This function is like `vm-pipe-message-to-command', but will not display the output of the command." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (read-string "Pipe to command: " vm-last-pipe-command) current-prefix-arg)))) (vm-pipe-message-to-command command prefix-arg t)) (defun vm-pipe-command-exit-handler (process command discard-output &optional exit-handler) "Switch to output buffer of PROCESS that ran COMMAND, if DISCARD-OUTPUT non-nil. If non-nil call EXIT-HANDLER with the two arguments COMMAND and OUTPUT-BUFFER." (let ((exit-code (process-exit-status process)) (buffer (process-buffer process)) (process-command (process-command process))) (if (not (zerop exit-code)) (vm-warn 0 0 "Command '%s' exit code is %d." command exit-code)) (vm-display nil nil '(vm-pipe-message-to-command) '(vm-pipe-message-to-command)) (vm-switch-to-command-output-buffer command buffer discard-output) (if exit-handler (funcall exit-handler process-command buffer)))) (defvar vm-pipe-messages-to-command-start t "*The string to be used as the leading message separator by `vm-pipe-messages-to-command' at the beginning of each message. If set to 't', then use the leading message separator stored in the VM folder. If set to nil, then no leading separator is included.") (defvar vm-pipe-messages-to-command-end t "*The string to be used as the trailing message separator by `vm-pipe-messages-to-command' at the end of each message. If set to 't', then use the trailing message separator stored in the VM folder. If set to nil, no trailing separator is included.") ;;;###autoload (defun vm-pipe-messages-to-command (command &optional prefix-arg discard-output no-wait) "Run a shell command with contents from messages as input. Similar to `vm-pipe-message-to-command', but it will call process just once and pipe all messages to it. For bulk operations this is much faster than calling the command on each message. This is more like saving to a pipe. With one \\[universal-argument] the text portion of the messages is used. With two \\[universal-argument]'s the header portion of the messages is used. With three \\[universal-argument]'s the visible header portion of the messages plus the text portion is used. Leading and trailing separators are included with each message depending on the settings of `vm-pipe-messages-to-command-start' and `vm-pipe-messages-to-command-end'. Output, if any, is displayed unless DISCARD-OUTPUT is t. If NO-WAIT is t, then do not wait for process to finish, if it is a function then call it with the COMMAND and OUTPUT-BUFFER as arguments after the command finished." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (read-string "Pipe to command: " vm-last-pipe-command) current-prefix-arg)))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (setq vm-last-pipe-command command) (let ((buffer (get-buffer-create "*Shell Command Output*")) (pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-operable-messages for marks and threads. (mlist (vm-select-operable-messages 1 (vm-interactive-p) "Pipe")) m process) (vm-retrieve-operable-messages 1 mlist) (save-excursion (set-buffer buffer) (erase-buffer)) (setq process (start-process command buffer (or shell-file-name "sh") shell-command-switch command)) (set-process-sentinel process `(lambda (process status) (setq status (process-status process)) (if (eq 'exit status) (if ,no-wait (vm-pipe-command-exit-handler process ,command ,discard-output (if (and ,no-wait (functionp ,no-wait)) ,no-wait))) (vm-inform 1 "Command '%s' changed state to %s." ,command status)))) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) (save-restriction (widen) (cond ((eq vm-pipe-messages-to-command-start t) (process-send-region process (vm-start-of m) (vm-headers-of m))) (vm-pipe-messages-to-command-start (process-send-string process vm-pipe-messages-to-command-start))) (let ((region (vm-pipe-message-part m prefix-arg))) (process-send-region process (nth 0 region) (nth 1 region))) (cond ((eq vm-pipe-messages-to-command-end t) (process-send-region process (vm-text-end-of m) (vm-end-of m))) (vm-pipe-messages-to-command-end (process-send-string process vm-pipe-messages-to-command-end)))) (setq mlist (cdr mlist))) (process-send-eof process) (when (not no-wait) (while (and (eq 'run (process-status process))) (accept-process-output process) (sit-for 0)) (vm-pipe-command-exit-handler process command discard-output)) buffer)) (defun vm-pipe-messages-to-command-to-string (command &optional prefix-arg) "Runs a shell command with contents from the current message as input. This function is like `vm-pipe-messages-to-command', but will not display the output of the command, but return it as a string." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (read-string "Pipe to command: " vm-last-pipe-command) current-prefix-arg)))) (save-excursion (set-buffer (vm-pipe-messages-to-command command prefix-arg t)) (buffer-substring-no-properties (point-min) (point-max)))) ;;;###autoload (defun vm-pipe-messages-to-command-discard-output (command &optional prefix-arg) "Runs a shell command with contents from the current message as input. This function is like `vm-pipe-messages-to-command', but will not display the output of the command." (interactive ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (save-current-buffer (vm-follow-summary-cursor) (vm-select-folder-buffer) (list (read-string "Pipe to command: " vm-last-pipe-command) current-prefix-arg)))) (vm-pipe-messages-to-command command prefix-arg t)) ;;;###autoload (defun vm-print-message (&optional count) "Print the current message Prefix arg N means print the current message and the next N - 1 messages. Prefix arg -N means print the current message and the previous N - 1 messages. The variable `vm-print-command' controls what command is run to print the message, and `vm-print-command-switches' is a list of switches to pass to the command. When invoked on marked messages (via `vm-next-command-uses-marks'), each marked message is printed, one message per vm-print-command invocation. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are printed. Output, if any, is displayed. The message is not altered." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (or count (setq count 1)) (let* ((buffer (get-buffer-create "*Shell Command Output*")) (need-tempfile (string-match ".*-.*-\\(win95\\|nt\\)" system-configuration)) (tempfile (if need-tempfile (vm-make-tempfile-name))) (command (mapconcat (function identity) (nconc (list vm-print-command) (copy-sequence vm-print-command-switches) (if need-tempfile (list tempfile))) " ")) (m nil) (pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) (mlist (vm-select-operable-messages count (vm-interactive-p) "Print"))) (vm-retrieve-operable-messages count mlist) (save-excursion (set-buffer buffer) (erase-buffer)) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) (if (and vm-display-using-mime (vectorp (vm-mm-layout m))) (let ((work-buffer nil)) (unwind-protect (progn (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (vm-insert-region-from-buffer (vm-buffer-of m) (vm-vheaders-of m) (vm-text-of m)) (vm-decode-mime-encoded-words) (goto-char (point-max)) (let ((vm-mime-auto-displayed-content-types '("text" "multipart")) (vm-mime-internal-content-types '("text" "multipart")) (vm-mime-external-content-types-alist nil)) (vm-decode-mime-layout (vm-mm-layout m))) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (selective-display nil)) (if need-tempfile (write-region (point-min) (point-max) tempfile nil 0)) (call-process-region (point-min) (point-max) (or shell-file-name "sh") nil buffer nil shell-command-switch command) (if need-tempfile (vm-error-free-call 'delete-file tempfile)))) (and work-buffer (kill-buffer work-buffer)))) (save-restriction (widen) (narrow-to-region (vm-vheaders-of m) (vm-text-end-of m)) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (selective-display nil)) (if need-tempfile (write-region (point-min) (point-max) tempfile nil 0)) (call-process-region (point-min) (point-max) (or shell-file-name "sh") nil buffer nil shell-command-switch command) (if need-tempfile (vm-error-free-call 'delete-file tempfile))))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-print-message) '(vm-print-message)) (vm-switch-to-command-output-buffer command buffer nil))) ;;;###autoload (defun vm-save-message-to-imap-folder (folder &optional count mlist quiet) "Save the current message to an IMAP folder. Prefix arg COUNT means save this message and the next COUNT-1 messages. A negative COUNT means save this message and the previous COUNT-1 messages. When invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages in the current folder are saved; other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are saved. The saved messages are flagged as `filed'." (interactive (list (let ((this-command this-command) (last-command last-command)) (vm-follow-summary-cursor) (vm-read-save-folder-name t)) (prefix-numeric-value current-prefix-arg))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-save-message-to-imap-folder) '(vm-save-message-to-imap-folder)) (unless count (setq count 1)) (let (source-spec-list (target-spec-list (vm-imap-parse-spec-to-list folder)) ml m (save-count 0) server-to-server-p mailbox process ) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Save"))) (setq mailbox (nth 3 target-spec-list)) (unwind-protect (save-excursion (vm-inform 5 "Saving messages...") (setq ml mlist) (while ml (setq m (vm-real-message-of (car ml))) (set-buffer (vm-buffer-of m)) (setq source-spec-list (and (vm-imap-folder-p) (vm-imap-parse-spec-to-list (vm-folder-imap-maildrop-spec)))) (setq server-to-server-p ; copy on the same imap server (and (equal (nth 1 source-spec-list) (nth 1 target-spec-list)) (equal (nth 5 source-spec-list) (nth 5 target-spec-list)))) ;; FIXME try to load the body before saving (if (and (not server-to-server-p) (vm-body-to-be-retrieved-of m)) (error "Message %s body has not been retrieved" (vm-number-of (car ml)))) ;; Kyle Jones says: ;; have to stuff the attributes in all cases because ;; the deleted attribute may have been stuffed ;; previously and we don't want to save that attribute. ;; FIXME But stuffing attributes into the IMAP buffer is ;; not easy. USR, 2010-03-08 ;; (vm-stuff-message-data m t) (if server-to-server-p ; economise on upstream data traffic (let ((process (vm-re-establish-folder-imap-session nil "save"))) (if (null process) (error "Could not connect to the IMAP server")) (vm-imap-copy-message process m mailbox)) (unless process (setq process (vm-imap-make-session folder t "save"))) (if (null process) (error "Could not connect to the IMAP server")) (vm-imap-save-message process m mailbox)) (vm-run-hook-on-message-with-args 'vm-save-message-hook m folder) (vm-set-filed-flag m t) (vm-increment save-count) (vm-modify-folder-totals folder 'saved 1 m) ;; we set the deleted flag so that the user is not ;; confused if the save doesn't go through fully. (when (and vm-delete-after-saving (not (vm-deleted-flag m))) (vm-set-deleted-flag m t)) (vm-inform 6 "Saving messages... %s" save-count) (setq ml (cdr ml)))) (when process (vm-imap-end-session process)) (vm-inform 5 "%d message%s saved to %s" save-count (if (/= 1 save-count) "s" "") (or (vm-imap-folder-for-spec folder) (vm-safe-imapdrop-string folder)))) (vm-update-summary-and-mode-line) (setq vm-last-save-imap-folder folder) ;; We call delete-message again even though the deleted-flags have ;; already been set, perhaps to take care of other business? (if (and vm-delete-after-saving (not vm-folder-read-only)) (vm-delete-message count mlist)) folder )) ;;; vm-save.el ends here vm-8.2.0b/lisp/vm-pop.el0000755000175000017500000013236411676442160015311 0ustar srivastasrivasta;;; vm-pop.el --- Simple POP (RFC 1939) client for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1993, 1994, 1997, 1998 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-pop) ;; For function declarations (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-crypto) (require 'vm-mime) ) (declare-function vm-submit-bug-report "vm.el" (&optional pre-hooks post-hooks)) (declare-function open-network-stream "subr.el" (name buffer host service &rest parameters)) (if (fboundp 'define-error) (progn (define-error 'vm-cant-uidl "Can't use UIDL") (define-error 'vm-dele-failed "DELE command failed") (define-error 'vm-uidl-failed "UIDL command failed")) (put 'vm-cant-uidl 'error-conditions '(vm-cant-uidl error)) (put 'vm-cant-uidl 'error-message "Can't use UIDL") (put 'vm-dele-failed 'error-conditions '(vm-dele-failed error)) (put 'vm-dele-failed 'error-message "DELE command failed") (put 'vm-uidl-failed 'error-conditions '(vm-uidl-failed error)) (put 'vm-uidl-failed 'error-message "UIDL command failed")) (defun vm-pop-find-cache-file-for-spec (remote-spec) "Given REMOTE-SPEC, which is a maildrop specification of a folder on a POP server, find its cache file on the file system" ;; Prior to VM 7.11, we computed the cache filename ;; based on the full POP spec including the password ;; if it was in the spec. This meant that every ;; time the user changed his password, we'd start ;; visiting the wrong (and probably nonexistent) ;; cache file. ;; ;; To fix this we do two things. First, migrate the ;; user's caches to the filenames based in the POP ;; sepc without the password. Second, we visit the ;; old password based filename if it still exists ;; after trying to migrate it. ;; ;; For VM 7.16 we apply the same logic to the access ;; methods, pop, pop-ssh and pop-ssl and to ;; authentication method and service port, which can ;; also change and lead us to visit a nonexistent ;; cache file. The assumption is that these ;; properties of the connection can change and we'll ;; still be accessing the same mailbox on the ;; server. (let ((f-pass (vm-pop-make-filename-for-spec remote-spec)) (f-nopass (vm-pop-make-filename-for-spec remote-spec t)) (f-nospec (vm-pop-make-filename-for-spec remote-spec t t))) (cond ((or (string= f-pass f-nospec) (file-exists-p f-nospec)) nil ) ((file-exists-p f-pass) ;; try to migrate (condition-case nil (rename-file f-pass f-nospec) (error nil))) ((file-exists-p f-nopass) ;; try to migrate (condition-case nil (rename-file f-nopass f-nospec) (error nil)))) ;; choose the one that exists, password version, ;; nopass version and finally nopass+nospec ;; version. (cond ((file-exists-p f-pass) f-pass) ((file-exists-p f-nopass) f-nopass) (t f-nospec)))) ;; Our goal is to drag the mail from the POP maildrop to the crash box. ;; just as if we were using movemail on a spool file. ;; We remember which messages we have retrieved so that we can ;; leave the message in the mailbox, and yet not retrieve the ;; same messages again and again. ;;;###autoload (defun vm-pop-move-mail (source destination) (let ((process nil) (m-per-session vm-pop-messages-per-session) (b-per-session vm-pop-bytes-per-session) (handler (vm-find-file-name-handler source 'vm-pop-move-mail)) (popdrop (or (vm-pop-find-name-for-spec source) (vm-safe-popdrop-string source))) (statblob nil) (can-uidl t) (msgid (list nil (vm-popdrop-sans-password source) 'uidl)) (pop-retrieved-messages vm-pop-retrieved-messages) auto-expunge x mailbox-count mailbox-size message-size response n (retrieved 0) retrieved-bytes process-buffer uidl) (setq auto-expunge (cond ((setq x (assoc source vm-pop-auto-expunge-alist)) (cdr x)) ((setq x (assoc (vm-popdrop-sans-password source) vm-pop-auto-expunge-alist)) (cdr x)) (vm-pop-expunge-after-retrieving t) ((member source vm-pop-auto-expunge-warned) nil) (t (vm-warn 1 1 "Warning: POP folder is not set to auto-expunge") (setq vm-pop-auto-expunge-warned (cons source vm-pop-auto-expunge-warned)) nil))) (unwind-protect (catch 'done (if handler (throw 'done (funcall handler 'vm-pop-move-mail source destination))) (setq process (vm-pop-make-session source)) (or process (throw 'done nil)) (setq process-buffer (process-buffer process)) (save-excursion (set-buffer process-buffer) ;; find out how many messages are in the box. (vm-pop-send-command process "STAT") (setq response (vm-pop-read-stat-response process) mailbox-count (nth 0 response) mailbox-size (nth 1 response)) ;; forget it if the command fails ;; or if there are no messages present. (if (or (null mailbox-count) (< mailbox-count 1)) (throw 'done nil)) ;; loop through the maildrop retrieving and deleting ;; messages as we go. (setq n 1 retrieved-bytes 0) (setq statblob (vm-pop-start-status-timer)) (vm-set-pop-stat-x-box statblob popdrop) (vm-set-pop-stat-x-maxmsg statblob mailbox-count) (while (and (<= n mailbox-count) (or (not (natnump m-per-session)) (< retrieved m-per-session)) (or (not (natnump b-per-session)) (< retrieved-bytes b-per-session))) (catch 'skip (vm-set-pop-stat-x-currmsg statblob n) (if can-uidl (condition-case nil (let (list) (vm-pop-send-command process (format "UIDL %d" n)) (setq response (vm-pop-read-response process t)) (if (null response) (signal 'vm-cant-uidl nil)) (setq list (vm-parse response "\\([\041-\176]+\\) *") uidl (nth 2 list)) (if (null uidl) (signal 'vm-cant-uidl nil)) (setcar msgid uidl) (when (member msgid pop-retrieved-messages) (if vm-pop-ok-to-ask (vm-inform 6 "Skipping message %d (of %d) from %s (retrieved already)..." n mailbox-count popdrop)) (throw 'skip t))) (vm-cant-uidl ;; something failed, so UIDL must not be working. (if (and (not auto-expunge) (or (not vm-pop-ok-to-ask) (not (vm-pop-ask-about-no-uidl popdrop)))) (progn (vm-inform 0 "Skipping mailbox %s (no UIDL support)" popdrop) (throw 'done (not (equal retrieved 0)))) ;; user doesn't care, so go ahead and ;; expunge from the server (setq can-uidl nil msgid nil))))) (vm-pop-send-command process (format "LIST %d" n)) (setq message-size (vm-pop-read-list-response process)) (vm-set-pop-stat-x-need statblob message-size) (if (and (integerp vm-pop-max-message-size) (> message-size vm-pop-max-message-size) (progn (setq response (if vm-pop-ok-to-ask (vm-pop-ask-about-large-message process popdrop message-size n) 'skip)) (not (eq response 'retrieve)))) (progn (if (eq response 'delete) (progn (vm-inform 6 "Deleting message %d..." n) (vm-pop-send-command process (format "DELE %d" n)) (and (null (vm-pop-read-response process)) (throw 'done (not (equal retrieved 0))))) (if vm-pop-ok-to-ask (vm-inform 6 "Skipping message %d..." n) (vm-inform 5 "Skipping message %d in %s, too large (%d > %d)..." n popdrop message-size vm-pop-max-message-size))) (throw 'skip t))) (vm-inform 6 "Retrieving message %d (of %d) from %s..." n mailbox-count popdrop) (vm-pop-send-command process (format "RETR %d" n)) (and (null (vm-pop-read-response process)) (throw 'done (not (equal retrieved 0)))) (and (null (vm-pop-retrieve-to-target process destination statblob)) (throw 'done (not (equal retrieved 0)))) (vm-inform 6 "Retrieving message %d (of %d) from %s...done" n mailbox-count popdrop) (vm-increment retrieved) (and b-per-session (setq retrieved-bytes (+ retrieved-bytes message-size))) (if (and (not auto-expunge) msgid) (setq pop-retrieved-messages (cons (copy-sequence msgid) pop-retrieved-messages)) ;; Either the user doesn't want the messages ;; kept in the mailbox or there's no UIDL ;; support so there's no way to remember what ;; messages we've retrieved. Delete the ;; message now. (vm-pop-send-command process (format "DELE %d" n)) ;; DELE can't fail but Emacs or this code might ;; blow a gasket and spew filth down the ;; connection, so... (and (null (vm-pop-read-response process)) (throw 'done (not (equal retrieved 0)))))) (vm-increment n)) (not (equal retrieved 0)) )) (setq vm-pop-retrieved-messages pop-retrieved-messages) (if (and (eq vm-flush-interval t) (not (equal retrieved 0))) (vm-stuff-pop-retrieved)) (and statblob (vm-pop-stop-status-timer statblob)) (if process (vm-pop-end-session process))))) (defun vm-pop-check-mail (source) (let ((process nil) (handler (vm-find-file-name-handler source 'vm-pop-check-mail)) (retrieved vm-pop-retrieved-messages) (popdrop (vm-popdrop-sans-password source)) (count 0) x response) (unwind-protect (save-excursion (catch 'done (if handler (throw 'done (funcall handler 'vm-pop-check-mail source))) (setq process (vm-pop-make-session source)) (or process (throw 'done nil)) (set-buffer (process-buffer process)) (vm-pop-send-command process "UIDL") (setq response (vm-pop-read-uidl-long-response process)) (if (null response) ;; server doesn't understand UIDL nil (if (null (car response)) ;; (nil . nil) is returned if there are no ;; messages in the mailbox. (progn (vm-store-folder-totals source '(0 0 0 0)) (throw 'done nil)) (while response (if (not (and (setq x (assoc (cdr (car response)) retrieved)) (equal (nth 1 x) popdrop) (eq (nth 2 x) 'uidl))) (vm-increment count)) (setq response (cdr response)))) (vm-store-folder-totals source (list count 0 0 0)) (throw 'done (not (eq count 0)))) (vm-pop-send-command process "STAT") (setq response (vm-pop-read-stat-response process)) (if (null response) nil (vm-store-folder-totals source (list (car response) 0 0 0)) (not (equal 0 (car response)))))) (and process (vm-pop-end-session process nil vm-pop-ok-to-ask))))) ;;;###autoload (defun vm-expunge-pop-messages () "Deletes all messages from POP mailbox that have already been retrieved into the current folder. VM sends POP DELE commands to all the relevant POP servers to remove the messages." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-virtual-folder) (if (and (vm-interactive-p) (eq vm-folder-access-method 'pop)) (error "This command is not meant for POP folders. Use the normal folder expunge instead.")) (let ((process nil) (source nil) (trouble nil) (delete-count 0) (vm-global-block-new-mail t) (vm-pop-ok-to-ask t) popdrop uidl-alist data mp match) (unwind-protect (save-excursion (setq vm-pop-retrieved-messages (delq nil vm-pop-retrieved-messages)) (setq vm-pop-retrieved-messages (sort vm-pop-retrieved-messages (function (lambda (a b) (cond ((string-lessp (nth 1 a) (nth 1 b)) t) ((string-lessp (nth 1 b) (nth 1 a)) nil) ((string-lessp (car a) (car b)) t) (t nil)))))) (setq mp vm-pop-retrieved-messages) (while mp (condition-case nil (catch 'replay (setq data (car mp)) (if (not (equal source (nth 1 data))) (progn (if process (progn (vm-pop-end-session process) (setq process nil))) (setq source (nth 1 data)) (setq popdrop (or (vm-pop-find-name-for-spec source) (vm-safe-popdrop-string source))) (condition-case nil (progn (vm-inform 6 "Opening POP session to %s..." popdrop) (setq process (vm-pop-make-session source)) (if (null process) (signal 'error nil)) (vm-inform 6 "Expunging messages in %s..." popdrop)) (error (vm-warn 0 2 "Couldn't open POP session to %s, skipping..." popdrop) (setq trouble (cons popdrop trouble)) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t))) (set-buffer (process-buffer process)) (vm-pop-send-command process "UIDL") (setq uidl-alist (vm-pop-read-uidl-long-response process)) (if (null uidl-alist) (signal 'vm-uidl-failed nil)))) (if (setq match (rassoc (car data) uidl-alist)) (progn (vm-pop-send-command process (format "DELE %s" (car match))) (if (null (vm-pop-read-response process)) (signal 'vm-dele-failed nil)) (setcar mp nil) ; side effect!! (vm-increment delete-count))) (setq mp (cdr mp))) (vm-dele-failed (vm-warn 0 2 "DELE %s failed on %s, skipping rest of mailbox..." (car match) popdrop) (setq trouble (cons popdrop trouble)) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t)) (vm-uidl-failed (vm-warn 0 2 "UIDL %s failed on %s, skipping this mailbox..." (car match) popdrop) (setq trouble (cons popdrop trouble)) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t)))) (if trouble (progn (set-buffer (get-buffer-create "*POP Expunge Trouble*")) (setq buffer-read-only nil) (erase-buffer) (insert (format "%s POP message%s expunged.\n\n" (if (zerop delete-count) "No" delete-count) (if (= delete-count 1) "" "s"))) (insert "VM had problems expunging messages from:\n") (nreverse trouble) (setq mp trouble) (while mp (insert " " (car mp) "\n") (setq mp (cdr mp))) (setq buffer-read-only t) (display-buffer (current-buffer))) (vm-inform 5 "%s POP message%s expunged." (if (zerop delete-count) "No" delete-count) (if (= delete-count 1) "" "s")))) (and process (vm-pop-end-session process))) (setq vm-pop-retrieved-messages (delq nil vm-pop-retrieved-messages)))) (defun vm-pop-make-session (source) (let ((process-to-shutdown nil) process use-ssl use-ssh success (folder-type vm-folder-type) (popdrop (or (vm-pop-find-name-for-spec source) (vm-safe-popdrop-string source))) (coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system)) (session-name "POP") (process-connection-type nil) greeting timestamp ssh-process host port auth user pass authinfo source-list process-buffer source-nopwd) (unwind-protect (catch 'done ;; parse the maildrop (setq source-list (vm-pop-parse-spec-to-list source)) ;; remove pop or pop-ssl from beginning of list if ;; present. (when (= 6 (length source-list)) (cond ((equal "pop-ssl" (car source-list)) (setq use-ssl t session-name "POP over SSL") ;; (when (null vm-stunnel-program) ;; (error ;; "vm-stunnel-program must be non-nil to use POP over SSL.")) ) ((equal "pop-ssh" (car source-list)) (setq use-ssh t session-name "POP over SSH") (when (null vm-ssh-program) (error "vm-ssh-program must be non-nil to use POP over SSH.")))) (setq source-list (cdr source-list))) (setq host (nth 0 source-list) port (nth 1 source-list) auth (nth 2 source-list) user (nth 3 source-list) pass (nth 4 source-list) source-nopwd (vm-popdrop-sans-password source)) ;; carp if parts are missing (when (null host) (error "No host in POP maildrop specification, \"%s\"" source)) (when (null port) (error "No port in POP maildrop specification, \"%s\"" source)) (when (string-match "^[0-9]+$" port) (setq port (string-to-number port))) (when (null auth) (error "No authentication method in POP maildrop specification, \"%s\"" source)) (when (null user) (error "No user in POP maildrop specification, \"%s\"" source)) (when (null pass) (error "No password in POP maildrop specification, \"%s\"" source)) (when (equal pass "*") (setq pass (car (cdr (assoc source-nopwd vm-pop-passwords)))) (when (and (null pass) (boundp 'auth-sources) (fboundp 'auth-source-user-or-password)) (cond ((and (setq authinfo (auth-source-user-or-password '("login" "password") (vm-pop-find-name-for-spec source) port)) (equal user (car authinfo))) (setq pass (cadr authinfo))) ((and (setq authinfo (auth-source-user-or-password '("login" "password") host port)) (equal user (car authinfo))) (setq pass (cadr authinfo))))) (while (and (null pass) vm-pop-ok-to-ask) (setq pass (read-passwd (format "POP password for %s: " popdrop))) (when (equal pass "") (vm-warn 0 2 "Password cannot be empty") (setq pass nil))) (when (null pass) (vm-inform 0 "Need password for %s" popdrop) (throw 'done nil)) ;; get the trace buffer (setq process-buffer (vm-make-work-buffer (vm-make-trace-buffer-name session-name host))) (save-excursion (set-buffer process-buffer) (setq vm-folder-type (or folder-type vm-default-folder-type)) (buffer-disable-undo process-buffer) (make-local-variable 'vm-pop-read-point) ;; clear the trace buffer of old output (erase-buffer) ;; Tell MULE not to mess with the text. (when (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-binary-coding-system) t)) (insert "starting " session-name " session " (current-time-string) "\n") (insert (format "connecting to %s:%s\n" host port)) ;; open the connection to the server (cond (use-ssl (if (null vm-stunnel-program) (setq process (open-network-stream session-name process-buffer host port :type 'tls)) (vm-setup-stunnel-random-data-if-needed) (setq process (apply 'start-process session-name process-buffer vm-stunnel-program (nconc (vm-stunnel-configuration-args host port) vm-stunnel-program-switches))))) (use-ssh (setq process (open-network-stream session-name process-buffer "127.0.0.1" (vm-setup-ssh-tunnel host port)))) (t (setq process (open-network-stream session-name process-buffer host port)))) (and (null process) (throw 'done nil)) (insert-before-markers "connected\n") (setq vm-pop-read-point (point)) (vm-process-kill-without-query process) (when (null (setq greeting (vm-pop-read-response process t))) (delete-process process) (throw 'done nil)) (setq process-to-shutdown process) ;; authentication (cond ((equal auth "pass") (vm-pop-send-command process (format "USER %s" user)) (and (null (vm-pop-read-response process)) (throw 'done nil)) (vm-pop-send-command process (format "PASS %s" pass)) (unless (vm-pop-read-response process) (vm-warn 0 0 "POP password for %s incorrect" popdrop) (setq vm-pop-passwords (vm-delete (lambda (pair) (equal (car pair) source-nopwd)) vm-pop-passwords)) ;; don't sleep unless we're running synchronously. (when vm-pop-ok-to-ask (sleep-for 2)) (throw 'done nil)) (unless (assoc source-nopwd vm-pop-passwords) (setq vm-pop-passwords (cons (list source-nopwd pass) vm-pop-passwords))) (setq success t)) ((equal auth "rpop") (vm-pop-send-command process (format "USER %s" user)) (when (null (vm-pop-read-response process)) (throw 'done nil)) (vm-pop-send-command process (format "RPOP %s" pass)) (when (null (vm-pop-read-response process)) (throw 'done nil))) ((equal auth "apop") (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)") timestamp (car timestamp)) (when (null timestamp) (goto-char (point-max)) (insert-before-markers "<<< ooops, no timestamp found in greeting! >>>\n") (vm-warn 0 0 "Server of %s does not support APOP" popdrop) ;; don't sleep unless we're running synchronously (if vm-pop-ok-to-ask (sleep-for 2)) (throw 'done nil)) (vm-pop-send-command process (format "APOP %s %s" user (vm-pop-md5 (concat timestamp pass)))) (unless (vm-pop-read-response process) (vm-warn 0 0 "POP password for %s incorrect" popdrop) (when vm-pop-ok-to-ask (sleep-for 2)) (throw 'done nil)) (unless (assoc source-nopwd vm-pop-passwords) (setq vm-pop-passwords (cons (list source-nopwd pass) vm-pop-passwords))) (setq success t)) (t (error "Don't know how to authenticate using %s" auth))) (setq process-to-shutdown nil) ))) ;; unwind-protection (if process-to-shutdown (vm-pop-end-session process-to-shutdown t)) (vm-tear-down-stunnel-random-data)) (if success process ;; try again if possible (when vm-pop-ok-to-ask (vm-pop-make-session source))))) (defun vm-pop-end-session (process &optional keep-buffer verbose) "Kill the POP session represented by PROCESS. PROCESS could be nil or be already closed. If the optional argument KEEP-BUFFER is non-nil, the process buffer is retained, otherwise it is killed as well." (if (and process (memq (process-status process) '(open run)) (buffer-live-p (process-buffer process))) (save-excursion (set-buffer (process-buffer process)) (vm-pop-send-command process "QUIT") ;; Previously we did not read the QUIT response because of ;; TCP shutdown problems (under Windows?) that made it ;; better if we just closed the connection. Microsoft ;; Exchange apparently fails to expunge messages if we shut ;; down the connection without reading the QUIT response. ;; So we provide an option and let the user decide what ;; works best for them. (if vm-pop-read-quit-response (progn (and verbose (vm-inform 5 "Waiting for response to POP QUIT command...")) (vm-pop-read-response process) (and verbose (vm-inform 5 "Waiting for response to POP QUIT command... done")))))) (if (and (process-buffer process) (buffer-live-p (process-buffer process))) (if (and (null vm-pop-keep-trace-buffer) (not keep-buffer)) (kill-buffer (process-buffer process)) (vm-keep-some-buffers (process-buffer process) 'vm-kept-pop-buffers vm-pop-keep-trace-buffer "saved "))) (if (fboundp 'add-async-timeout) (add-async-timeout 2 'delete-process process) (run-at-time 2 nil 'delete-process process))) (defun vm-pop-stat-timer (o) (aref o 0)) (defun vm-pop-stat-did-report (o) (aref o 1)) (defun vm-pop-stat-x-box (o) (aref o 2)) (defun vm-pop-stat-x-currmsg (o) (aref o 3)) (defun vm-pop-stat-x-maxmsg (o) (aref o 4)) (defun vm-pop-stat-x-got (o) (aref o 5)) (defun vm-pop-stat-x-need (o) (aref o 6)) (defun vm-pop-stat-y-box (o) (aref o 7)) (defun vm-pop-stat-y-currmsg (o) (aref o 8)) (defun vm-pop-stat-y-maxmsg (o) (aref o 9)) (defun vm-pop-stat-y-got (o) (aref o 10)) (defun vm-pop-stat-y-need (o) (aref o 11)) (defun vm-set-pop-stat-timer (o val) (aset o 0 val)) (defun vm-set-pop-stat-did-report (o val) (aset o 1 val)) (defun vm-set-pop-stat-x-box (o val) (aset o 2 val)) (defun vm-set-pop-stat-x-currmsg (o val) (aset o 3 val)) (defun vm-set-pop-stat-x-maxmsg (o val) (aset o 4 val)) (defun vm-set-pop-stat-x-got (o val) (aset o 5 val)) (defun vm-set-pop-stat-x-need (o val) (aset o 6 val)) (defun vm-set-pop-stat-y-box (o val) (aset o 7 val)) (defun vm-set-pop-stat-y-currmsg (o val) (aset o 8 val)) (defun vm-set-pop-stat-y-maxmsg (o val) (aset o 9 val)) (defun vm-set-pop-stat-y-got (o val) (aset o 10 val)) (defun vm-set-pop-stat-y-need (o val) (aset o 11 val)) (defun vm-pop-start-status-timer () (let ((blob (make-vector 12 nil)) timer) (setq timer (add-timeout 5 'vm-pop-report-retrieval-status blob 5)) (vm-set-pop-stat-timer blob timer) blob )) (defun vm-pop-stop-status-timer (status-blob) (if (vm-pop-stat-did-report status-blob) (vm-inform 5 "")) (if (fboundp 'disable-timeout) (disable-timeout (vm-pop-stat-timer status-blob)) (cancel-timer (vm-pop-stat-timer status-blob)))) (defun vm-pop-report-retrieval-status (o) (vm-set-pop-stat-did-report o t) (cond ((null (vm-pop-stat-x-got o)) t) ;; should not be possible, but better safe... ((not (eq (vm-pop-stat-x-box o) (vm-pop-stat-y-box o))) t) ((not (eq (vm-pop-stat-x-currmsg o) (vm-pop-stat-y-currmsg o))) t) (t (vm-inform 6 "Retrieving message %d (of %d) from %s, %s..." (vm-pop-stat-x-currmsg o) (vm-pop-stat-x-maxmsg o) (vm-pop-stat-x-box o) (if (vm-pop-stat-x-need o) (format "%d%s of %d%s" (vm-pop-stat-x-got o) (if (> (vm-pop-stat-x-got o) (vm-pop-stat-x-need o)) "!" "") (vm-pop-stat-x-need o) (if (eq (vm-pop-stat-x-got o) (vm-pop-stat-y-got o)) " (stalled)" "")) "post processing")))) (vm-set-pop-stat-y-box o (vm-pop-stat-x-box o)) (vm-set-pop-stat-y-currmsg o (vm-pop-stat-x-currmsg o)) (vm-set-pop-stat-y-maxmsg o (vm-pop-stat-x-maxmsg o)) (vm-set-pop-stat-y-got o (vm-pop-stat-x-got o)) (vm-set-pop-stat-y-need o (vm-pop-stat-x-need o))) (defun vm-pop-check-connection (process) (cond ((not (memq (process-status process) '(open run))) (error "POP connection not open: %s" process)) ((not (buffer-live-p (process-buffer process))) (error "POP process %s's buffer has been killed" process)))) (defun vm-pop-send-command (process command) (vm-pop-check-connection process) (goto-char (point-max)) (if (= (aref command 0) ?P) (insert-before-markers "PASS \r\n") (insert-before-markers command "\r\n")) (setq vm-pop-read-point (point)) (process-send-string process (format "%s\r\n" command))) (defun vm-pop-read-response (process &optional return-response-string) (vm-pop-check-connection process) (let ((case-fold-search nil) match-end) (goto-char vm-pop-read-point) (while (not (search-forward "\r\n" nil t)) (vm-pop-check-connection process) (accept-process-output process) (goto-char vm-pop-read-point)) (setq match-end (point)) (goto-char vm-pop-read-point) (if (not (looking-at "+OK")) (progn (setq vm-pop-read-point match-end) nil) (setq vm-pop-read-point match-end) (if return-response-string (buffer-substring (point) match-end) t )))) (defun vm-pop-read-past-dot-sentinel-line (process) (vm-pop-check-connection process) (let ((case-fold-search nil)) (goto-char vm-pop-read-point) (while (not (re-search-forward "^\\.\r\n" nil 0)) (beginning-of-line) ;; save-excursion doesn't work right (let ((opoint (point))) (vm-pop-check-connection process) (accept-process-output process) (goto-char opoint))) (setq vm-pop-read-point (point)))) (defun vm-pop-read-stat-response (process) (let ((response (vm-pop-read-response process t)) list) (if (null response) nil (setq list (vm-parse response "\\([^ ]+\\) *")) (list (string-to-number (nth 1 list)) (string-to-number (nth 2 list)))))) (defun vm-pop-read-list-response (process) (let ((response (vm-pop-read-response process t))) (and response (string-to-number (nth 2 (vm-parse response "\\([^ ]+\\) *")))))) (defun vm-pop-read-uidl-long-response (process) (vm-pop-check-connection process) (let ((start vm-pop-read-point) (list nil) n uidl) (catch 'done (goto-char start) (while (not (re-search-forward "^\\.\r\n\\|^-ERR .*$" nil 0)) (beginning-of-line) ;; save-excursion doesn't work right (let ((opoint (point))) (vm-pop-check-connection process) (accept-process-output process) (goto-char opoint))) (setq vm-pop-read-point (point-marker)) (goto-char start) ;; no uidl support, bail. (if (not (looking-at "\\+OK")) (throw 'done nil)) (forward-line 1) (while (not (eq (char-after (point)) ?.)) ;; not loking at a number, bail. (if (not (looking-at "[0-9]")) (throw 'done nil)) (setq n (int-to-string (read (current-buffer)))) (skip-chars-forward " ") (setq start (point)) (skip-chars-forward "\041-\176") ;; no tag after the message number, bail. (if (= start (point)) (throw 'done nil)) (setq uidl (buffer-substring start (point))) (setq list (cons (cons n uidl) list)) (forward-line 1)) ;; returning nil means the uidl command failed so don't ;; return nil if there aren't any messages. (if (null list) (cons nil nil) list )))) (defun vm-pop-ask-about-large-message (process popdrop size n) (let ((work-buffer nil) (pop-buffer (current-buffer)) start end) (unwind-protect (save-excursion (save-window-excursion (vm-pop-send-command process (format "TOP %d %d" n 0)) (if (vm-pop-read-response process) (progn (setq start vm-pop-read-point) (vm-pop-read-past-dot-sentinel-line process) (setq end vm-pop-read-point) (setq work-buffer (generate-new-buffer (format "*headers of %s message %d*" popdrop n))) (set-buffer work-buffer) (insert-buffer-substring pop-buffer start end) (forward-line -1) (delete-region (point) (point-max)) (vm-pop-cleanup-region (point-min) (point-max)) (vm-display-buffer work-buffer) (setq minibuffer-scroll-window (selected-window)) (goto-char (point-min)) (if (re-search-forward "^Received:" nil t) (progn (goto-char (match-beginning 0)) (vm-reorder-message-headers nil :keep-list vm-visible-headers :discard-regexp vm-invisible-header-regexp))) (set-window-point (selected-window) (point)))) (if (y-or-n-p (format "Retrieve message %d (size = %d)? " n size)) 'retrieve (if (y-or-n-p (format "Delete message %d from popdrop? " n)) 'delete 'skip)))) (and work-buffer (kill-buffer work-buffer))))) (defun vm-pop-ask-about-no-uidl (popdrop) (let ((work-buffer nil) (pop-buffer (current-buffer)) start end) (unwind-protect (save-excursion (save-window-excursion (setq work-buffer (generate-new-buffer (format "*trouble with %s*" popdrop))) (set-buffer work-buffer) (insert "You have asked VM to leave messages on the server for the POP mailbox " popdrop ". VM cannot do so because the server does not seem to support the POP UIDL command.\n\nYou can either continue to retrieve messages from this mailbox with VM deleting the messages from the server, or you can skip this mailbox, leaving messages on the server and not retrieving any messages.") (fill-individual-paragraphs (point-min) (point-max)) (vm-display-buffer work-buffer) (setq minibuffer-scroll-window (selected-window)) (yes-or-no-p "Continue retrieving anyway? "))) (and work-buffer (kill-buffer work-buffer))))) (defun vm-pop-retrieve-to-target (process target statblob) (vm-pop-check-connection process) (let ((start vm-pop-read-point) end) (goto-char start) (vm-set-pop-stat-x-got statblob 0) (while (not (re-search-forward "^\\.\r\n" nil 0)) (beginning-of-line) ;; save-excursion doesn't work right (let* ((opoint (point)) (func (function (lambda (beg end len) (if vm-pop-read-point (progn (vm-set-pop-stat-x-got statblob (- end start)) (if (zerop (% (random) 10)) (vm-pop-report-retrieval-status statblob))))))) (after-change-functions (cons func after-change-functions))) (vm-pop-check-connection process) (accept-process-output process) (goto-char opoint))) (vm-set-pop-stat-x-need statblob nil) (setq vm-pop-read-point (point-marker)) (goto-char (match-beginning 0)) (setq end (point-marker)) (vm-pop-cleanup-region start end) (vm-set-pop-stat-x-got statblob nil) ;; Some POP servers strip leading and trailing message ;; separators, some don't. Figure out what kind we're ;; talking to and do the right thing. (if (eq (vm-get-folder-type nil start end) 'unknown) (progn (vm-munge-message-separators vm-folder-type start end) (goto-char start) ;; avoid the consing and stat() call for all but babyl ;; files, since this will probably slow things down. ;; only babyl files have the folder header, and we ;; should only insert it if the target folder is empty. (if (and (eq vm-folder-type 'babyl) (cond ((stringp target) (let ((attrs (file-attributes target))) (or (null attrs) (equal 0 (nth 7 attrs))))) ((bufferp target) (save-excursion (set-buffer target) (zerop (buffer-size)))))) (let ((opoint (point))) (vm-convert-folder-header nil vm-folder-type) ;; if start is a marker, then it was moved ;; forward by the insertion. restore it. (setq start opoint) (goto-char start) (vm-skip-past-folder-header))) (insert (vm-leading-message-separator)) (save-restriction (narrow-to-region (point) end) (vm-convert-folder-type-headers 'baremessage vm-folder-type)) (goto-char end) (insert-before-markers (vm-trailing-message-separator)))) (if (stringp target) ;; Set file type to binary for DOS/Windows. I don't know if ;; this is correct to do or not; it depends on whether the ;; the CRLF or the LF newline convention is used on the inbox ;; associated with this crashbox. This setting assumes the LF ;; newline convention is used. (let ((buffer-file-type t) (selective-display nil)) (write-region start end target t 0)) (let ((b (current-buffer))) (save-excursion (set-buffer target) (let ((buffer-read-only nil)) (insert-buffer-substring b start end))))) (delete-region start end) t )) (defun vm-pop-cleanup-region (start end) (setq end (vm-marker end)) (save-excursion ;; CRLF -> LF (if vm-xemacs-mule-p (progn ;; we need this otherwise the end marker gets corrupt and ;; unfortunately decode-coding-region does not return the ;; length to the decoded region (decode-coding-region start (1- end) 'undecided-dos) (goto-char (- end 2)) (delete-char 1)) (goto-char start) (while (and (< (point) end) (search-forward "\r\n" end t)) (replace-match "\n" t t))) ;; chop leading dots (goto-char start) (while (and (< (point) end) (re-search-forward "^\\." end t)) (replace-match "" t t) (forward-char))) (set-marker end nil)) (defun vm-establish-new-folder-pop-session (&optional interactive) (let ((process (vm-folder-pop-process)) (vm-pop-ok-to-ask interactive)) (if (processp process) (vm-pop-end-session process)) (setq process (vm-pop-make-session (vm-folder-pop-maildrop-spec))) (vm-set-folder-pop-process process) process )) (defun vm-pop-get-uidl-data () (let ((there (make-vector 67 0)) (process (vm-folder-pop-process))) (save-excursion (set-buffer (process-buffer process)) (vm-pop-send-command process "UIDL") (let ((start vm-pop-read-point) n uidl) (catch 'done (goto-char start) (while (not (re-search-forward "^\\.\r\n\\|^-ERR .*$" nil 0)) (beginning-of-line) ;; save-excursion doesn't work right (let ((opoint (point))) (vm-pop-check-connection process) (accept-process-output process) (goto-char opoint))) (setq vm-pop-read-point (point-marker)) (goto-char start) ;; no uidl support, bail. (if (not (looking-at "\\+OK")) (throw 'done nil)) (forward-line 1) (while (not (eq (char-after (point)) ?.)) ;; not loking at a number, bail. (if (not (looking-at "[0-9]")) (throw 'done nil)) (setq n (int-to-string (read (current-buffer)))) (skip-chars-forward " ") (setq start (point)) (skip-chars-forward "\041-\176") ;; no tag after the message number, bail. (if (= start (point)) (throw 'done nil)) (setq uidl (buffer-substring start (point))) (set (intern uidl there) n) (forward-line 1)) there ))))) (defun vm-pop-get-synchronization-data () (let ((here (make-vector 67 0)) (there (vm-pop-get-uidl-data)) (process (vm-folder-pop-process)) retrieve-list expunge-list mp) (setq mp vm-message-list) (while mp (if (null (vm-pop-uidl-of (car mp))) nil (set (intern (vm-pop-uidl-of (car mp)) here) (car mp)) (if (not (boundp (intern (vm-pop-uidl-of (car mp)) there))) (setq expunge-list (cons (car mp) expunge-list)))) (setq mp (cdr mp))) (mapatoms (function (lambda (sym) (if (and (not (boundp (intern (symbol-name sym) here))) (not (assoc (symbol-name sym) vm-pop-retrieved-messages))) (setq retrieve-list (cons (cons (symbol-name sym) (symbol-value sym)) retrieve-list))))) there) (list retrieve-list expunge-list))) ;;;###autoload (defun* vm-pop-synchronize-folder (&optional &key (interactive nil) (do-remote-expunges nil) (do-local-expunges nil) (do-retrieves nil)) (if (and do-retrieves vm-block-new-mail) (error "Can't get new mail until you save this folder.")) (if (or vm-global-block-new-mail (null (vm-establish-new-folder-pop-session interactive))) nil (if do-retrieves (vm-assimilate-new-messages)) (let* ((sync-data (vm-pop-get-synchronization-data)) (retrieve-list (car sync-data)) (local-expunge-list (nth 1 sync-data)) (process (vm-folder-pop-process)) (n 1) (statblob nil) (popdrop (vm-folder-pop-maildrop-spec)) (safe-popdrop (or (vm-pop-find-name-for-spec popdrop) (vm-safe-popdrop-string popdrop))) r-list mp got-some message-size (folder-buffer (current-buffer))) (if (and do-retrieves retrieve-list) (save-excursion (vm-save-restriction (widen) (goto-char (point-max)) (condition-case error-data (save-excursion (set-buffer (process-buffer process)) (setq statblob (vm-pop-start-status-timer)) (vm-set-pop-stat-x-box statblob safe-popdrop) (vm-set-pop-stat-x-maxmsg statblob (length retrieve-list)) (setq r-list retrieve-list) (while r-list (vm-set-pop-stat-x-currmsg statblob n) (vm-pop-send-command process (format "LIST %s" (cdr (car r-list)))) (setq message-size (vm-pop-read-list-response process)) (vm-set-pop-stat-x-need statblob message-size) (vm-pop-send-command process (format "RETR %s" (cdr (car r-list)))) (and (null (vm-pop-read-response process)) (error "server didn't say +OK to RETR %s command" (cdr (car r-list)))) (vm-pop-retrieve-to-target process folder-buffer statblob) (setq r-list (cdr r-list) n (1+ n)))) (error (vm-warn 0 2 "Retrieval from %s signaled: %s" safe-popdrop error-data)) (quit (vm-inform 0 "Quit received during retrieval from %s" safe-popdrop))) (and statblob (vm-pop-stop-status-timer statblob)) ;; to make the "Mail" indicator go away (setq vm-spooled-mail-waiting nil) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) (setq mp (vm-assimilate-new-messages :read-attributes nil)) (setq got-some mp) (if got-some (vm-increment vm-modification-counter)) (setq r-list retrieve-list) (while mp (vm-set-pop-uidl-of (car mp) (car (car r-list))) (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp) r-list (cdr r-list)))))) (if do-local-expunges (vm-expunge-folder :quiet t :just-these-messages local-expunge-list)) (if (and do-remote-expunges vm-pop-messages-to-expunge) (let ((process (vm-folder-pop-process))) ;; POP servers usually allow only one remote accessor ;; at a time vm-expunge-pop-messages will set up its ;; own connection so we get out of its way by closing ;; our connection. (if (and (processp process) (memq (process-status process) '(open run))) (vm-pop-end-session process)) (setq vm-pop-retrieved-messages (mapcar (function (lambda (x) (list x popdrop 'uidl))) vm-pop-messages-to-expunge)) (vm-expunge-pop-messages) ;; Any messages that could not be expunged will be ;; remembered for future (setq vm-pop-messages-to-expunge (mapcar (function (lambda (x) (car x))) vm-pop-retrieved-messages)))) got-some))) ;;;###autoload (defun vm-pop-folder-check-mail (&optional interactive) "Check if there is new mail on the POP server for the current POP folder. Optional argument INTERACTIVE says whether this function is being called from an interactive use of a command." (if (or vm-global-block-new-mail (null (vm-establish-new-folder-pop-session interactive))) nil (let ((result (car (vm-pop-get-synchronization-data)))) (vm-pop-end-session (vm-folder-pop-process)) result ))) (defalias 'vm-pop-folder-check-for-mail 'vm-pop-folder-check-mail) (make-obsolete 'vm-pop-folder-check-for-mail 'vm-pop-folder-check-mail "8.2.0") ;;;###autoload (defun vm-pop-find-spec-for-name (name) "Returns the full maildrop specification of a short name NAME." (let ((list vm-pop-folder-alist) (done nil)) (while (and (not done) list) (if (equal name (nth 1 (car list))) (setq done t) (setq list (cdr list)))) (and list (car (car list))))) ;;;###autoload (defun vm-pop-find-name-for-spec (spec) "Returns the short name of a POP maildrop specification SPEC." (let ((list vm-pop-folder-alist) (done nil)) (while (and (not done) list) (if (equal spec (car (car list))) (setq done t) (setq list (cdr list)))) (and list (nth 1 (car list))))) ;;;###autoload (defun vm-pop-find-name-for-buffer (buffer) (let ((list vm-pop-folder-alist) (done nil)) (while (and (not done) list) (if (eq buffer (vm-get-file-buffer (vm-pop-make-filename-for-spec (car (car list))))) (setq done t) (setq list (cdr list)))) (and list (nth 1 (car list))))) ;;;###autoload (defun vm-pop-make-filename-for-spec (spec &optional scrub-password scrub-spec) "Returns a cache file name appropriate for the POP maildrop specification SPEC." (let (md5 list) (if (and (null scrub-password) (null scrub-spec)) nil (setq list (vm-pop-parse-spec-to-list spec)) (setcar (vm-last list) "*") ; scrub password (if scrub-spec (progn (cond ((= (length list) 6) (setcar list "pop") ; standardise protocol name (setcar (nthcdr 2 list) "*") ; scrub port number (setcar (nthcdr 3 list) "*")) ; scrub auth method (t (setq list (cons "pop" list)) (setcar (nthcdr 2 list) "*") (setcar (nthcdr 3 list) "*"))))) (setq spec (mapconcat (function identity) list ":"))) (setq md5 (vm-md5-string spec)) (expand-file-name (concat "pop-cache-" md5) (or vm-pop-folder-cache-directory vm-folder-directory (getenv "HOME"))))) (defun vm-pop-parse-spec-to-list (spec) (if (string-match "\\(pop\\|pop-ssh\\|pop-ssl\\)" spec) (vm-parse spec "\\([^:]+\\):?" 1 5) (vm-parse spec "\\([^:]+\\):?" 1 4))) (defun vm-pop-start-bug-report () "Begin to compose a bug report for POP support functionality." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq vm-kept-pop-buffers nil) (setq vm-pop-keep-trace-buffer 20)) (defun vm-pop-submit-bug-report () "Submit a bug report for VM's POP support functionality. It is necessary to run vm-pop-start-bug-report before the problem occurrence and this command after the problem occurrence, in order to capture the trace of POP sessions during the occurrence." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (or vm-pop-keep-trace-buffer (y-or-n-p "Did you run vm-pop-start-bug-report earlier? ")) (vm-inform 5 "Thank you. Preparing the bug report... ") (vm-inform 1 "Consider running vm-pop-start-bug-report before the problem occurrence")) (let ((process (vm-folder-pop-process))) (if process (vm-pop-end-session process))) (let ((trace-buffer-hook (lambda () (let ((bufs vm-kept-pop-buffers) buf) (insert "\n\n") (insert "POP Trace buffers - most recent first\n\n") (while bufs (setq buf (car bufs)) (insert "----") (insert (format "%s" buf)) (insert "----------\n") (insert (save-excursion (set-buffer buf) (buffer-string))) (setq bufs (cdr bufs))) (insert "--------------------------------------------------\n")) ))) (vm-submit-bug-report nil (list trace-buffer-hook)) )) (defun vm-pop-set-default-attributes (m) (vm-set-headers-to-be-retrieved-of m nil) (vm-set-body-to-be-retrieved-of m nil) (vm-set-body-to-be-discarded-of m nil)) ;;; vm-pop.el ends here vm-8.2.0b/lisp/vm-macro.el0000755000175000017500000002451511676442160015612 0ustar srivastasrivasta;;; vm-macro.el --- Random VM macros ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-macro) ;; Definitions for things that aren't in all Emacsen and that we really ;; prefer not to live without. (eval-and-compile (if (fboundp 'unless) nil (defmacro unless (bool &rest forms) `(if ,bool nil ,@forms)) (defmacro when (bool &rest forms) `(if ,bool (progn ,@forms)))) (unless (fboundp 'save-current-buffer) (defalias 'save-current-buffer 'save-excursion)) (if (fboundp 'mapc) (defalias 'bbdb-mapc 'mapc) (defalias 'bbdb-mapc 'mapcar)) ) (unless (fboundp 'with-current-buffer) (defmacro with-current-buffer (buf &rest body) `(save-current-buffer (set-buffer ,buf) ,@body))) (unless (fboundp 'defvaralias) (defmacro defvaralias (&rest args))) (unless (fboundp 'declare-function) (defmacro declare-function (fn file &optional arglist fileonly))) (declare-function vm-check-for-killed-summary "vm-misc" ()) (declare-function vm-check-for-killed-presentation "vm-misc" ()) (declare-function vm-error-if-folder-empty "vm-misc" ()) (declare-function vm-build-threads "vm-thread" (message-list)) (defmacro vm-add-to-list (elem list) "Like add-to-list, but compares elements by `eq' rather than `equal'." `(if (not (memq ,elem ,list)) (setq ,list (cons ,elem ,list)))) (defsubst vm-sit-for (seconds &optional nodisplay) "Like sit-for, but has no effect if display-hourglass is set to t. Otherwise, the hourglass would be displayed while sit-for happens." (unless (and (boundp 'display-hourglass) display-hourglass) (sit-for seconds nodisplay))) (defsubst vm-marker (pos &optional buffer) (set-marker (make-marker) pos buffer)) (defsubst vm-pop-folder-spec-p (folder) (and vm-recognize-pop-maildrops (string-match vm-recognize-pop-maildrops folder))) (defsubst vm-imap-folder-spec-p (folder) (and vm-recognize-imap-maildrops (string-match vm-recognize-imap-maildrops folder))) (defsubst vm-select-folder-buffer () "Select the folder buffer corresponding to the current buffer (which could be Summary or Presentation). Gives an error message if there isn't a folder buffer. USR, 2010-03-08" (cond (vm-mail-buffer (or (buffer-name vm-mail-buffer) (error "Folder buffer has been killed.")) (set-buffer vm-mail-buffer)) ((not (memq major-mode '(vm-mode vm-virtual-mode))) (error "No VM folder buffer associated with this buffer"))) ;;-------------------------- ;; This may be problematic - done in revno 570. ;; All kinds of operations call vm-select-folder-buffer, including ;; asynchronous things like the toolbar. ;; (vm-buffer-type:set 'folder) ;;-------------------------- ) (defsubst vm-select-folder-buffer-if-possible () "Select the folder buffer corresponding to the current buffer (which could be Summary or Presentation). Returns normally if there isn't a folder buffer. USR, 2010-03-08" (cond ((and (bufferp vm-mail-buffer) (buffer-name vm-mail-buffer)) (set-buffer vm-mail-buffer) ;;-------------------------- ;; This may be problematic - done in revno 570. ;; (vm-buffer-type:set 'folder) ;;-------------------------- ) ((memq major-mode '(vm-mode vm-virtual-mode)) ;;-------------------------- ;; This may be problematic - done in revno 570. ;; (vm-buffer-type:set 'folder) ;;-------------------------- ))) (defsubst vm-select-folder-buffer-and-validate (&optional minimum interactive-p) "Select the folder buffer corresponding to the current buffer (which could be Summary or Presentation) and make sure that it has valid references to Summary and Presentation buffers. If optional argument MINIMUM is 1, the folder should be nonempty as well. If INTERACTIVE-p is t, then it also records the current-buffer in `vm-user-interaction-buffer'." (when interactive-p (setq vm-user-interaction-buffer (current-buffer))) (cond (vm-mail-buffer (or (buffer-name vm-mail-buffer) (error "Folder buffer has been killed.")) (set-buffer vm-mail-buffer)) ((not (memq major-mode '(vm-mode vm-virtual-mode))) (error "No VM folder buffer associated with this buffer"))) ;;-------------------------- ;; This may be problematic - done in revno 570. ;; (vm-buffer-type:set 'folder) ;;-------------------------- (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (if (and minimum (= minimum 1)) (vm-error-if-folder-empty)) ) (defsubst vm-error-if-folder-read-only () (while vm-folder-read-only (signal 'folder-read-only (list (current-buffer))))) (defsubst vm-error-if-virtual-folder () (and (eq major-mode 'vm-virtual-mode) (error "%s cannot be applied to virtual folders." this-command))) (defsubst vm-summary-operation-p () (and vm-summary-buffer (eq vm-summary-buffer vm-user-interaction-buffer))) (defsubst vm-build-threads-if-unbuilt () (if (not (vectorp vm-thread-obarray)) (vm-build-threads nil))) (defsubst vm-binary-coding-system () (cond (vm-xemacs-mule-p 'binary) (vm-xemacs-file-coding-p 'binary) (t 'no-conversion))) (defsubst vm-line-ending-coding-system () (cond (vm-xemacs-mule-p 'no-conversion) (vm-xemacs-file-coding-p 'no-conversion) (t 'raw-text))) ;;; can't use defsubst where quoting is needed in some places but ;; not others. ;; save-restriction flubs restoring the clipping region if you ;; (widen) and modify text outside the old region. ;; This should do it right. (defmacro vm-save-restriction (&rest forms) (let ((vm-sr-clip (make-symbol "vm-sr-clip")) (vm-sr-min (make-symbol "vm-sr-min")) (vm-sr-max (make-symbol "vm-sr-max"))) `(let ((,vm-sr-clip (> (buffer-size) (- (point-max) (point-min)))) ;; this shouldn't be necessary but the ;; byte-compiler turns these into interned symbols ;; which utterly defeats the purpose of the ;; make-symbol calls above. Soooo, until the compiler ;; is fixed, these must be made into (let ...) ;; temporaries so that nested calls to this macros ;; won't misbehave. ,vm-sr-min ,vm-sr-max) (and ,vm-sr-clip (setq ,vm-sr-min (set-marker (make-marker) (point-min))) (setq ,vm-sr-max (set-marker (make-marker) (point-max)))) (unwind-protect (progn ,@forms) (widen) (and ,vm-sr-clip (progn (narrow-to-region ,vm-sr-min ,vm-sr-max) (set-marker ,vm-sr-min nil) (set-marker ,vm-sr-max nil))))))) (put 'vm-save-restriction 'edebug-form-spec t) (defmacro vm-save-buffer-excursion (&rest forms) `(let ((vm-sbe-buffer (current-buffer))) (unwind-protect (progn ,@forms) (and (not (eq vm-sbe-buffer (current-buffer))) (buffer-name vm-sbe-buffer) (set-buffer vm-sbe-buffer))))) (put 'vm-save-buffer-excursion 'edebug-form-spec t) (defmacro vm-assert (expression) (list 'or 'vm-assertion-checking-off (list 'or expression (list 'let (list (list 'debug-on-error t)) (list 'error "assertion failed: %S" (list 'quote expression)))))) (defmacro vm-increment (variable) (list 'setq variable (list '1+ variable))) (defmacro vm-decrement (variable) (list 'setq variable (list '1- variable))) ;; This should be turned into a defsubst eventually (defun vm-make-trace-buffer-name (session-name host) (format "trace of %s session to %s at %s" session-name host (substring (current-time-string) 11 19))) ;; For verification of the correct buffer protocol ;; Possible values are 'folder, 'presentation, 'summary, 'process ;; (defvar vm-buffer-types nil) ; moved to vm-vars.el (defvar vm-buffer-type-debug nil "*This flag can be set to t for debugging asynchronous buffer change errors.") (defvar vm-buffer-type-debug nil) ; for debugging asynchronous ; buffer change errors (defvar vm-buffer-type-trail nil "List of VM buffer types entered and exited, used for debugging purposes.") (defsubst vm-buffer-type:enter (type) "Note that vm is temporarily entering a buffer of TYPE." (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons type (cons 'enter vm-buffer-type-trail)))) (setq vm-buffer-types (cons type vm-buffer-types))) (defsubst vm-buffer-type:exit () "Note that vm is exiting the current temporary buffer." (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'exit vm-buffer-type-trail))) (setq vm-buffer-types (cdr vm-buffer-types))) (defsubst vm-buffer-type:duplicate () "Note that vm is reentering the current buffer for a temporary purpose." (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons (car vm-buffer-type-trail) vm-buffer-type-trail))) (setq vm-buffer-types (cons (car vm-buffer-types) vm-buffer-types))) (defun vm-buffer-type:set (type) "Note that vm is changing to a buffer of TYPE." (when (and (eq type 'folder) vm-buffer-types (eq (car vm-buffer-types) 'process)) ;; This may or may not be a problem. ;; It just means that no save-excursion was done among the ;; functions currently tracked by vm-buffe-types. (if vm-buffer-type-debug (debug "folder buffer being entered from %s" (car vm-buffer-types)) (message "folder buffer being entered from %s" (car vm-buffer-types))) (setq vm-buffer-type-trail (cons type vm-buffer-type-trail))) (if vm-buffer-types (rplaca vm-buffer-types type) (setq vm-buffer-types (cons type vm-buffer-types)))) (defsubst vm-buffer-type:assert (type) "Check that vm is currently in a buffer of TYPE." (vm-assert (eq (car vm-buffer-types) type))) (defsubst vm-buffer-type:wait-for-imap-session () "Wait until the IMAP session is free to use, based on the vm-buffer-types stack." (while (and vm-buffer-types (eq (car vm-buffer-types) 'process)) (sleep-for 1))) ;;; vm-macro.el ends here vm-8.2.0b/lisp/vm-delete.el0000755000175000017500000005236511676442160015757 0ustar srivastasrivasta;;; vm-delete.el --- Delete and expunge commands for VM. ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-delete) (eval-when-compile (require 'vm-misc) (require 'vm-summary) (require 'vm-folder) (require 'vm-crypto) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-sort) (require 'vm-thread) (require 'vm-pop) (require 'vm-imap) ) ;;;###autoload (defun vm-delete-message (count &optional mlist) "Add the `deleted' attribute to the current message. The message will be physically deleted from the current folder the next time the current folder is expunged. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are deleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are deleted, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are deleted." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (del-count 0)) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Delete"))) (while mlist (unless (vm-deleted-flag (car mlist)) (when (vm-set-deleted-flag (car mlist) t) (vm-increment del-count) ;; The following is a temporary fix. To be absorted into ;; vm-update-summary-and-mode-line eventually. (when (and vm-summary-enable-thread-folding vm-summary-show-threads ;; (not (and vm-enable-thread-operations ;; (eq count 1))) (> (vm-thread-count (car mlist)) 1)) (with-current-buffer vm-summary-buffer (vm-expand-thread (vm-thread-root (car mlist))))))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-delete-message vm-delete-message-backward) (list this-command)) (when (vm-interactive-p) (if (zerop del-count) (vm-inform 5 "No messages deleted") (vm-inform 5 "%d message%s deleted" del-count (if (= 1 del-count) "" "s")))) (vm-update-summary-and-mode-line) (if (and vm-move-after-deleting (not used-marks)) (let ((vm-circular-folders (and vm-circular-folders (eq vm-move-after-deleting t)))) (vm-next-message count t executing-kbd-macro))))) ;;;###autoload (defun vm-delete-message-backward (count) "Like vm-delete-message, except the deletion direction is reversed." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-delete-message (- count))) ;;;###autoload (defun vm-undelete-message (count) "Remove the `deleted' attribute from the current message. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are undeleted. A negative argument means the current message and the previous |COUNT| - 1 messages are deleted. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are undeleted, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are undeleted." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist (vm-select-operable-messages count (vm-interactive-p) "Undelete")) (undel-count 0)) (while mlist (if (vm-deleted-flag (car mlist)) (if (vm-set-deleted-flag (car mlist) nil) (vm-increment undel-count))) (setq mlist (cdr mlist))) (if (and used-marks (vm-interactive-p)) (if (zerop undel-count) (vm-inform 5 "No messages undeleted") (vm-inform 5 "%d message%s undeleted" undel-count (if (= 1 undel-count) "" "s")))) (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message)) (vm-update-summary-and-mode-line) (if (and vm-move-after-undeleting (not used-marks)) (let ((vm-circular-folders (and vm-circular-folders (eq vm-move-after-undeleting t)))) (vm-next-message count t executing-kbd-macro))))) ;;;###autoload (defun vm-toggle-flag-message (count &optional mlist) "Toggle the `flagged' attribute to the current message, i.e., if it has not been flagged then it will be flagged and, if it is already flagged, then it will be unflagged. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are flagged/unflagged. A negative argument means the current message and the previous |COUNT| - 1 messages are flagged/unflagged. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are flagged/unflagged, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are flagged/unflagged." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (flagged-count 0) (new-flagged nil)) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Flag/unflag"))) (when mlist (setq new-flagged (not (vm-flagged-flag (car mlist))))) (while mlist (when (vm-set-flagged-flag (car mlist) new-flagged) (vm-increment flagged-count) ;; The following is a temporary fix. To be absorted into ;; vm-update-summary-and-mode-line eventually. (when (and vm-summary-enable-thread-folding vm-summary-show-threads ;; (not (and vm-enable-thread-operations ;; (eq count 1))) (> (vm-thread-count (car mlist)) 1)) (with-current-buffer vm-summary-buffer (vm-expand-thread (vm-thread-root (car mlist)))))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-toggle-flag-message) (list this-command)) (if (and used-marks (vm-interactive-p)) (if (zerop flagged-count) (vm-inform 5 "No messages flagged/unflagged") (vm-inform 5 "%d message%s %sflagged" flagged-count (if (= 1 flagged-count) "" "s") (if new-flagged "" "un")))) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-kill-subject (&optional arg) "Delete all messages with the same subject as the current message. Message subjects are compared after ignoring parts matched by the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix. The optional prefix argument ARG specifies the direction to move if vm-move-after-killing is non-nil. The default direction is forward. A positive prefix argument means move forward, a negative arugment means move backward, a zero argument means don't move at all." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((subject (vm-so-sortable-subject (car vm-message-pointer))) (mp vm-message-list) (n 0) (case-fold-search t)) (while mp (if (and (not (vm-deleted-flag (car mp))) (string-equal subject (vm-so-sortable-subject (car mp)))) (if (vm-set-deleted-flag (car mp) t) (vm-increment n))) (setq mp (cdr mp))) (and (vm-interactive-p) (if (zerop n) (vm-inform 5 "No messages deleted.") (vm-inform 5 "%d message%s deleted" n (if (= n 1) "" "s"))))) (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject)) (vm-update-summary-and-mode-line) (cond ((or (not (numberp arg)) (> arg 0)) (setq arg 1)) ((< arg 0) (setq arg -1)) (t (setq arg 0))) (if vm-move-after-killing (let ((vm-circular-folders (and vm-circular-folders (eq vm-move-after-killing t)))) (vm-next-message arg t executing-kbd-macro)))) ;;;###autoload (defun vm-kill-thread-subtree (&optional arg) "Delete all messages in the thread tree rooted at the current message. The optional prefix argument ARG specifies the direction to move if vm-move-after-killing is non-nil. The default direction is forward. A positive prefix argument means move forward, a negative arugment means move backward, a zero argument means don't move at all." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (vm-build-threads-if-unbuilt) (let ((list (vm-thread-subtree (vm-thread-symbol (car vm-message-pointer)))) (n 0)) (while list (unless (vm-deleted-flag (car list)) (if (vm-set-deleted-flag (car list) t) (vm-increment n))) (setq list (cdr list))) (when (vm-interactive-p) (if (zerop n) (vm-inform 5 "No messages deleted.") (vm-inform 5 "%d message%s deleted" n (if (= n 1) "" "s"))))) (vm-display nil nil '(vm-kill-thread-subtree) '(vm-kill-thread-subtree)) (vm-update-summary-and-mode-line) (cond ((or (not (numberp arg)) (> arg 0)) (setq arg 1)) ((< arg 0) (setq arg -1)) (t (setq arg 0))) (if vm-move-after-killing (let ((vm-circular-folders (and vm-circular-folders (eq vm-move-after-killing t)))) (vm-next-message arg t executing-kbd-macro)))) ;;;###autoload (defun vm-delete-duplicate-messages () "Delete duplicate messages in the current folder. This command works by comparing the message ID's. Messages that already deleted are not considered, so VM will never delete the last copy of a message in a folder. 'Deleting' means flagging for deletion; you will have to expunge the messages with `vm-expunge-folder' to really get rid of them, as usual. When invoked on marked messages (via `vm-next-command-uses-marks'), only duplicate messages among the marked messages are deleted; unmarked messages are not considerd for deletion." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (table (make-vector 103 0)) (mp vm-message-list) (n 0) (case-fold-search t) mid) (if used-marks (let ((vm-enable-thread-operations nil)) (setq mp (vm-select-operable-messages 0)))) (while mp (cond ((vm-deleted-flag (car mp))) (t (setq mid (vm-su-message-id (car mp))) (when mid ;; (or mid (debug (car mp))) (when (intern-soft mid table) (if (vm-set-deleted-flag (car mp) t) (setq n (1+ n)))) (intern mid table)))) (setq mp (cdr mp))) (when (vm-interactive-p) (if (zerop n) (vm-inform 5 "No messages deleted") (vm-inform 5 "%d message%s deleted" n (if (= 1 n) "" "s")))) (vm-update-summary-and-mode-line) n)) ;;;###autoload (defun vm-delete-duplicate-messages-by-body () "Delete duplicate messages in the current folder. This command works by computing an MD5 hash for the body of each non-deleted message in the folder and deleting messages that have a hash that has already been seen. Messages that are already deleted are never hashed, so VM will never delete the last copy of a message in a folder. 'Deleting' means flagging for deletion; you will have to expunge the messages with `vm-expunge-folder' to really get rid of them, as usual. When invoked on marked messages (via `vm-next-command-uses-marks'), only duplicate messages among the marked messages are deleted, unmarked messages are not hashed or considerd for deletion." (interactive) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist vm-message-list) (table (make-vector 61 0)) hash m (del-count 0)) (when used-marks (let ((vm-enable-thread-operations nil)) (setq mlist (vm-select-operable-messages 0)))) (save-excursion (save-restriction (widen) (while mlist (if (vm-deleted-flag (car mlist)) nil (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) (setq hash (vm-md5-region (vm-text-of m) (vm-text-end-of m))) (if (intern-soft hash table) (if (vm-set-deleted-flag (car mlist) t) (vm-increment del-count)) (intern hash table))) (setq mlist (cdr mlist))))) (vm-display nil nil '(vm-delete-duplicate-messages) (list this-command)) (when (vm-interactive-p) (if (zerop del-count) (vm-inform 5 "No messages deleted") (vm-inform 5 "%d message%s deleted" del-count (if (= 1 del-count) "" "s")))) (vm-update-summary-and-mode-line) del-count)) ;;;###autoload (defun* vm-expunge-folder (&key (quiet nil) ((:just-these-messages message-list) nil ; default value just-these-messages)) "Expunge messages with the `deleted' attribute. For normal folders this means that the deleted messages are removed from the message list and the message contents are removed from the folder buffer. For virtual folders, messages are removed from the virtual message list. If virtual mirroring is in effect for the virtual folder, the corresponding real messages are also removed from real message lists and the message contents are removed from real folders. When invoked on marked messages (via `vm-next-command-uses-marks'), only messages both marked and deleted are expunged, other messages are ignored." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-folder-read-only) ;; do this so we have a clean slate. code below depends on the ;; fact that the numbering redo start point begins as nil in ;; all folder buffers. (vm-update-summary-and-mode-line) (unless quiet (vm-inform 5 "Expunging...")) (let ((use-marks (and (eq last-command 'vm-next-command-uses-marks) (null just-these-messages))) (mp vm-message-list) (virtual (eq major-mode 'vm-virtual-mode)) (buffers-altered (make-vector 29 0)) prev virtual-messages) (while mp (cond ((if just-these-messages (memq (car mp) message-list) (and (vm-deleted-flag (car mp)) (or (not use-marks) (vm-mark-of (car mp))))) ;; remove the message from the thread tree. (if (vectorp vm-thread-obarray) (vm-unthread-message-and-mirrors (vm-real-message-of (car mp)) :message-changing nil)) ;; expunge from the virtual side first, removing all ;; references to this message before actually removing ;; the message itself. (cond ((setq virtual-messages (vm-virtual-messages-of (car mp))) (let (vms prev curr) (if virtual (setq vms (cons (vm-real-message-of (car mp)) (vm-virtual-messages-of (car mp)))) (setq vms (vm-virtual-messages-of (car mp)))) (while vms (save-excursion (set-buffer (vm-buffer-of (car vms))) (vm-unregister-fetched-message (car vms)) (setq prev (vm-reverse-link-of (car vms)) curr (or (cdr prev) vm-message-list)) (intern (buffer-name) buffers-altered) (vm-set-numbering-redo-start-point (or prev t)) (vm-set-summary-redo-start-point (or prev t)) (if (eq vm-message-pointer curr) (setq vm-system-state nil vm-message-pointer (or prev (cdr curr)))) (if (eq vm-last-message-pointer curr) (setq vm-last-message-pointer nil)) ;; lock out interrupts to preserve message-list integrity (let ((inhibit-quit t)) ;; vm-clear-expunge-invalidated-undos uses ;; this to recognize expunged messages. ;; If this stuff is mirrored we'll be ;; setting this value multiple times if there ;; are multiple virtual messages referencing ;; the underlying real message. Harmless. (vm-set-deleted-flag-of (car curr) 'expunged) ;; disable any summary update that may have ;; already been scheduled. (vm-set-su-start-of (car curr) nil) (vm-increment vm-modification-counter) (if (null prev) (progn (setq vm-message-list (cdr vm-message-list)) (and (cdr curr) (vm-set-reverse-link-of (car (cdr curr)) nil))) (setcdr prev (cdr curr)) (and (cdr curr) (vm-set-reverse-link-of (car (cdr curr)) prev))) (vm-set-virtual-messages-of (car mp) (cdr vms)) (vm-mark-folder-modified-p (vm-buffer-of (car vms))))) (setq vms (cdr vms)))))) (cond ((or (not virtual-messages) (not virtual)) (when (and (not virtual-messages) virtual) (vm-set-virtual-messages-of (vm-real-message-of (car mp)) (delq (car mp) (vm-virtual-messages-of (vm-real-message-of (car mp)))))) (if (eq vm-message-pointer mp) (setq vm-system-state nil vm-message-pointer (or prev (cdr mp)))) (if (eq vm-last-message-pointer mp) (setq vm-last-message-pointer nil)) (intern (buffer-name) buffers-altered) (if (null vm-numbering-redo-start-point) (progn (vm-set-numbering-redo-start-point (or prev t)) (vm-set-summary-redo-start-point (or prev t)))) ;; lock out interrupt to preserve message list integrity (let ((inhibit-quit t)) (if (null prev) (progn (setq vm-message-list (cdr vm-message-list)) (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) nil))) (setcdr prev (cdr mp)) (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev))) ;; vm-clear-expunge-invalidated-undos uses this to recognize ;; expunged messages. (vm-set-deleted-flag-of (car mp) 'expunged) ;; disable any summary update that may have ;; already been scheduled. (vm-set-su-start-of (car mp) nil) (vm-mark-folder-modified-p (current-buffer)) (vm-increment vm-modification-counter)))) (if (eq (vm-attributes-of (car mp)) (vm-attributes-of (vm-real-message-of (car mp)))) (let ((real-m (vm-real-message-of (car mp)))) (save-excursion (set-buffer (vm-buffer-of real-m)) (cond ((eq vm-folder-access-method 'pop) (setq vm-pop-messages-to-expunge (cons (vm-pop-uidl-of real-m) vm-pop-messages-to-expunge) ;; Set this so that if Emacs crashes or ;; the user quits without saving, we ;; have a record of messages that were ;; retrieved and expunged locally. ;; When the user does M-x recover-file ;; we won't re-retrieve messages the ;; user has already dealt with. vm-pop-retrieved-messages (cons (list (vm-pop-uidl-of real-m) (vm-folder-pop-maildrop-spec) 'uidl) vm-pop-retrieved-messages))) ((eq vm-folder-access-method 'imap) (setq vm-imap-messages-to-expunge (cons (cons (vm-imap-uid-of real-m) (vm-imap-uid-validity-of real-m)) vm-imap-messages-to-expunge)) ;; Set this so that if Emacs crashes or ;; the user quits without saving, we ;; have a record of messages that were ;; retrieved and expunged locally. ;; When the user does M-x recover-file ;; we won't re-retrieve messages the ;; user has already dealt with. (when (and (vm-imap-uid-of real-m) (vm-imap-uid-validity-of real-m)) (setq vm-imap-retrieved-messages (cons (list (vm-imap-uid-of real-m) (vm-imap-uid-validity-of real-m) (vm-folder-imap-maildrop-spec) 'uid) vm-imap-retrieved-messages))))) (vm-increment vm-modification-counter) (vm-save-restriction (widen) (let ((buffer-read-only nil)) (delete-region (vm-start-of real-m) (vm-end-of real-m)))))))) (t (setq prev mp))) (setq mp (cdr mp))) (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder)) (cond (buffers-altered (save-excursion (mapatoms (function (lambda (buffer) (set-buffer (symbol-name buffer)) ;; FIXME The update summary here is a heavy duty ;; operation. Can we be more clever about it, for ;; instance avoid doing it before quitting a folder? (if (null vm-system-state) (progn (vm-garbage-collect-message) (if (null vm-message-pointer) ;; folder is now empty (progn (setq vm-folder-type nil) (vm-update-summary-and-mode-line)) (vm-present-current-message))) (vm-update-summary-and-mode-line)) (if (not (eq major-mode 'vm-virtual-mode)) (setq vm-message-order-changed (or vm-message-order-changed vm-message-order-header-present))) (vm-clear-expunge-invalidated-undos))) buffers-altered)) (if vm-ml-sort-keys (vm-sort-messages vm-ml-sort-keys)) (unless quiet (vm-inform 5 "Deleted messages expunged."))) (t (vm-inform 5 "No messages are flagged for deletion.")))) (when vm-debug (vm-check-thread-integrity))) ;;; vm-delete.el ends here vm-8.2.0b/lisp/vm-window.el0000755000175000017500000006365711676442160016032 0ustar srivastasrivasta;;; vm-window.el --- Window management code for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-window) (eval-when-compile (require 'vm-misc) (require 'tapestry) ) (declare-function frame-highest-window "vm-xemacs" (frame)) (declare-function vm-selected-frame "vm-window.el" ()) (declare-function vm-window-frame "vm-window.el" (window)) (declare-function vm-delete-frame "vm-window.el" (&optional frame force)) (declare-function vm-raise-frame "vm-window.el" (&optional frame)) (declare-function vm-frame-visible-p "vm-window.el" (frame)) (declare-function vm-frame-iconified-p "vm-window.el" (frame)) (declare-function vm-window-frame "vm-window.el" (window)) (declare-function vm-next-frame "vm-window.el" (&optional frame miniframe)) (declare-function vm-select-frame "vm-window.el" (frame &optional norecord)) (declare-function vm-frame-selected-window "vm-window.el" (&optional frame)) ;;;###autoload (defun vm-display (buffer display commands configs &optional do-not-raise) ;; the clearinghouse VM display function. ;; ;; First arg BUFFER non-nil is a buffer to display or undisplay. ;; nil means there is no request to display or undisplay a ;; buffer. ;; ;; Second arg DISPLAY non-nil means to display the buffer, nil means ;; to undisplay it. This function guarantees to display the ;; buffer if requested. Undisplay is not guaranteed. ;; ;; Third arg COMMANDS is a list of symbols. this-command must ;; match one of these symbols for a window configuration to be ;; applied. ;; ;; Fourth arg CONFIGS is a list of window configurations to try. ;; vm-set-window-configuration will step through the list looking ;; for an existing configuration, and apply the one it finds. ;; ;; Display is done this way: ;; 1. if the buffer is visible in an invisible frame, make that frame visible ;; 2. if the buffer is already displayed, quit ;; 3. if vm-display-buffer-hook in non-nil ;; run the hooks ;; use the selected window/frame to display the buffer ;; quit ;; 4. apply a window configuration ;; if the buffer is displayed now, quit ;; 5. call vm-display-buffer which will display the buffer. ;; ;; Undisplay is done this way: ;; 1. if the buffer is not displayed, quit ;; 2. if vm-undisplay-buffer-hook is non-nil ;; run the hooks ;; quit ;; 3. apply a window configuration ;; 4, if a window configuration was applied ;; quit ;; 5. call vm-undisplay-buffer which will make the buffer ;; disappear from at least one window/frame. ;; ;; If display/undisplay is not requested, only window ;; configuration is done, and only then if the value of ;; this-command is found in the COMMANDS list. (and (stringp buffer) (setq buffer (get-buffer buffer))) (vm-save-buffer-excursion (let* ((w (and buffer (vm-get-buffer-window buffer))) (wf (and w (vm-window-frame w)))) (if (and w display (not do-not-raise)) (vm-raise-frame wf)) (if (and w display (not (eq (vm-selected-frame) wf))) (vm-select-frame wf)) (cond ((and buffer display) (if (and vm-display-buffer-hook (null (vm-get-visible-buffer-window buffer))) (progn (save-excursion (set-buffer buffer) (run-hooks 'vm-display-buffer-hook)) (switch-to-buffer buffer)) (if (not (and (memq this-command commands) (apply 'vm-set-window-configuration configs) (vm-get-visible-buffer-window buffer))) (vm-display-buffer buffer)))) ((and buffer (not display)) (if (and vm-undisplay-buffer-hook (vm-get-visible-buffer-window buffer)) (progn (save-excursion (set-buffer buffer) (run-hooks 'vm-undisplay-buffer-hook))) (if (not (and (memq this-command commands) (apply 'vm-set-window-configuration configs))) (vm-undisplay-buffer buffer)))) ((memq this-command commands) (apply 'vm-set-window-configuration configs)))))) (defun vm-display-buffer (buffer) (let ((pop-up-windows (eq vm-mutable-window-configuration t)) (pop-up-frames (and pop-up-frames vm-mutable-frame-configuration))) (if (or pop-up-frames (and (eq vm-mutable-window-configuration t) (symbolp (vm-buffer-to-label (window-buffer (selected-window)))))) (select-window (display-buffer buffer)) (switch-to-buffer buffer)))) (defun vm-undisplay-buffer (buffer) (vm-save-buffer-excursion (let ((vm-mutable-frame-configuration (and vm-mutable-frame-configuration pop-up-frames))) (vm-maybe-delete-windows-or-frames-on buffer)) (let (w) (while (setq w (vm-get-buffer-window buffer)) (set-window-buffer w (other-buffer buffer)))))) (defun vm-load-window-configurations (file) (save-excursion (let ((work-buffer nil)) (unwind-protect (progn (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for empty buffer (erase-buffer) (setq vm-window-configurations (condition-case () (progn (let ((coding-system-for-read (vm-line-ending-coding-system))) (insert-file-contents file)) (read (current-buffer))) (error nil)))) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-store-window-configurations (file) (save-excursion (let ((work-buffer nil)) (unwind-protect (progn (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for empty buffer ;; for MULE (if (fboundp 'set-buffer-file-coding-system) (set-buffer-file-coding-system (vm-line-ending-coding-system))) (erase-buffer) (print vm-window-configurations (current-buffer)) (let ((coding-system-for-write (vm-line-ending-coding-system)) (selective-display nil)) (write-region (point-min) (point-max) file nil 0))) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-set-window-configuration (&rest tags) (catch 'done (if (not vm-mutable-window-configuration) (throw 'done nil)) (let ((nonexistent " *vm-nonexistent*") (nonexistent-summary " *vm-nonexistent-summary*") (selected-frame (vm-selected-frame)) folders-summary summary message composition edit config) (while (and tags (null config)) (setq config (assq (car tags) vm-window-configurations) tags (cdr tags))) (or config (setq config (assq 'default vm-window-configurations))) (or config (throw 'done nil)) (setq config (vm-copy config)) (setq composition (vm-find-composition-buffer t)) (cond ((eq major-mode 'vm-summary-mode) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) (setq summary (current-buffer)) (setq message vm-mail-buffer))) ((eq major-mode 'vm-folders-summary-mode) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) (setq folders-summary (current-buffer)) (setq message vm-mail-buffer))) ((eq major-mode 'vm-mode) (setq message (current-buffer))) ((eq major-mode 'vm-presentation-mode) (setq message vm-mail-buffer)) ((eq major-mode 'vm-virtual-mode) (setq message (current-buffer))) ((eq major-mode 'mail-mode) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) (setq message vm-mail-buffer ;; assume that the proximity implies affinity composition (current-buffer)))) ((eq vm-system-state 'editing) (if (or (null vm-mail-buffer) (null (buffer-name vm-mail-buffer))) (throw 'done nil) (setq edit (current-buffer)) (setq message vm-mail-buffer))) ;; not in a VM related buffer, bail... (t (throw 'done nil))) (set-buffer message) (vm-check-for-killed-presentation) (if vm-presentation-buffer (setq message vm-presentation-buffer)) (vm-check-for-killed-summary) (or folders-summary (setq folders-summary (or vm-folders-summary-buffer nonexistent))) (or summary (setq summary (or vm-summary-buffer nonexistent-summary))) (or composition (setq composition nonexistent)) (or edit (setq edit nonexistent)) (tapestry-replace-tapestry-element (nth 1 config) 'buffer-name (function (lambda (x) (if (symbolp x) (symbol-value x) (if (and (stringp x) (get-buffer x) (zerop (save-excursion (set-buffer x) (buffer-size)))) nonexistent x ))))) (set-tapestry (nth 1 config) 1) (and (get-buffer nonexistent) (vm-maybe-delete-windows-or-frames-on nonexistent)) (if (and (vm-get-buffer-window nonexistent-summary) (not (vm-get-buffer-window message))) ;; user asked for summary to be displayed but doesn't ;; have one, nor is the folder buffer displayed. Help ;; the user not to lose here. (vm-replace-buffer-in-windows nonexistent-summary message) (and (get-buffer nonexistent-summary) (vm-maybe-delete-windows-or-frames-on nonexistent-summary))) config ))) ;;;###autoload (defun vm-save-window-configuration (tag) "Name and save the current window configuration. With this command you associate the current window setup with an action. Each time you perform this action VM will duplicate this window setup. Nearly every VM command can have a window configuration associated with it. VM also allows some category configurations, `startup', `reading-message', `composing-message', `editing-message', `marking-message' and `searching-message' for the commands that do these things. There is also a `default' configuration that VM will use if no other configuration is applicable. Command specific configurations are searched for first, then the category configurations and then the default configuration. The first configuration found is the one that is applied. The value of vm-mutable-window-configuration must be non-nil for VM to use window configurations." (interactive (let ((last-command last-command) (this-command this-command)) (if (null vm-window-configuration-file) (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) (list (intern (completing-read "Name this window configuration: " vm-supported-window-configurations 'identity t))))) (if (null vm-window-configuration-file) (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) (let (map p) (setq map (tapestry (list (vm-selected-frame)))) ;; set frame map to nil since we don't use it. this prevents ;; cursor objects and any other objects that have an ;; "unreadable" read syntax appearing in the window ;; configuration file by way of frame-parameters. (setcar map nil) (tapestry-replace-tapestry-element map 'buffer-name 'vm-buffer-to-label) (tapestry-nullify-tapestry-elements map t nil t t t nil) (setq p (assq tag vm-window-configurations)) (if p (setcar (cdr p) map) (setq vm-window-configurations (cons (list tag map) vm-window-configurations))) (vm-store-window-configurations vm-window-configuration-file) (vm-inform 5 "%s configuration recorded" tag))) (defun vm-buffer-to-label (buf) (save-excursion (set-buffer buf) (cond ((eq major-mode 'vm-summary-mode) 'summary) ((eq major-mode 'vm-folders-summary-mode) 'folders-summary) ((eq major-mode 'mail-mode) 'composition) ((eq major-mode 'vm-mode) 'message) ((eq major-mode 'vm-presentation-mode) 'message) ((eq major-mode 'vm-virtual-mode) 'message) ((eq vm-system-state 'editing) 'edit) (t buf)))) ;;;###autoload (defun vm-delete-window-configuration (tag) "Delete the configuration saved for a particular action. This action will no longer have an associated window configuration. The action will be read from the minibuffer." (interactive (let ((last-command last-command) (this-command this-command)) (if (null vm-window-configuration-file) (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) (list (intern (completing-read "Delete window configuration: " (mapcar (function (lambda (x) (list (symbol-name (car x))))) vm-window-configurations) 'identity t))))) (if (null vm-window-configuration-file) (error "Configurable windows not enabled. Set vm-window-configuration-file to enable.")) (let (p) (setq p (assq tag vm-window-configurations)) (if p (if (eq p (car vm-window-configurations)) (setq vm-window-configurations (cdr vm-window-configurations)) (setq vm-window-configurations (delq p vm-window-configurations))) (error "No window configuration set for %s" tag))) (vm-store-window-configurations vm-window-configuration-file) (vm-inform 5 "%s configuration deleted" tag)) ;;;###autoload (defun vm-apply-window-configuration (tag) "Change the current window configuration to be one associated with a particular action. The action will be read from the minibuffer." (interactive (let ((last-command last-command) (this-command this-command)) (list (intern (completing-read "Apply window configuration: " (mapcar (function (lambda (x) (list (symbol-name (car x))))) vm-window-configurations) 'identity t))))) (vm-set-window-configuration tag)) (defun vm-window-help () (interactive) (vm-inform 0 "WS = save configuration, WD = delete configuration, WW = apply configuration")) (defun vm-iconify-frame () "Iconify the current frame. Run the hooks in vm-iconify-frame-hook before doing so." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (vm-multiple-frames-possible-p) (progn (run-hooks 'vm-iconify-frame-hook) (vm-iconify-frame-xxx)))) (defun vm-window-loop (action obj-1 &optional obj-2) (let ((delete-me nil) (done nil) (all-frames (if vm-search-other-frames t nil)) start w) (setq start (next-window (selected-window) 'nomini all-frames) w start) (and obj-1 (setq obj-1 (get-buffer obj-1))) (while (not done) (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) (progn (delete-window delete-me) (if (eq delete-me start) (setq start nil)) (setq delete-me nil))) (cond ((and (eq action 'delete) (eq obj-1 (window-buffer w))) ;; a deleted window has no next window, so we ;; defer the deletion until after we've moved ;; to the next window. (setq delete-me w)) ((and (eq action 'replace) (eq obj-1 (window-buffer w))) (set-window-buffer w obj-2))) (setq done (eq start (setq w (condition-case nil (next-window w 'nomini all-frames) (wrong-number-of-arguments (next-window w 'nomini)))))) (if (null start) (setq start w))) (if (and delete-me (not (eq delete-me (next-window delete-me 'nomini)))) (delete-window delete-me)))) (defun vm-frame-loop (action obj-1) (if (fboundp 'vm-next-frame) (let ((start (vm-next-frame (vm-selected-frame))) (delete-me nil) (done nil) f) (setq f start) (and obj-1 (setq obj-1 (get-buffer obj-1))) (while (not done) (if delete-me (progn (condition-case nil (progn (if (vm-created-this-frame-p delete-me) (progn (vm-delete-frame delete-me) (if (eq delete-me start) (setq start nil))))) (error nil)) (setq delete-me nil))) (cond ((and (eq action 'delete) ;; one-window-p doesn't take a frame argument (eq (next-window (vm-frame-selected-window f) 'nomini) (previous-window (vm-frame-selected-window f) 'nomini)) ;; the next-window call is to avoid looking ;; at the minibuffer window (eq obj-1 (window-buffer (next-window (vm-frame-selected-window f) 'nomini)))) ;; a deleted frame has no next frame, so we ;; defer the deletion until after we've moved ;; to the next frame. (setq delete-me f)) ((eq action 'bury) (bury-buffer obj-1))) (setq done (eq start (setq f (vm-next-frame f)))) (if (null start) (setq start f))) (if (and delete-me (vm-created-this-frame-p delete-me)) (progn (vm-error-free-call 'vm-delete-frame delete-me) (setq delete-me nil)))))) (defun vm-maybe-delete-windows-or-frames-on (buffer) (and (eq vm-mutable-window-configuration t) (vm-window-loop 'delete buffer)) (and vm-mutable-frame-configuration (vm-frame-loop 'delete buffer))) (defun vm-replace-buffer-in-windows (old new) (vm-window-loop 'replace old new)) (defun vm-bury-buffer (&optional buffer) (or buffer (setq buffer (current-buffer))) (if vm-xemacs-p (if (vm-multiple-frames-possible-p) (vm-frame-loop 'bury buffer) (bury-buffer buffer)) (bury-buffer buffer))) (defun vm-unbury-buffer (buffer) (save-excursion (save-window-excursion ;; catch errors--- the selected window might be a dedicated ;; window or a minibuffer window. We don't care and we ;; don't want to crash because of it. (condition-case data (switch-to-buffer buffer) (error nil))))) (defun vm-set-hooks-for-frame-deletion () (make-local-variable 'vm-undisplay-buffer-hook) (add-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) (add-hook 'kill-buffer-hook 'vm-delete-buffer-frame)) (defun vm-created-this-frame-p (&optional frame) (memq (or frame (vm-selected-frame)) vm-frame-list)) (defun vm-delete-buffer-frame () ;; kludge. we only want to this to run on VM related buffers ;; but this function is generally on a global hook. Check for ;; vm-undisplay-buffer-hook set; this is a good sign that this ;; is a VM buffer. (if vm-undisplay-buffer-hook (save-excursion ;; run once only per buffer. (remove-hook 'vm-undisplay-buffer-hook 'vm-delete-buffer-frame) (let* ((w (vm-get-visible-buffer-window (current-buffer))) (b (current-buffer)) (wf (and w (vm-window-frame w)))) (and w (eq (vm-selected-frame) wf) (vm-created-this-frame-p wf) (vm-error-free-call 'vm-delete-frame wf)) (and w (let ((vm-mutable-frame-configuration t)) (vm-maybe-delete-windows-or-frames-on b))))))) (defun vm-register-frame (frame) (setq vm-frame-list (cons frame vm-frame-list))) (defun vm-goto-new-frame (&rest types) (let ((params nil)) (while (and types (null params)) (setq params (car (cdr (assq (car types) vm-frame-parameter-alist))) types (cdr types))) ;; these functions might be defined in an Emacs that isn't ;; running under a window system, but VM always checks for ;; multi-frame support before calling this function. (cond ((fboundp 'make-frame) (vm-select-frame (make-frame params))) ((fboundp 'make-screen) (vm-select-frame (make-screen params))) ((fboundp 'new-screen) (vm-select-frame (new-screen params)))) (vm-register-frame (vm-selected-frame)) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-selected-frame))))) (defun vm-goto-new-summary-frame-maybe () (if (and vm-mutable-frame-configuration vm-frame-per-summary (vm-multiple-frames-possible-p)) (let ((w (vm-get-buffer-window vm-summary-buffer))) (if (null w) (progn (vm-goto-new-frame 'summary) (vm-set-hooks-for-frame-deletion)) (save-excursion (select-window w) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) (defun vm-goto-new-folders-summary-frame-maybe () (if (and vm-mutable-frame-configuration vm-frame-per-folders-summary (vm-multiple-frames-possible-p)) (let ((w (vm-get-buffer-window vm-folders-summary-buffer))) (if (null w) (progn (vm-goto-new-frame 'folders-summary) (vm-set-hooks-for-frame-deletion)) (save-excursion (select-window w) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) (defun vm-goto-new-folder-frame-maybe (&rest types) (if (and vm-mutable-frame-configuration vm-frame-per-folder (vm-multiple-frames-possible-p)) (let ((w (or (vm-get-buffer-window (current-buffer)) ;; summary == folder for the purpose ;; of frame reuse. (and vm-summary-buffer (vm-get-buffer-window vm-summary-buffer)) ;; presentation == folder for the purpose ;; of frame reuse. (and vm-presentation-buffer (vm-get-buffer-window vm-presentation-buffer))))) (if (null w) (progn (apply 'vm-goto-new-frame types) (vm-set-hooks-for-frame-deletion)) (save-excursion (select-window w) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))))))) (defun vm-warp-mouse-to-frame-maybe (&optional frame) (or frame (setq frame (vm-selected-frame))) (if (vm-mouse-support-possible-here-p) (cond ((vm-mouse-xemacs-mouse-p) (cond ((fboundp 'mouse-position);; XEmacs 19.12 and up (let ((mp (mouse-position))) (if (and (car mp) (eq (window-frame (car mp)) (selected-frame))) nil (set-mouse-position (frame-highest-window frame) (/ (frame-width frame) 2) (/ (frame-height frame) 2))))) (t (error "Emacs version too old") ;; XEmacs 19.11 ;; use (apply 'screen-...) instead of ;; (screen-...) to avoid stimulating a ;; byte-compiler bug in Emacs 19.29 that ;; happens when it encounters 'obsolete' ;; functions. puke, puke, puke. ;; (let ((mp (read-mouse-position frame))) ;; (if (and (>= (car mp) 0) ;; (<= (car mp) (apply 'screen-width frame)) ;; (>= (cdr mp) 0) ;; (<= (cdr mp) (apply 'screen-height frame))) ;; nil ;; (set-mouse-position ;; frame ;; (/ (apply 'screen-width frame) 2) ;; (/ (apply 'screen-height frame) 2)))) ))) ((vm-fsfemacs-p) (let ((mp (mouse-position))) (if (and (eq (car mp) frame) ;; nil coordinates mean that the mouse ;; pointer isn't really within the frame (car (cdr mp))) nil (set-mouse-position frame (/ (frame-width frame) 2) (/ (frame-height frame) 2)) ;; doc for set-mouse-position says to do this ;; but Emacs 22 doesn't say it and unfocus-frame is ;; obsolete now. USR, 2010-07-03 ;; (unfocus-frame) )))))) (fset 'vm-selected-frame (symbol-function (cond ((fboundp 'selected-frame) 'selected-frame) ;; ((fboundp 'selected-screen) 'selected-screen) ; Xemacs 19? (t 'ignore)))) (fset 'vm-delete-frame (symbol-function (cond ((fboundp 'delete-frame) 'delete-frame) ;; ((fboundp 'delete-screen) 'delete-screen) ; XEmacs 19? (t 'ignore)))) ;; xxx because vm-iconify-frame is a command (defun vm-iconify-frame-xxx (&optional frame) (cond ((fboundp 'iconify-frame) (iconify-frame frame)) ;; ((fboundp 'iconify-screen) ; XEmacs 19? ;; (iconify-screen (or frame (vm-selected-frame)))) )) (defun vm-deiconify-frame (frame) "Deiconify FRAME." (if (fboundp 'deiconify-frame) (deiconify-frame frame) (when (eq (frame-visible-p frame) 'icon) (select-frame frame) (iconify-or-deiconify-frame)))) (fset 'vm-raise-frame (symbol-function (cond ((fboundp 'raise-frame) 'raise-frame) ;; ((fboundp 'raise-screen) 'raise-screen) ; XEmacs 19? (t 'ignore)))) (fset 'vm-frame-visible-p (symbol-function (cond ((fboundp 'frame-visible-p) 'frame-visible-p) ;; ((fboundp 'screen-visible-p) 'screen-visible-p) ; XEmacs 19? (t 'ignore)))) (if (fboundp 'frame-iconified-p) (fset 'vm-frame-iconified-p 'frame-iconified-p) (defun vm-frame-iconified-p (&optional frame) (eq (vm-frame-visible-p frame) 'icon))) ;; frame-totally-visible-p is broken under XEmacs 19.14 and is ;; absent under Emacs 19.34. So vm-frame-per-summary won't work ;; quite right under these Emacs versions. XEmacs 19.15 should ;; have a working version of this function. ;; 2 April 1997, frame-totally-visible-p apparently still broken ;; under 19.15. I give up for now. ;;(if (and (fboundp 'frame-totally-visible-p) ;; vm-xemacs-p ;; (or (>= emacs-major-version 20) ;; (>= emacs-minor-version 15))) ;; (fset 'vm-frame-totally-visible-p 'frame-totally-visible-p) ;; (fset 'vm-frame-totally-visible-p 'vm-frame-visible-p)) ;; 2 April 1998, frame-visible-p returns 'hidden for tty frames ;; that are visible but not the topmost frame. Use that info. (defun vm-frame-totally-visible-p (&optional frame) (or frame (setq frame (selected-frame))) (not (memq (frame-visible-p frame) '(nil hidden)))) (fset 'vm-window-frame (symbol-function (cond ((fboundp 'window-frame) 'window-frame) ((fboundp 'window-screen) 'window-screen) (t 'ignore)))) (cond ((fboundp 'next-frame) (fset 'vm-next-frame (symbol-function 'next-frame)) (fset 'vm-select-frame (symbol-function 'select-frame)) (fset 'vm-frame-selected-window (symbol-function 'frame-selected-window))) ((fboundp 'next-screen) (fset 'vm-next-frame (symbol-function 'next-screen)) (fset 'vm-select-frame (symbol-function 'select-screen)) (fset 'vm-frame-selected-window (if (fboundp 'epoch::selected-window) (symbol-function 'epoch::selected-window) (symbol-function 'screen-selected-window)))) (t ;; it is useful for this to be a no-op, but don't bind the ;; others. (fset 'vm-select-frame 'ignore))) ;;; vm-window.el ends here vm-8.2.0b/lisp/u-vm-color.el0000755000175000017500000007127211676442160016073 0ustar srivastasrivasta;;; u-vm-color.el --- Font-lock support for VM. ;; ;; This file is an add-on for VM ;; Copyright (C) 2001-2007 by Ulf Jasper ;; Emacs Lisp Archive Entry ;; Author: Ulf Jasper ;; Filename: u-vm-color.el ;; Created: January 19 2001 ;; Keywords: VM, Customization ;; Time-stamp: "23. Februar 2008, 21:28:20 (ulf)" ;; CVS-Version: $Id: u-vm-color.el,v 2.19 2008-02-23 20:28:57 ulf Exp $ ;;; Code (provide 'u-vm-color) (eval-when-compile (require 'vm-misc) (require 'vm-folder)) (defconst u-vm-color-version "2.10" "Version number of u-vm-color.") ;; This program is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by the ;; Free Software Foundation; either version 2 of the License, or (at your ;; option) any later version. ;; This program is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; General Public License for more details. ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;; ====================================================================== ;;; Commentary: ;; This package provides a simple way for configuring faces for VM. ;; All faces are customizable. ;; For the VM summary buffer this is done using `font-lock', for the ;; message buffer by a "proprietary" fontifier. ;; For vm-summary-mode font-lock-keywords are created from the value of ;; `vm-summary-format'. All vm format-specifiers are understood (as of VM ;; 6.88), as well as the user-defined specifier `%UB', provided by BBDB. ;; To install and use place this file somewhere in your load-path and put ;; the following in your VM startup file (~/.emacs or ~/.vm) ;; (require 'u-vm-color) ;; (add-hook 'vm-select-message-hook 'u-vm-color-fontify-buffer) ;; It may be necessary to add the following, which probably comes from ;; a bug in my code... ;; (defadvice vm-show-current-message (after u-vm-color activate) ;; (u-vm-color-fontify-buffer-even-more)) ;; You might also add this advice, which causes some slow down: ;; (defadvice vm-decode-mime-message (after u-vm-color activate) ;; (u-vm-color-fontify-buffer-even-more)) ;; ;; If you are using auto-fill, ie when the variables ;; `vm-word-wrap-paragraphs' or ;; `vm-fill-paragraphs-containing-long-lines' is not nil, you should ;; also add this: ;; (defadvice vm-fill-paragraphs-containing-long-lines ;; (after u-vm-color activate) ;; (u-vm-color-fontify-buffer)) ;; It will make sure that buffers/messages, which have been re-filled ;; are fontified properly. ;; It is possible to use the face definitions from Gnus by adding ;; (setq u-vm-color-use-gnus-faces t) ;; However, this is irreversible. At least for that Emacs session. ;; All faces are customizable: Just say ;; M-x customize-group u-vm-color ;; In order to prevent Emacs from locking I strongly recommend to use ;; lazy-lock or jit-mode. ;; Disclaimer: `u-vm-color' may show unexpected results, or even fail, if ;; vm-summary-format is sufficiently complex=strange. ;; XEmacs users might want to turn off `vm-use-lucid-highlighting', if ;; this package works... ;; ====================================================================== ;;; History: ;; (2011-02-17) ;; Removed instructions for fontifying summary buffers because ;; vm-summary-faces is now built into VM. Uday S. Reddy ;; 2.10: (2008-02-23) ;; Bugfixes -- thanks to Martin Schwenke ;; 2.9: (2007-12-19) ;; Handle PGP signatures -- thanks to Frederik Axelsson. ;; Other minor changes. ;; 2.8.1: (2005-10-22) ;; Added autoload cookies. ;; Silence compiler warnings. ;; 2.8: (2005-04-05) ;; Fixed problems with non-graphical chars in summary buffers. ;; Fixed font-lock-problems with "older" Emacsen which were ;; introduced with version 2.7. ;; 2.7: (2005-02-26) ;; Fixed font-lock-problems with recent CVS Emacs. ;; 2.6: Fixed problems with summary mode in recent CVS Emacs. ;; Added u-vm-color-spamassassin. ;; 2.5: Bugfix(?): require gnus-cite for gnus-faces. Thanks to ;; Richard Walker for pointing out. ;; Tested with Emacs 21.2.2/VM 7.08 ;; 2.4: Bugfix: re-activated font-lock-keywords-only. If this is not set, ;; font-lock tries to fontify strings and will screw up the ;; summary buffer if it finds double-quotes. ;; Thanks to Stefan Kamphausen for testing. ;; Recognize lengths of *strings* in the vm-summary-format, like in ;; "%-10.10F %s". In this case sender/recipient and subject will ;; always be correctly fontified. (The font-lock regexp will now be ;; ".......... .*" instead of ".* .*".) Note that it is still not ;; possible to distinguish two arbitrary-length adjacent strings, ;; like in "%F %s". ;; Tested with Emacs 21.2.2 ;; 2.3: Bugfix: Removed (setq font-lock-keywords-only t) in ;; u-vm-color-summary-mode, which confused font-lock in XEmacs ;; 21.4 when vm-use-toolbar was non-nil -- ???! ;; Tested with Emacs 21.2.1/VM 7.07 and XEmacs 21.4.6/VM 7.03. ;; 2.2: Bugfixes: Recipient- and author face were interchanged in message. ;; Now setting buffer-modified-p to its original value after ;; fontifying message buffer. ;; 2.0: Fontification in message buffers now done "by hand" -- no ;; font-lock here any more. Apparently font-lock removes all ;; face-properties when it is started. So, inlined html messages and ;; such looked quite boring. ;; No limitation on header lengths anymore. Doesn't remove faces for ;; inlined html messages and such. ;; Tested with emacs 21.1. ;; 1.11: Added faces for dark backgrounds. ;; Introduced u-vm-color-use-gnus-faces. ;; 1.9 Colons belong to header-keywords. ;; 1.7 Forgot VM's B attribute. ;; 1.6: Limited headers and signatures to 5 lines to avoid regexp stack ;; overflow. ;; Citations now supercite-compliant. ;; 1.5: Minor bug fixes. ;; 1.1: Introduced minor modes. ;; Should work for xemacs as well. ;; 1.0: Initial version. ;; ====================================================================== ;;; Code: (require 'font-lock) ;; Silence compiler warnings (defvar vm-summary-format) (defgroup u-vm-color nil "Font-lock support for vm." :group 'vm-ext) (defcustom u-vm-color-use-gnus-faces nil "Use corresponding face definitions from Gnus." :type 'boolean :group 'u-vm-color) (defface u-vm-color-signature-face '((((class color) (background dark)) (:bold nil :italic t :foreground "misty rose")) (((class color) (background light)) (:bold nil :italic t :foreground "Sienna"))) "Face for Signatures." :group 'u-vm-color) (defface u-vm-color-header-face '((((class color) (background dark)) (:bold t :italic nil :foreground "white")) (((class color) (background light)) (:bold t :italic nil :foreground "black"))) "General Face for header keywords." :group 'u-vm-color) (defface u-vm-color-author-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "cornflower blue")) (((class color) (background light)) (:bold nil :italic nil :foreground "midnight blue"))) "Face for sender names." :group 'u-vm-color) (defface u-vm-color-recipient-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "green")) (((class color) (background light)) (:bold nil :italic nil :foreground "DarkGreen"))) "Face for recipient names." :group 'u-vm-color) (defface u-vm-color-subject-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "sky blue")) (((class color) (background light)) (:bold nil :italic nil :foreground "medium blue"))) "Face for subjects." :group 'u-vm-color) (defface u-vm-color-default-face '((t (:italic t))) "Default face." :group 'u-vm-color) (defface u-vm-color-time-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "pink")) (((class color) (background light)) (:bold nil :italic nil :foreground "maroon"))) "Face for message time." :group 'u-vm-color) (defface u-vm-color-attribute-face '((((class color) (background dark)) (:bold t :italic nil :foreground "orange red")) (((class color) (background light)) (:bold t :italic nil :foreground "red"))) "Face for vm attributes." :group 'u-vm-color) (defface u-vm-color-date-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "pink")) (((class color) (background light)) (:bold nil :italic nil :foreground "maroon"))) "Face for message date." :group 'u-vm-color) (defface u-vm-color-id-face '((t (:bold nil :italic t))) "Face for message id." :group 'u-vm-color) (defface u-vm-color-label-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "orange red")) (((class color) (background light)) (:bold nil :italic nil :foreground "red"))) "Face for vm labels." :group 'u-vm-color) (defface u-vm-color-length-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "white")) (((class color) (background light)) (:bold nil :italic nil :foreground "black"))) "Face for message length." :group 'u-vm-color) (defface u-vm-color-number-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "white")) (((class color) (background light)) (:bold nil :italic nil :foreground "black"))) "Face for message number." :group 'u-vm-color) (defface u-vm-color-user-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "light sea green")) (((class color) (background light)) (:bold nil :italic nil :foreground "forest green"))) "Face for user defined summary elements." :group 'u-vm-color) (defface u-vm-color-citation-1-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "orange red")) (((class color) (background light)) (:bold nil :italic nil :foreground "orange red"))) "Face for citations." :group 'u-vm-color) (defface u-vm-color-citation-2-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "SkyBlue1")) (((class color) (background light)) (:bold nil :italic nil :foreground "SlateBlue"))) "Face for citation." :group 'u-vm-color) (defface u-vm-color-citation-3-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "cyan")) (((class color) (background light)) (:bold nil :italic nil :foreground "DarkGreen"))) "Face for citation." :group 'u-vm-color) (defface u-vm-color-citation-4-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "magenta")) (((class color) (background light)) (:bold nil :italic nil :foreground "BlueViolet"))) "Face for citation." :group 'u-vm-color) (defface u-vm-color-citation-5-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "firebrick1")) (((class color) (background light)) (:bold nil :italic nil :foreground "Firebrick"))) "Face for citation." :group 'u-vm-color) (defface u-vm-color-spamassassin-face '((((class color) (background dark)) (:bold nil :italic nil :foreground "firebrick1")) (((class color) (background light)) (:bold nil :italic nil :foreground "Firebrick"))) "Face for spamassassin preview block." :group 'u-vm-color) (defface u-vm-color-pgp-inline-signature-face '((((class color) (background dark)) (:bold nil :italic t :foreground "blue")) (((class color) (background light)) (:bold nil :italic t :foreground "blue"))) "Face for pgp inline signatures." :group 'u-vm-color) (defun u-vm-color-copy-gnus-faces () "Set up u-vm-color faces by copying from corresponding Gnus faces." ;; make sure we have the Gnus faces (require 'gnus-art) (require 'gnus-cite) (require 'message) ;; (message "u-vm-color: copying Gnus faces...") (when (facep 'gnus-signature-face) (copy-face 'gnus-signature-face 'u-vm-color-signature-face)) (when (facep 'gnus-header-from-face) (copy-face 'gnus-header-from-face 'u-vm-color-author-face)) (when (facep 'gnus-header-subject-face) (copy-face 'gnus-header-subject-face 'u-vm-color-subject-face)) (when (facep 'gnus-header-content-face) (copy-face 'gnus-header-content-face 'u-vm-color-default-face)) (when (facep 'gnus-header-name-face) (copy-face 'gnus-header-name-face 'u-vm-color-header-face)) (when (facep 'gnus-cite-face-1) (copy-face 'gnus-cite-face-1 'u-vm-color-citation-1-face)) (when (facep 'gnus-cite-face-2) (copy-face 'gnus-cite-face-2 'u-vm-color-citation-2-face)) (when (facep 'gnus-cite-face-3) (copy-face 'gnus-cite-face-3 'u-vm-color-citation-3-face)) (when (facep 'gnus-cite-face-4) (copy-face 'gnus-cite-face-4 'u-vm-color-citation-4-face)) (when (facep 'gnus-cite-face-5) (copy-face 'gnus-cite-face-5 'u-vm-color-citation-5-face)) (message "u-vm-color: copying Gnus faces... done")) (defun u-vm-color-make-specific-length-regexp (regexp m-length length &optional prefix) "Create a regular expression. Argument REGEXP a regexp . Argument M-LENGTH the minimal LENGTH. Optional argument PREFIX the maximal length." (let ((i 0) (result "\\(")) (if prefix (setq result (concat result prefix))) ;;(message "input: %s %d %d" regexp m-length length) (cond ((and length (> length 0)) (when m-length (while (and (< i m-length) (< i length)) (setq result (concat result regexp)) (setq i (1+ i)))) (while (< i length) (setq result (concat result regexp "?")) (setq i (1+ i)))) (t (setq result (concat result regexp "*")))) ;;(message "result: --%s--" result) (concat result "\\)"))) (defun u-vm-color-make-summary-keywords () "Parse `vm-summary-format' and return a font-lock keyword list. List consists of one big regexp and lots of face instructions for subexpressions." (let ((search-start 0) (length 0) ; (maximum) length (m-length 0) ; minimum length (rest "") (f-element "") (m-element "") (value "") (u-format "^..") (u-match nil) (count 1) (t-vm-summary-format vm-summary-format) (u-vm-color-xemacs-workaround (string-match "XEmacs\\|Lucid" emacs-version))) ;; pick up all elements in the vm-summary-format (while (string-match (concat "%-?\\([0-9]+\\.\\)?-?\\([0-9]+\\)?" "\\([aAcdfFhHiIlLmMnstTwyz*]\\|U.\\)\\([^%\n]*\\)") t-vm-summary-format search-start) (setq search-start (match-end 0)) (if (match-beginning 1) (setq m-length (string-to-number (substring t-vm-summary-format (match-beginning 1) (1- (match-end 1))))) (setq m-length 0)) (if (match-beginning 2) (setq length (string-to-number (substring t-vm-summary-format (match-beginning 2) (match-end 2)))) (setq length 0)) (if (match-beginning 3) (setq value (substring t-vm-summary-format (match-beginning 3) (match-end 3))) (setq value "")) (if (match-beginning 4) (setq rest (substring t-vm-summary-format (match-beginning 4) (match-end 4))) (setq rest "")) (setq rest (regexp-quote rest)) ;;(message "--> %s, %s, %s" length m-length value) ;; Should use the length and m-length values for things like %5d ;; instead of doing [0-9 ]+ for numerics... ;; No! (cond ((string-equal value "a") ;; attributes -- make sure that all ;; possible letters are given! (setq f-element "\\([DNU ][FW ][RZB ][E ]\\)") (setq m-element (list count (quote 'u-vm-color-attribute-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "A") ;; attributes -- long (setq f-element "\\([DNU ][r ][z ][b ][f ][w ][e ]\\)") (setq m-element (list count (quote 'u-vm-color-attribute-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "c") ;; number of characters (setq f-element "\\( *[0-9]+ *\\)") (setq m-element (list count (quote 'u-vm-color-length-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "d") ;; day -- numeric (setq f-element "\\( *[0-9]+ *\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "f") ;; authors / recipients address ;;(setq f-element "\\(To: [^ \n]+\\)?\\([^ \n]+\\)?") (setq f-element (concat "\\(" (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." (- m-length 4) (- length 4) "To: ") "\\|" (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." m-length length) "\\)")) (setq count (+ 1 count)) (setq m-element (list count (quote 'u-vm-color-recipient-face) t t)) (setq count (+ 1 count)) (setq u-match (append u-match (list m-element))) (setq m-element (list count (quote 'u-vm-color-author-face) t t))) ((or (string-equal value "F") (string-equal value "UA") ;; IS THIS CORRECT!???????? (string-equal value "UB")) ;; authors / recipients full names ;;(setq f-element "\\(To:.+\\)?\\([^:\n]+\\)?") (setq f-element (concat "\\(" (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." (- m-length 4) (- length 4) "To: ") "\\|" (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." m-length length) "\\)")) (setq count (+ 1 count)) (setq m-element (list count (quote 'u-vm-color-recipient-face) t t)) (setq count (+ 1 count)) (setq u-match (append u-match (list m-element))) (setq m-element (list count (quote 'u-vm-color-author-face) t t))) ((string-equal value "h") ;; time (setq f-element "\\([0-9][0-9]:[0-9][0-9]:[0-9][0-9]\\)") (setq m-element (list count (quote 'u-vm-color-time-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "H") ;; time -- short (setq f-element "\\([0-9][0-9]:[0-9][0-9]\\)") (setq m-element (list count (quote 'u-vm-color-time-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "i") ;; id (setq f-element "\\(<[^ \n]+>\\)") (setq m-element (list count (quote 'u-vm-color-id-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "I") ;; indentation (setq f-element " *") (setq m-element nil)) ((string-equal value "l") ;; number of lines (setq f-element "\\( *[0-9]+ *\\)") (setq m-element (list count (quote 'u-vm-color-length-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "L") ;; label (setq f-element (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." m-length length)) (setq m-element (list count (quote 'u-vm-color-label-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "m") ;; month (setq f-element "\\([A-Za-z]+\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "M") ;; month -- numeric (setq f-element "\\( *[0-9]+ *\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "n") ;; message number (setq f-element "\\( *[0-9]+ *\\)") (setq m-element (list count (quote 'u-vm-color-number-face)))) ((string-equal value "s") ;; subject (setq f-element (u-vm-color-make-specific-length-regexp ;;"[ [:graph:]]" "." m-length length)) (setq m-element (list count (quote 'u-vm-color-subject-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "t") ;; recipient addresses (setq f-element "\\([^ \n]+\\)") (setq m-element (list count (quote 'u-vm-color-recipient-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "T") ;; recipient full names (setq f-element "\\(.+\\)") (setq m-element (list count (quote 'u-vm-color-recipient-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "w") ;; week day (is missing in some mails!) (setq f-element "\\([A-Za-z ]+\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "y") ;; year (setq f-element "\\([0-9]+\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "z") ;; timezone (setq f-element "\\(.+\\)") (setq m-element (list count (quote 'u-vm-color-date-face) nil u-vm-color-xemacs-workaround))) ((string-equal value "*") ;; mark-marker (setq f-element "\\(\\*\\| \\)") (setq m-element (list count (quote 'u-vm-color-attribute-face) nil u-vm-color-xemacs-workaround))) (t ;; user defined and everything else (setq f-element ".*") (setq m-element nil))) (setq u-format (concat u-format f-element rest)) (if m-element (progn (setq count (+ 1 count)) (setq u-match (append u-match (list m-element)))))) (setq u-format (concat u-format "$")) (append (list u-format) u-match))) (defvar u-vm-color-summary-mode nil) (make-variable-buffer-local 'u-vm-color-summary-mode) (add-to-list 'minor-mode-alist '(u-vm-color-summary-mode nil)) (defvar u-vm-color-summary-keywords nil) ;; FIXME: u-vm-color-summary-mode cannot be turned off ;;;###autoload (defun u-vm-color-summary-mode (&optional arg) "Configure `font-lock-keywords' and add some hooks for vm-buffers. (Optional argument ARG is not used.)" (interactive "P") (setq u-vm-color-summary-mode (not (or (and (null arg) u-vm-color-summary-mode) (<= (prefix-numeric-value arg) 0)))) (if u-vm-color-use-gnus-faces (u-vm-color-copy-gnus-faces)) ;; apparently emacs expects this statement here... (font-lock-mode 1) (cond ((string-match "XEmacs\\|Lucid" emacs-version) ;; XEmacs (setq u-vm-color-summary-keywords (list (u-vm-color-make-summary-keywords))) (put 'vm-summary-mode 'font-lock-defaults '( 'u-vm-color-summary-keywords t ; keywords-only t ; case-fold nil ; syntax-alist nil ; syntax-begin )) (setq font-lock-keywords (list (u-vm-color-make-summary-keywords))) (font-lock-fontify-buffer)) (t ;; GNU Emacs (setq u-vm-color-summary-keywords (list (u-vm-color-make-summary-keywords))) (set (make-local-variable 'font-lock-defaults) (list 'u-vm-color-summary-keywords ;; keywords t ;; keywords-only t ;; case-fold nil ;; syntax-alist nil)) ;; syntax-begin ;; With the CVS version of GNU Emacs as of Feb. 2005 one must ;; not set font-lock-keywords explicitly as a global variable. ;; It is sufficient to set font-lock-defaults. ;; For older GNU Emacs versions up to 21.3 it is necessary to ;; set font-lock-keywords. ;; Setting font-lock-keywords as a local variable works with all ;; GNU Emacs versions. ;; 2005-04-05 (set (make-local-variable 'font-lock-keywords) u-vm-color-summary-keywords) (set (make-local-variable 'font-lock-keywords-only) t) (font-lock-mode 1)))) (make-obsolete 'u-vm-color-summary-mode 'vm-summary-enable-faces "8.2.0") (defun u-vm-color-fontify-regexp (start end regexp how) "Search the buffer for an expression and fontify it. Search starts at START and ends at END. If REGEXP is found, it is fontified according to the argument HOW, which is a list of the form '((index face)...)." ;;(message "Searching from %d to %d for %s" start end regexp) (let ((inhibit-read-only t)) (save-excursion (goto-char start) (while (and start (< start end)) (setq start (re-search-forward regexp end t)) (when start ;;(message "match found!") (mapc (lambda (what) (let ((index (nth 0 what)) (face (nth 1 what))) (when (match-beginning index) ;;(message "Adding face %s for match %d" face index) (put-text-property (match-beginning index) (match-end index) 'face face)))) how)))))) (defun u-vm-color-fontify-signature (start end) "Search and fontify the signature. Search is restricted to the region between START and END." (let ((inhibit-read-only t)) (save-excursion (goto-char end) (setq start (re-search-backward "^\\(- \\)?-- ?$" start t)) (when start (put-text-property start end 'face 'u-vm-color-signature-face))))) (defun u-vm-color-fontify-pgp-signature (start end) "Search and fontify inline PGP signatures." (let ((inhibit-read-only t) (pgp-end-regex "-----END PGP SIGNATURE-----") (pgp-start-regex "-----BEGIN PGP SIGNATURE-----") (pgp-sign-regex "-----BEGIN PGP SIGNED MESSAGE-----") (pgp-hash-regex "^Hash: .*") re-end-pos) (save-excursion (goto-char end) (when (re-search-backward pgp-end-regex start t) (setq re-end-pos (match-end 0)) (when (re-search-backward pgp-start-regex start t) (put-text-property (point) re-end-pos 'face 'u-vm-color-pgp-inline-signature-face))) (when (re-search-backward pgp-hash-regex start t) (setq re-end-pos (match-end 0)) (when (re-search-backward pgp-sign-regex start t) (put-text-property (point) re-end-pos 'face ' 'u-vm-color-pgp-inline-signature-face))) ))) ;;;###autoload (defun u-vm-color-fontify-buffer () "Fontifies mail-buffers." (interactive) ;;(message "u-vm-color-fontify-buffer") (let ((continued-header-contents "\\(.*\\(\n[ \t]+.*\\)*\\)") (pmin (point-min)) (buffer-modified (buffer-modified-p)) (header-end (or (save-excursion (goto-char (point-min)) (re-search-forward "^[ \t]*$" (point-max) t)) (point-min)))) (u-vm-color-fontify-regexp pmin header-end (concat "^\\([A-Z][-A-Za-z0-9]+:\\) " continued-header-contents) '((1 u-vm-color-header-face) (2 u-vm-color-default-face))) (u-vm-color-fontify-regexp pmin header-end (concat "^Date: " continued-header-contents) '((1 u-vm-color-date-face))) (u-vm-color-fontify-regexp pmin header-end (concat "^Subject: " continued-header-contents) '((1 u-vm-color-subject-face))) (u-vm-color-fontify-regexp pmin header-end (concat "^\\(From\\|Sender\\): " continued-header-contents) '((2 u-vm-color-author-face))) (u-vm-color-fontify-regexp pmin header-end (concat "^\\(To\\|Cc\\|Bcc\\|Fcc\\): " continued-header-contents) '((2 u-vm-color-recipient-face))) ;; signature (u-vm-color-fontify-signature header-end (point-max)) ;; PGP-signatures (u-vm-color-fontify-pgp-signature header-end (point-max)) ;; citations (u-vm-color-fontify-regexp header-end (point-max) "^ *[-A-Za-z0-9]*> *.*$" '((0 u-vm-color-citation-1-face))) (u-vm-color-fontify-regexp header-end (point-max) "^ *[-A-Za-z0-9]*> *\\([-A-Za-z0-9]*> *.*\\)$" '((1 u-vm-color-citation-2-face))) (u-vm-color-fontify-regexp header-end (point-max) (concat "^ *[-A-Za-z0-9]*> *[-A-Za-z0-9]*> *" "\\([-A-Za-z0-9]*> *.*\\)$") '((1 u-vm-color-citation-3-face))) (u-vm-color-fontify-regexp header-end (point-max) (concat "^ *[-A-Za-z0-9]*> *[-A-Za-z0-9]*> *" "[-A-Za-z0-9]*> *\\([-A-Za-z0-9]*> *" ".*\\)$") '((1 u-vm-color-citation-4-face))) (u-vm-color-fontify-regexp header-end (point-max) (concat "^ *[-A-Za-z0-9]*> *[-A-Za-z0-9]*> *" "[-A-Za-z0-9]*> *[-A-Za-z0-9]*> *" "\\([-A-Za-z0-9]*> *.*\\)$") '((1 u-vm-color-citation-5-face))) ;; Spamassassin preview block (u-vm-color-fontify-regexp header-end (point-max) (concat "^Content preview:" "\\([^\n]*\n\\( +[^\n]*\n\\)*\\)") '((1 u-vm-color-spamassassin-face))) (vm-restore-buffer-modified-p buffer-modified (current-buffer)))) ;;;###autoload (defun u-vm-color-fontify-buffer-even-more () "Temporarily widen buffer and call `u-vm-color-fontify-buffer'." (save-restriction (widen) ;;(message "u-vm-color-fontify-even-more: %d %d" (point-min) (point-max)) (u-vm-color-fontify-buffer))) ;;; u-vm-color.el ends here vm-8.2.0b/lisp/vm-reply.el0000755000175000017500000024006011676442160015637 0ustar srivastasrivasta;;; vm-reply.el --- Mailing, forwarding, and replying commands ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;;; Interface: ;; Interactive commands: ;; ;; vm-yank-message: (message) -> unit ;; vm-yank-message-other-folder: (folder) -> unit ;; vm-mail-send-and-exit: () -> unit ;; vm-mail-send: () -> unit ;; vm-do-fcc-before-mime-encode: () -> unit ;; vm-reply: (count) -> unit ;; vm-reply-other-frame: (count) -> unit ;; vm-reply-include-text: (count) -> unit ;; vm-reply-include-text-other-frame: (count) -> unit ;; vm-followup: (count) -> unit ;; vm-followup-other-frame: (count) -> unit ;; vm-followup-include-text: (count) -> unit ;; vm-followup-include-text-other-frame: (count) -> unit ;; vm-forward-message: (&optional bool message-list) -> unit ;; vm-forward-message-plain: () -> unit ;; vm-forward-message-other-frame: () -> unit ;; vm-forward-message-plain-other-frame: () -> unit ;; vm-forward-message-all-headers: () -> unit ;; vm-forward-message-all-headers-other-frame: () -> unit ;; vm-resend-message: () -> unit ;; vm-resend-message-other-frame: () -> unit ;; vm-resend-bounced-message: () -> unit ;; vm-resend-bounced-message-other-frame: () -> unit ;; vm-send-digest: (&optional preamble-line list) -> unit ;; vm-send-digest-other-frame: (&optional preamble-line list) -> unit ;; vm-send-rfc934-digest: (&optional preamble-line list) -> unit ;; vm-send-rfc934-digest-other-frame: (&optional preamble-line list) -> unit ;; vm-send-rfc1153-digest: (&optional preamble-line list) -> unit ;; vm-send-rfc1153-digest-other-frame: (&optional preamble-line list) -> unit ;; vm-send-mime-digest: (&optional preamble-line list) -> unit ;; vm-send-mime-digest-other-frame: (&optional preamble-line list) -> unit ;; vm-continue-composing-message () -> unit ;; vm-mail-to-mailto-url: (url) -> unit ;; vm-preview-composition: () -> unit ;; ;; vm-mail-mode-show-headers: () -> unit ;; vm-mail-mode-hide-headers: () -> unit ;;; Code: (provide 'vm-reply) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-mime) (require 'vm-digest) (require 'vm-undo) ;; (require 'vm-delete) ;; (require 'vm-imap) ) (declare-function vm-mode "vm" (&optional read-only)) (declare-function vm-session-initialization "vm" ()) (declare-function get-itimer "vm-xemacs.el" (name)) (declare-function mail-strip-quoted-names "ext:mail-utils" (address)) (declare-function mail-fetch-field "ext:mail-utils" (field-name &optional last all list)) (declare-function mail-send "ext:sendmail" ()) (declare-function mail-do-fcc "ext:sendmail" (header-end)) (declare-function mail-text "ext:sendmail" ()) (declare-function mail-position-on-field "ext:sendmail" (field &optional soft)) (declare-function mail-mode "ext:sendmail" ()) (declare-function build-mail-aliases "ext:mailalias" (&optional file)) (defun vm-add-reply-subject-prefix (message &optional start) (when (not start) (goto-char (point-min)) (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max)) (forward-char 1) (setq start (point))) (goto-char start) (if (and message vm-included-text-attribution-format) (let ((vm-summary-uninteresting-senders nil)) (insert (vm-summary-sprintf vm-included-text-attribution-format message)))) (while (re-search-forward "^" (point-max) t) (insert vm-included-text-prefix))) ;;;###autoload (defun vm-fill-long-lines-in-reply () (interactive) (let ((vm-word-wrap-paragraphs vm-word-wrap-paragraphs-in-reply) ; doesn't work well with fill-prefixes (vm-paragraph-fill-column vm-fill-long-lines-in-reply-column)) (vm-fill-paragraphs-containing-long-lines vm-fill-paragraphs-containing-long-lines-in-reply (save-excursion (goto-char (point-min)) (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max)) (forward-line 1) (point)) (point-max)))) ;;;###autoload (defun vm-do-reply (to-all include-text count) "Set up a VM composition buffer for sending a reply (and switch the focus to that buffer?). The reply is sent to the current message in the folder buffer or other selected messages. The dynamically bound variable `vm-enable-thread-operations' should be bound to nil before calling this function in order to avoid surprises for the user. The argument TO-ALL says whether the reply should go to all the recipients of the original messages. INCLUDE-TEXT says whether the body of those messages should be included in the reply. COUNT is the prefix argument indicating how many consecutive messages of the folder are involved in this reply." (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Reply to")) (dir default-directory) (message-pointer vm-message-pointer) (case-fold-search t) to cc subject in-reply-to references mp tmp tmp2 newsgroups) (vm-retrieve-operable-messages count mlist) (when (and include-text vm-include-text-from-presentation (> (length mlist) 1)) (error "Including presentation is possible for only a single message")) (setq mp mlist) (while mp (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:" ", ")) (unless (vm-ignored-reply-to tmp) (add-to-list 'to tmp))) ((setq tmp (vm-get-header-contents (car mp) "From:" ", ")) (add-to-list 'to tmp)) ;; bad, but better than nothing for some ((setq tmp (vm-grok-From_-author (car mp))) (add-to-list 'to tmp)) (t (error "No From: or Reply-To: header in message"))) (let ((this-subject (vm-get-header-contents (car mp) "Subject:")) (this-reply-to (and vm-in-reply-to-format (let ((vm-summary-uninteresting-senders nil)) (vm-summary-sprintf vm-in-reply-to-format (car mp)))))) (if (and this-subject vm-reply-subject-prefix (not (string-match vm-reply-subject-prefix this-subject))) (setq this-subject (concat vm-reply-subject-prefix this-subject))) (unless subject (setq subject (concat this-subject (if (cdr mlist) (format " [and %d more messages]" (length (cdr mlist))))))) (setq in-reply-to (if in-reply-to (concat in-reply-to ",\n\t" this-reply-to) this-reply-to))) (when to-all (setq tmp (vm-get-header-contents (car mp) "To:" ", ")) (setq tmp2 (vm-get-header-contents (car mp) "Cc:" ", ")) (when tmp (if cc (setq cc (concat cc "," tmp)) (setq cc tmp))) (when tmp2 (if cc (setq cc (concat cc "," tmp2)) (setq cc tmp2)))) (setq references (cons (or (vm-get-header-contents (car mp) "References:" " ") (vm-get-header-contents (car mp) "In-reply-to:" " ")) (cons (vm-get-header-contents (car mp) "Message-ID:" " ") references))) (setq newsgroups (cons (or (and to-all (vm-get-header-contents (car mp) "Followup-To:" ",")) (vm-get-header-contents (car mp) "Newsgroups:" ",")) newsgroups)) (setq mp (cdr mp))) (when to (setq tmp (car to)) (setq to (cdr to)) (while to (setq tmp (concat tmp ", " (car to))) (setq to (cdr to))) (setq to tmp)) (when vm-strip-reply-headers (let ((mail-use-rfc822 t)) (and to (setq to (mail-strip-quoted-names to))) (and cc (setq cc (mail-strip-quoted-names cc))))) (setq to (vm-parse-addresses to) cc (vm-parse-addresses cc)) (when vm-reply-ignored-addresses (setq to (vm-strip-ignored-addresses to) cc (vm-strip-ignored-addresses cc))) (setq to (vm-delete-duplicates to nil t)) (setq cc (vm-delete-duplicates (append (vm-delete-duplicates cc nil t) to (copy-sequence to)) t t)) (when to (setq to (mapconcat 'identity to ",\n "))) (when cc (setq cc (mapconcat 'identity cc ",\n "))) (when (null to) (setq to cc cc nil)) (setq references (delq nil references) references (mapconcat 'identity references " ") references (vm-parse references "[^<]*\\(<[^>]+>\\)") references (vm-delete-duplicates references) references (if references (mapconcat 'identity references "\n\t"))) (setq newsgroups (delq nil newsgroups) newsgroups (mapconcat 'identity newsgroups ",") newsgroups (vm-parse newsgroups "[ \t\f\r\n,]*\\([^ \t\f\r\n,]+\\)") newsgroups (vm-delete-duplicates newsgroups) newsgroups (if newsgroups (mapconcat 'identity newsgroups ","))) (vm-mail-internal :buffer-name (format "reply to %s%s" (vm-su-full-name (car mlist)) (if (cdr mlist) ", ..." "")) :to to :subject subject :in-reply-to in-reply-to :cc cc :references references :newsgroups newsgroups) (make-local-variable 'vm-reply-list) (setq vm-system-state 'replying vm-reply-list mlist default-directory dir) (when include-text (save-excursion (goto-char (point-min)) (let ((case-fold-search nil)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil 0)) (forward-char 1) (while mlist (save-restriction (narrow-to-region (point) (point)) (vm-yank-message (car mlist)) (goto-char (point-max))) (setq mlist (cdr mlist)))) ;; Set window-start to the top because the yanks processed by ;; emacs-w3m are somehow clobbering the buffer in Emacs 24 (set-window-start nil (point-min))) (when vm-fill-paragraphs-containing-long-lines-in-reply (vm-fill-long-lines-in-reply)) (run-hooks 'vm-reply-hook) (run-hooks 'vm-mail-mode-hook))) (defun vm-strip-ignored-addresses (addresses) (setq addresses (copy-sequence addresses)) (let (re-list list addr-list) (setq re-list vm-reply-ignored-addresses) (while re-list (setq addr-list addresses) (while addr-list (when (string-match (car re-list) (car addr-list)) (setq addresses (delq (car addr-list) addresses))) (setq addr-list (cdr addr-list))) (setq re-list (cdr re-list)))) addresses ) (defun vm-ignored-reply-to (reply-to) (if (and reply-to (not (string= reply-to ""))) (let (re-list result) (setq re-list vm-reply-ignored-reply-tos) (while re-list (if (string-match (car re-list) reply-to) (setq result t re-list nil) (setq re-list (cdr re-list)))) result))) ;;;###autoload (defun vm-mail-yank-default (&optional message) "The default message yank handler when `mail-citation-hook' is set to nil." (save-excursion (vm-reorder-message-headers nil :keep-list vm-included-text-headers :discard-regexp vm-included-text-discard-header-regexp) ;; if all the headers are gone, delete the trailing blank line, too. (when (eq (following-char) ?\n) (delete-char 1)) (when (and message vm-included-text-attribution-format) (let ((vm-summary-uninteresting-senders nil)) (insert (vm-summary-sprintf vm-included-text-attribution-format message)))) ;; turn off zmacs-regions for Lucid Emacs 19 ;; and get around transient-mark-mode in FSF Emacs 19 ;; all this so that (mark) does what it did in v18, sheesh. (let* ((zmacs-regions nil) (mark-even-if-inactive t) (end (mark-marker))) (while (< (point) end) (insert vm-included-text-prefix) (forward-line 1))))) ;;;###autoload (defun vm-yank-message-other-folder (folder) "Like vm-yank-message except the message is yanked from a folder other than the one that spawned the current Mail mode buffer. The name of the folder is read from the minibuffer. Don't call this function from a program." (interactive (list (let ((dir (if vm-folder-directory (expand-file-name vm-folder-directory) default-directory)) (last-command last-command) (this-command this-command)) (read-file-name "Yank from folder: " dir nil t)))) (let ((b (current-buffer)) newbuf sumbuf default result prompt mp) (set-buffer (or (vm-get-file-buffer folder) (find-file-noselect folder))) (setq newbuf (current-buffer)) (unless (eq major-mode 'vm-mode) (vm-mode)) (when vm-presentation-buffer-handle (vm-bury-buffer vm-presentation-buffer-handle)) (when (null vm-message-pointer) (error "No messages in folder %s" folder)) (setq default (vm-number-of (car vm-message-pointer))) (save-excursion (save-window-excursion (save-window-excursion (vm-summarize)) (vm-display vm-summary-buffer t '(vm-yank-message-other-folder) '(vm-yank-message-other-folder composing-message)) (setq sumbuf (current-buffer)) (setq prompt (format "Yank message number: (default %s) " default) result 0) (while (zerop result) (setq result (read-string prompt)) (and (string= result "") default (setq result default)) (setq result (string-to-number result))) (when (null (setq mp (nthcdr (1- result) vm-message-list))) (error "No such message.")))) (set-buffer b) (unwind-protect (let ((vm-mail-buffer newbuf)) (vm-yank-message (car mp))) (vm-bury-buffer newbuf) (vm-bury-buffer sumbuf)))) ;;;###autoload (defun vm-yank-message (message) "Yank message number N into the current buffer at point. When called interactively N is always read from the minibuffer. When called non-interactively the first argument is expected to be a message struct. This command is meant to be used in VM created Mail mode buffers; the yanked message comes from the mail buffer containing the message you are replying to, forwarding, or invoked VM's mail command from. All message headers are yanked along with the text. Point is left before the inserted text, the mark after. Any hook functions bound to `mail-citation-hook' are run, after inserting the text and setting point and mark. For backward compatibility, if mail-citation-hook is set to nil, `mail-yank-hooks' is run instead. If mail-citation-hook and mail-yank-hooks are both nil, this default action is taken: the yanked headers are trimmed as specified by `vm-included-text-headers' and `vm-included-text-discard-header-regexp', and the value of `vm-included-text-prefix' is prepended to every yanked line." (interactive (list ;; What we really want for the first argument is a message struct, ;; but if called interactively, we let the user type in a message ;; number instead. (let (mp default (result 0) prompt (last-command last-command) (this-command this-command)) (save-current-buffer (vm-select-folder-buffer) (setq default (and vm-message-pointer (vm-number-of (car vm-message-pointer))) prompt (if default (format "Yank message number: (default %s) " default) "Yank message number: ")) (while (zerop result) (setq result (read-string prompt)) (and (string= result "") default (setq result default)) (setq result (string-to-number result))) (when (null (setq mp (nthcdr (1- result) vm-message-list))) (error "No such message."))) (car mp)))) (unless (bufferp vm-mail-buffer) (error "This is not a VM Mail mode buffer.")) (unless (buffer-name vm-mail-buffer) (error "The folder buffer containing message %d has been killed." (vm-number-of message))) (vm-display nil nil '(vm-yank-message) '(vm-yank-message composing-message)) (vm-retrieve-operable-messages 1 (list message)) (setq message (vm-real-message-of message)) (let ((layout (vm-mm-layout message)) (start (point)) (end (point-marker))) (save-excursion (cond ((and vm-include-text-from-presentation (not (vm-mime-plain-message-p message)) (or (eq message (car vm-message-pointer)) (progn (message (concat "Can yank presentation for only the " "current message. Using default yank.")) (sit-for 2) nil))) (vm-yank-message-presentation) (setq end (point-marker))) (vm-include-text-basic (vm-yank-message-text message layout) (setq end (point-marker))) (t (vm-yank-message-mime message layout) (setq end (point-marker))) ) ;; decode MIME encoded words so supercite and other ;; mail-citation-hook denizens won't have to eat 'em. (when vm-display-using-mime (save-restriction (narrow-to-region start end) (vm-decode-mime-encoded-words)))) ;; get rid of read-only text properties on the text, as ;; they will only cause trouble. (let ((inhibit-read-only t)) (remove-text-properties (point-min) (point-max) '(read-only nil invisible nil) (current-buffer))) (push-mark end) (save-excursion ;; Move point above the headers which should be at the top of ;; the buffer by this point, and given the push-mark above, mark ;; should now be after the message text. This is the invariant ;; needed by the hook functions called by mail-citation-hook ;; whose doc string states "Each hook function can find the ;; citation between (point) and (mark t)." The upshot of that is ;; that if point equals mark at the end of the buffer, some ;; citation functions will fail with messages similar to ;; "doesn't conform to RFC 822." -- Brent Goodrick, 2009-01-24 ;; But this yanks wrongly! The following line reverted by Uday ;; Reddy, 2009-12-07 ;; (goto-char (point-min)) (cond (mail-citation-hook (run-hooks 'mail-citation-hook)) (mail-yank-hooks (run-hooks 'mail-yank-hooks)) (t (vm-mail-yank-default message)))))) (defun vm-yank-message-presentation () ;; This function is the same as Rob's vm-insert-presentation. ;; It has been reported that it includes the entire mail box on ;; occasion. See Bug #498477. It should not be used until that ;; problem resolved. (let ((start (point))) (vm-insert-region-from-buffer (save-excursion (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) ;; ensure the current message is presented (vm-present-current-message) (vm-show-current-message) (vm-select-folder-buffer) (when vm-presentation-buffer (set-buffer vm-presentation-buffer)) (current-buffer))) (save-excursion (goto-char start) (when (looking-at "From ") (delete-region start (1+ (line-end-position))))))) (defconst vm-mime-yanked-button-format-alist '( ("text" . "[DELETED ATTACHMENT %f, %t]") ("message" . "[DELETED ATTACHMENT %f, %t]") ("audio" . "[DELETED ATTACHMENT %f, %t]") ("video" . "[DELETED ATTACHMENT %f, %t]") ("image" . "[DELETED ATTACHMENT %f, %t]") ("application" . "[DELETED ATTACHMENT %f, %t]") )) (defun vm-yank-message-mime (message layout) ;; This is Rob's new code that uses vm-decode-mime-layout for ;; creating the yanked text, but use the reply-specific settings for ;; filling etc. (let ((vm-word-wrap-paragraphs vm-word-wrap-paragraphs-in-reply) ; doesn't work well with fill-prefixes (vm-fill-paragraphs-containing-long-lines vm-fill-paragraphs-containing-long-lines-in-reply) (vm-paragraph-fill-column vm-fill-long-lines-in-reply-column)) (if (eq layout 'none) (vm-insert-region-from-buffer (vm-buffer-of message) (vm-headers-of message) (vm-text-end-of message)) (vm-insert-region-from-buffer (vm-buffer-of message) (vm-headers-of message) (vm-text-of message)) (save-excursion (goto-char (point-min)) (vm-decode-mime-message-headers)) ;; Use normal MIME decoding but override normal parameter settings (let (;; override the alternative-select-method (vm-mime-alternative-show-method vm-mime-alternative-yank-method) ;; include only text and message/rfc822 types ;; message/external-body should not be included (vm-auto-displayed-mime-content-types '("text" "message/rfc822")) ;; don't include separator for multipart (vm-mime-parts-display-separator "") ;; make MIME buttons look like text unless they are included (vm-mime-button-face (if vm-include-mime-attachments vm-mime-button-face 'default)) (vm-mime-button-mouse-face (if vm-include-mime-attachments vm-mime-button-mouse-face nil)) ;; use different labels (vm-mime-button-format-alist vm-mime-yanked-button-format-alist) ) (vm-decode-mime-layout layout)) ;; Make the MIME buttons attachment buttons (if vm-include-mime-attachments (vm-mime-convert-to-attachment-buttons))))) (defun vm-yank-message-text (message layout) ;; This is the original code for included text (let (new-layout type alternatives parts res insert-start) (if (null (vectorp (vm-mm-layout message))) (let ((b (current-buffer))) (set-buffer (vm-buffer-of message)) (save-restriction (widen) ;; decode MIME encoded words so supercite and other ;; mail-citation-hook denizens won't have to eat 'em. (append-to-buffer b (vm-headers-of message) (vm-text-end-of message)) (set-buffer b))) (setq type (car (vm-mm-layout-type layout))) (setq parts (list layout)) (setq alternatives 0) (vm-insert-region-from-buffer (vm-buffer-of message) (vm-headers-of message) (vm-text-of message)) (while parts (setq layout (car parts)) (cond ((vm-mime-text-type-layout-p layout) (cond ((vm-mime-types-match "text/plain" (car (vm-mm-layout-type layout))) (setq res (vm-mime-display-internal-text/plain layout t))) ((vm-mime-types-match "text/enriched" (car (vm-mm-layout-type layout))) (setq res (vm-mime-display-internal-text/enriched layout))) ((vm-mime-types-match "message/rfc822" (car (vm-mm-layout-type layout))) (setq res (vm-mime-display-internal-message/rfc822 layout))) ;; no text/html for now ;; ((vm-mime-types-match ;; "text/html" ;; (car (vm-mm-layout-type layout))) ;; (setq res (vm-mime-display-internal-text/html ;; layout))) ((member (downcase (car (vm-mm-layout-type layout))) vm-included-mime-types-list) (if (and (not (vm-mm-layout-is-converted layout)) (vm-mime-can-convert (car (vm-mm-layout-type layout))) (setq new-layout (vm-mime-convert-undisplayable-layout layout))) (setq res (vm-decode-mime-layout new-layout)) (setq res (vm-mime-display-internal-text/plain layout t))))) (if res (while (> alternatives 1) (setq parts (cdr parts)) (setq alternatives (1- alternatives))) (when (member (downcase (car (vm-mm-layout-type layout))) vm-included-mime-types-list) ;; charset problems probably ;; just dump the raw bits (setq insert-start (point)) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout insert-start (point)))) (setq parts (cdr parts))) ((vm-mime-composite-type-p (car (vm-mm-layout-type layout))) (when (vm-mime-types-match "multipart/alternative" (car (vm-mm-layout-type layout))) (setq alternatives (length (vm-mm-layout-parts (car parts))))) (setq parts (nconc (copy-sequence (vm-mm-layout-parts (car parts))) (cdr parts)))) (t (setq alternatives (1- alternatives)) (setq parts (cdr parts)))))))) ;;;###autoload (defun vm-mail-send-and-exit (&rest ignored) "Send message and maybe delete the composition buffer. The value of `vm-keep-sent-mesages' determines whether the composition buffer is deleted. If the composition is a reply to a message in a currently visited folder, that message is marked as having been replied to." (interactive "P") (vm-check-for-killed-folder) (when (and (boundp 'mail-alias-file) mail-alias-file (not (eq (user-uid) 0))) (error "Must be superuser to use mail-alias-file. Please set mail-alias-file to nil.")) (let ((b (current-buffer))) (vm-mail-send) (cond ((null (buffer-name b)) ;; dead buffer ;; This improves window configuration behavior in ;; XEmacs. It avoids taking the folder buffer from ;; one frame and attaching it to the selected frame. (set-buffer (window-buffer (selected-window))) (vm-display nil nil '(vm-mail-send-and-exit) '(vm-mail-send-and-exit reading-message startup))) (t (vm-display b nil '(vm-mail-send-and-exit) '(vm-mail-send-and-exit reading-message startup)) (vm-bury-buffer b))))) (defun vm-keep-mail-buffer (buffer) (vm-keep-some-buffers buffer 'vm-kept-mail-buffers vm-keep-sent-messages)) (defun vm-help-tale () (save-excursion (goto-char (point-min)) (while (vm-match-header) (if (not (vm-match-header "To:\\|Resent-To:\\|Cc:\\|Resent-Cc:")) (goto-char (vm-matched-header-end)) (goto-char (vm-matched-header-contents-start)) (if (re-search-forward "[^, \t][ \t]*\n[ \t\n]+[^ \t\n]" (vm-matched-header-contents-end) t) (error "tale is an idiot, and so are you. :-)")) (goto-char (vm-matched-header-end)))))) (defun vm-mail-mode-insert-message-id-maybe () (when vm-mail-header-insert-message-id (save-restriction (save-excursion (let ((resent nil)) (if (or (vm-mail-mode-get-header-contents "Resent-To:") (vm-mail-mode-get-header-contents "Resent-Cc:") (vm-mail-mode-get-header-contents "Resent-Bcc:")) (progn (vm-mail-mode-remove-header "Resent-Message-ID:") (setq resent t)) (vm-mail-mode-remove-header "Message-ID:")) (widen) (goto-char (point-min)) (insert (format "%sMessage-ID: %s\n" (if resent "Resent-" "") (vm-make-message-id)))))))) (defun vm-mail-mode-insert-date-maybe () (if (not vm-mail-header-insert-date) nil (save-restriction (save-excursion (let* ((timezone (car (current-time-zone))) (hour (/ timezone 3600)) (min (/ (- timezone (* hour 3600)) 60)) (time (current-time)) (resent nil)) (if (or (vm-mail-mode-get-header-contents "Resent-To:") (vm-mail-mode-get-header-contents "Resent-Cc:") (vm-mail-mode-get-header-contents "Resent-Bcc:")) (progn (vm-mail-mode-remove-header "Resent-Date:") (setq resent t)) (vm-mail-mode-remove-header "Date:")) (widen) (goto-char (point-min)) (insert (format "%sDate: " (if resent "Resent-" "")) (capitalize (car (nth (string-to-number (format-time-string "%w" time)) vm-weekday-alist))) ", " ;; %e generated " 2". Go from string to int ;; to string to get rid of the blank. (int-to-string (string-to-number (format-time-string "%e" time))) " " (capitalize (car (nth (1- (string-to-number (format-time-string "%m" time))) vm-month-alist))) (format-time-string " %Y %H:%M:%S" time) (format " %s%02d%02d" (if (< timezone 0) "-" "+") (abs hour) (abs min)) ;; localization in Europe and elsewhere can cause %Z to return ;; 8-bit chars, which are forbidden in headers. ;; (format-time-string " (%Z)" time) "\n")))))) (defun vm-mail-mode-remove-message-id-maybe () (if vm-mail-header-insert-message-id (let ((resent nil)) (if (or (vm-mail-mode-get-header-contents "Resent-To:") (vm-mail-mode-get-header-contents "Resent-Cc:") (vm-mail-mode-get-header-contents "Resent-Bcc:")) (progn (vm-mail-mode-remove-header "Resent-Message-ID:") (setq resent t)) (vm-mail-mode-remove-header "Message-ID:"))))) (defun vm-mail-mode-remove-date-maybe () (if vm-mail-header-insert-date (let ((resent nil)) (if (or (vm-mail-mode-get-header-contents "Resent-To:") (vm-mail-mode-get-header-contents "Resent-Cc:") (vm-mail-mode-get-header-contents "Resent-Bcc:")) (progn (vm-mail-mode-remove-header "Resent-Date:") (setq resent t)) (vm-mail-mode-remove-header "Date:"))))) ;;;###autoload (defun vm-mail-get-header-contents (header-name-regexp &optional clump-sep) "Return the contents of the header(s) matching HEADER-NAME-REGEXP for the message in the current-buffer. The result will be a string that is mime-encoded. The optional argument CLUMP-SEP, if present, should be a string, which can be used as a separator to concatenate the fields of multiple header lines which might match HEADER-NAME-REGEXP. This function is a variant of `vm-get-header-contents'." (let ((contents nil) (text-of-message 0) (regexp (concat "^\\(" header-name-regexp "\\)"))) (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max) t) (setq text-of-message (match-end 0)) (error "No mail header separator found!")) (goto-char (point-min)) (let ((case-fold-search t)) (while (and (or (null contents) clump-sep) (re-search-forward regexp text-of-message t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header))) (if contents (setq contents (concat contents clump-sep (vm-matched-header-contents))) (setq contents (vm-matched-header-contents))))) contents))) (defvar vm-dont-ask-coding-system-question nil) (cond ((and vm-fsfemacs-mule-p (fboundp 'select-message-coding-system) (not (fboundp 'vm-old-select-message-coding-system))) (fset 'vm-old-select-message-coding-system (symbol-function 'select-message-coding-system)) (defun select-message-coding-system (&rest ignored) (if vm-dont-ask-coding-system-question nil (apply 'vm-old-select-message-coding-system ignored))))) (defvar select-safe-coding-system-function) (defvar coding-system-for-write) ;;;###autoload (defun vm-mail-send () "Just like mail-send except that VM flags the appropriate message(s) as replied to, forwarded, etc, if appropriate." (interactive) (if vm-tale-is-an-idiot (vm-help-tale)) ;; protect value of this-command from minibuffer read (let ((this-command this-command)) (when (and vm-confirm-mail-send (not (y-or-n-p "Send the message? "))) (error "Message not sent."))) (vm-mail-mode-show-headers) (save-excursion (run-hooks 'vm-mail-send-hook)) (vm-mail-mode-insert-date-maybe) (vm-mail-mode-insert-message-id-maybe) ;; send mail using MIME if user requests it and if the buffer ;; has not already been MIME encoded. (when (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:"))) (when vm-do-fcc-before-mime-encode (vm-do-fcc-before-mime-encode)) (vm-mime-encode-composition)) (when vm-mail-reorder-message-headers (vm-reorder-message-headers nil :keep-list vm-mail-header-order :discard-regexp 'none)) ;; this to prevent Emacs 19 from asking whether a message that ;; has already been sent should be sent again. VM renames mail ;; buffers after the message has been sent, so the user should ;; already know that the message has been sent. (set-buffer-modified-p t) (let ((composition-buffer (current-buffer)) ;; preserve these in case the composition buffer gets ;; killed. (vm-reply-list vm-reply-list) (vm-forward-list vm-forward-list) (vm-redistribute-list vm-redistribute-list)) ;; fragment message using message/partial if it is too big. (if (and vm-send-using-mime (integerp vm-mime-max-message-size) (> (buffer-size) vm-mime-max-message-size)) (let (list) (setq list (vm-mime-fragment-composition vm-mime-max-message-size)) (while list (save-excursion (set-buffer (car list)) (vm-mail-send) (kill-buffer (car list))) (setq list (cdr list))) ;; what mail-send would have done (set-buffer-modified-p nil)) ;; don't want a buffer change to occur here ;; save-excursion to be sure. ;; ;; also protect value of this-command from minibuffer reads (let ((this-command this-command) ;; set up coding-system-for-write so that FCC uses ;; the correct coding system to save the message into ;; a folder. (coding-system-for-write (if (stringp mail-archive-file-name) (vm-get-file-line-ending-coding-system mail-archive-file-name) (and (boundp 'coding-system-for-write) coding-system-for-write))) ;; For Emacs 21. (mail-send-nonascii t) (sendmail-coding-system (vm-binary-coding-system)) (vm-dont-ask-coding-system-question t) (select-safe-coding-system-function nil)) (save-excursion (mail-send)))) ;; be careful, something could have killed the composition ;; buffer inside mail-send. (when (eq (current-buffer) composition-buffer) (cond ((eq vm-system-state 'replying) (vm-mail-mark-replied)) ((eq vm-system-state 'forwarding) (vm-mail-mark-forwarded)) ((eq vm-system-state 'redistributing) (vm-mail-mark-redistributed))) (vm-rename-current-mail-buffer) (vm-keep-mail-buffer (current-buffer))) (vm-display nil nil '(vm-mail-send) '(vm-mail-send)))) ;;;###autoload (defun vm-do-fcc-before-mime-encode () "The name says it all. Sometimes you may want to save a message unencoded, specifically not to waste storage for attachments which are stored on disk anyway." (interactive) (save-excursion (goto-char (point-min)) (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max)) (delete-region (match-beginning 0) (match-end 0)) (let ((header-end (point-marker))) (unwind-protect (mail-do-fcc header-end) (goto-char header-end) (insert mail-header-separator))))) ;;;###autoload (defun vm-mail-mode-get-header-contents (header-name-regexp) (let (regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^" (regexp-quote mail-header-separator) "$\\)")) (save-excursion (save-restriction (widen) (goto-char (point-min)) (let ((case-fold-search t)) (if (and (re-search-forward regexp nil t) (match-beginning 1) (progn (goto-char (match-beginning 0)) (vm-match-header))) (vm-matched-header-contents) nil )))))) ;;;###autoload (defun vm-mail-mode-remove-header (header-name-regexp) (let (regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^" (regexp-quote mail-header-separator) "$\\)")) (save-excursion (save-restriction (widen) (goto-char (point-min)) (let ((case-fold-search t)) (if (and (re-search-forward regexp nil t) (match-beginning 1) (progn (goto-char (match-beginning 0)) (vm-match-header))) (delete-region (vm-matched-header-start) (vm-matched-header-end)) nil )))))) (defun vm-rename-current-mail-buffer () (if vm-rename-current-buffer-function (funcall vm-rename-current-buffer-function) (let ((case-fold-search nil)) (if (not (string-match "^sent " (buffer-name))) (let (prefix name n) (if (not (string-match "^mail to \\?" (buffer-name))) (setq prefix (format "sent %s" (buffer-name))) (let (recipients) (cond ((not (zerop (length (setq recipients (mail-fetch-field "To")))))) ((not (zerop (length (setq recipients (mail-fetch-field "Cc")))))) ((not (zerop (length (setq recipients (mail-fetch-field "Bcc")))))) ; can't happen?!? (t (setq recipients "the horse with no name"))) (setq prefix (format "sent mail to %s" recipients)))) (if (> (length prefix) 44) (setq prefix (concat (substring prefix 0 40) " ..."))) (setq name prefix n 2) (while (get-buffer name) (setq name (format "%s<%d>" prefix n)) (vm-increment n)) (rename-buffer name)))))) (defun vm-mail-mark-replied () (save-excursion (let ((mp vm-reply-list)) (while mp (if (null (buffer-name (vm-buffer-of (car mp)))) () (set-buffer (vm-buffer-of (car mp))) (cond ((and (memq (car mp) vm-message-list) (null (vm-replied-flag (car mp)))) (vm-set-replied-flag (car mp) t)))) (setq mp (cdr mp))) (vm-update-summary-and-mode-line)))) (defun vm-mail-mark-forwarded () (save-excursion (let ((mp vm-forward-list)) (while mp (if (null (buffer-name (vm-buffer-of (car mp)))) () (set-buffer (vm-buffer-of (car mp))) (cond ((and (memq (car mp) vm-message-list) (null (vm-forwarded-flag (car mp)))) (vm-set-forwarded-flag (car mp) t)))) (setq mp (cdr mp))) (vm-update-summary-and-mode-line)))) (defun vm-mail-mark-redistributed () (save-excursion (let ((mp vm-redistribute-list)) (while mp (if (null (buffer-name (vm-buffer-of (car mp)))) () (set-buffer (vm-buffer-of (car mp))) (cond ((and (memq (car mp) vm-message-list) (null (vm-redistributed-flag (car mp)))) (vm-set-redistributed-flag (car mp) t)))) (setq mp (cdr mp))) (vm-update-summary-and-mode-line)))) ;;;###autoload (defun vm-reply (count) "Reply to the sender of the current message. Numeric prefix argument N means to reply to the current message plus the next N-1 messages. A negative N means reply to the current message and the previous N-1 messages. If invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages will be replied to. You will be placed into a standard Emacs Mail mode buffer to compose and send your message. See the documentation for the function `mail' for more info. Note that the normal binding of C-c C-y in the reply buffer is automatically changed to `vm-yank-message' during a reply. This allows you to yank any message from the current folder into a reply. Normal VM commands may be accessed in the reply buffer by prefixing them with C-c C-v." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vm-enable-thread-operations nil)) (vm-do-reply nil nil count))) ;;;###autoload (defun vm-reply-include-text (count) "Reply to the sender (only) of the current message and include text from the message. See the documentation for function vm-reply for details." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vm-enable-thread-operations nil)) (vm-do-reply nil t count))) ;;;###autoload (defun vm-followup (count) "Reply to all recipients of the current message. See the documentation for the function vm-reply for details." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vm-enable-thread-operations nil)) (vm-do-reply t nil count))) ;;;###autoload (defun vm-followup-include-text (count) "Reply to all recipients of the current message and include text from the message. See the documentation for the function vm-reply for details." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vm-enable-thread-operations nil)) (vm-do-reply t t count))) ;;;###autoload (defun vm-forward-message-all-headers () "Like `vm-forward-message' but forwards all the headers." (interactive) (let ((vm-forwarded-headers nil) (vm-unforwarded-header-regexp "only-drop-this-header") ;; set these because vm-forward-message calls vm-send-digest ;; if there is more than one message to be forwarded. (vm-rfc934-digest-headers nil) (vm-rfc934-digest-discard-header-regexp "only-drop-this-header") (vm-rfc1153-digest-headers nil) (vm-rfc1153-digest-discard-header-regexp "only-drop-this-header") (vm-mime-digest-headers nil) (vm-mime-digest-discard-header-regexp "only-drop-this-header")) (vm-forward-message))) ;;;###autoload (defun vm-forward-message-plain () "Forward the current message in plain text to one or more recipients. You will be placed in a Mail mode buffer as you would with a reply, but you must fill in the \"To:\" header and perhaps the \"Subject:\" header manually. Any MIME attachments in the forwarded message will be attached to the outgoing message. See `vm-forward-message' for other forms of forwarding." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vm-forwarded-headers vm-forwarded-headers-plain) (vm-unforwarded-header-regexp vm-unforwarded-header-regexp-plain)) (vm-forward-message t (vm-select-operable-messages 1 (vm-interactive-p) "Forward")))) ;;;###autoload (defun vm-forward-message (&optional plain mlist) "Forward the current message to one or more recipients. You will be placed in a Mail mode buffer as you would with a reply, but you must fill in the \"To:\" header and perhaps the \"Subject:\" header manually. See `vm-forward-message-plain' for forwarding messages in plain text." ;; The optional argument PLAIN says that the forwarding should be ;; done as plain text, irrespective of the value of ;; `vm-forwarding-digest-type'. ;; The optional argument MLIST is the list of messages to be ;; forwarded. (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((dir default-directory) (miming (and vm-send-using-mime (not plain) (equal vm-forwarding-digest-type "mime"))) reply-buffer header-end) (unless mlist (setq mlist (vm-select-operable-messages 1 (vm-interactive-p) "Forward"))) (if (cdr mlist) ;; multiple message forwarding (progn ;; (unless (or (not plain) ;; (y-or-n-p ;; "Use encapsulated forwarding for multiple messages? ")) ;; (error "Aborted")) ;; (setq plain nil) (let ((vm-digest-send-type (if plain nil vm-forwarding-digest-type))) ;; (setq this-command 'vm-next-command-uses-marks) ;; (command-execute 'vm-send-digest) (vm-send-digest nil mlist))) ;; single message forwarding (vm-retrieve-operable-messages 1 mlist) (save-restriction (widen) (vm-mail-internal :buffer-name (format "forward of %s's note re: %s" (vm-su-full-name (car vm-message-pointer)) (vm-su-subject (car vm-message-pointer))) :subject (when vm-forwarding-subject-format (let ((vm-summary-uninteresting-senders nil)) (vm-summary-sprintf vm-forwarding-subject-format (car mlist))))) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list mlist default-directory dir) ;; current-buffer is now the reply buffer (if miming (progn (setq reply-buffer (current-buffer)) (set-buffer (vm-make-work-buffer "*vm-forward-buffer*")) (setq header-end (point)) (insert "\n")) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (goto-char (match-end 0)) (setq header-end (match-beginning 0))) (cond ((or plain (null vm-forwarding-digest-type)) (vm-no-frills-encapsulate-message (car mlist) (append vm-forwarded-headers vm-forwarded-mime-headers) vm-unforwarded-header-regexp)) ((equal vm-forwarding-digest-type "mime") (vm-mime-encapsulate-messages mlist ;; :keep-list nil :discard-regexp "none" :keep-list vm-forwarded-headers :discard-regexp vm-unforwarded-header-regexp :always-use-digest nil) (goto-char header-end) (insert "MIME-Version: 1.0\n") (insert "Content-Type: message/rfc822\n") (insert "Content-Transfer-Encoding: " (vm-determine-proper-content-transfer-encoding (point) (point-max)) "\n") (insert "Content-Description: forwarded message\n") ;; eight bit chars will get \201 prepended if we ;; don't do this. (when vm-fsfemacs-mule-p (set-buffer-multibyte t))) ; is this safe? ((equal vm-forwarding-digest-type "rfc934") (vm-rfc934-encapsulate-messages vm-forward-list (append vm-forwarded-headers vm-forwarded-mime-headers) vm-unforwarded-header-regexp)) ((equal vm-forwarding-digest-type "rfc1153") (vm-rfc1153-encapsulate-messages vm-forward-list (append vm-forwarded-headers vm-forwarded-mime-headers) vm-unforwarded-header-regexp))) (when miming (let ((work-buffer (current-buffer))) (set-buffer reply-buffer) ; intended buffer change (mail-text) (vm-attach-object work-buffer :type "message/rfc822" :params nil :disposition '("inline") :description "forwarded message" :mimed t) (add-hook 'kill-buffer-hook `(lambda () (if (eq ,reply-buffer (current-buffer)) (kill-buffer ,work-buffer))) ))) (mail-position-on-field "To")) (run-hooks 'vm-forward-message-hook) (run-hooks 'vm-mail-mode-hook)))) ;;;###autoload (defun vm-resend-bounced-message () "Extract the original text from a bounced message and resend it. You will be placed in a Mail mode buffer with the extracted message and you can change the recipient address before resending the message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((b (current-buffer)) start (dir default-directory) (layout (vm-mm-layout (car vm-message-pointer))) (lim (vm-text-end-of (car vm-message-pointer)))) ;; We only want to select one message here (vm-retrieve-operable-messages 1 (list (car vm-message-pointer))) (save-restriction (widen) (if (or (not (vectorp layout)) (not (setq layout (vm-mime-layout-contains-type layout "message/rfc822")))) (save-excursion (goto-char (vm-text-of (car vm-message-pointer))) (let ((case-fold-search t)) ;; What a wonderful world it would be if mailers ;; used a single message encapsulation standard ;; instead of all the weird variants. It is ;; useless to try to cover them all. This simple ;; rule should cover the sanest of the formats (if (not (re-search-forward "^Received:" lim t)) (error "This doesn't look like a bounced message.")) (beginning-of-line) (setq start (point))))) ;; briefly nullify vm-mail-header-from to keep vm-mail-internal ;; from inserting another From header. (let ((vm-mail-header-from nil)) (vm-mail-internal :buffer-name (format "retry of bounce from %s" (vm-su-from (car vm-message-pointer))))) (goto-char (point-min)) (if (vectorp layout) (progn (setq start (point)) (vm-mime-insert-mime-body layout) (vm-mime-transfer-decode-region layout start (point))) (insert-buffer-substring b start lim)) (delete-region (point) (point-max)) (goto-char (point-min)) ;; delete all but pertinent headers (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(X-VM-\\|Status:\\|Sender:\\)") (vm-reorder-message-headers nil :keep-list vm-resend-bounced-headers :discard-regexp vm-resend-bounced-discard-header-regexp) (if (search-forward "\n\n" nil t) (replace-match "") (goto-char (point-max))) (insert ?\n mail-header-separator ?\n) (goto-char (point-min)) (if vm-mail-header-from (insert "Resent-From: " vm-mail-header-from ?\n)) (if (vm-mail-mode-get-header-contents "Resent-To:") (mail-position-on-field "Resent-To") (insert "Resent-To: \n") (forward-char -1)) (setq default-directory dir))) (run-hooks 'vm-resend-bounced-message-hook) (run-hooks 'vm-mail-mode-hook)) ;;;###autoload (defun vm-resend-message () "Resend the current message to someone else. The current message will be copied to a Mail mode buffer and you can edit the message and send it as usual. NOTE: since you are doing a resend, a Resent-To header is provided for you to fill in the new recipient list. If you don't fill in this header, what happens when you send the message is undefined. You may also create a Resent-Cc header." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (save-restriction (widen) (let ((b (current-buffer)) (dir default-directory) (vmp vm-message-pointer) (start (vm-headers-of (car vm-message-pointer))) (lim (vm-text-end-of (car vm-message-pointer)))) ;; We only want to select one message here (vm-retrieve-operable-messages 1 (list (car vm-message-pointer))) ;; briefly nullify vm-mail-header-from to keep vm-mail-internal ;; from inserting another From header. (let ((vm-mail-header-from nil)) (vm-mail-internal :buffer-name (format "resend of %s's note re: %s" (vm-su-full-name (car vm-message-pointer)) (vm-su-subject (car vm-message-pointer))))) (goto-char (point-min)) (insert-buffer-substring b start lim) (delete-region (point) (point-max)) (goto-char (point-min)) (if vm-mail-header-from (insert "Resent-From: " vm-mail-header-from ?\n)) (insert "Resent-To: \n") (if mail-self-blind (insert "Bcc: " (cond ((and vm-xemacs-p (fboundp 'user-mail-address)) (user-mail-address)) ((and (boundp 'user-mail-address) (stringp user-mail-address)) user-mail-address) (t (user-login-name))) ?\n)) (if mail-archive-file-name (insert "FCC: " mail-archive-file-name ?\n)) ;; delete all but pertinent headers (vm-reorder-message-headers nil :keep-list nil :discard-regexp "\\(X-VM-\\|Status:\\|Sender:\\)") (vm-reorder-message-headers nil :keep-list vm-resend-headers :discard-regexp vm-resend-discard-header-regexp) (if (search-forward "\n\n" nil t) (replace-match "")) (insert ?\n mail-header-separator ?\n) (goto-char (point-min)) (mail-position-on-field "Resent-To") (make-local-variable 'vm-redistribute-list) (setq vm-system-state 'redistributing vm-redistribute-list (list (car vmp)) default-directory dir) (run-hooks 'vm-resend-message-hook) (run-hooks 'vm-mail-mode-hook)))) ;;;###autoload (defun vm-send-digest (&optional prefix mlist) "Send a digest of all messages in the current folder to recipients. The type of the digest is specified by the variable `vm-digest-send-type'. You will be placed in a Mail mode buffer as is usual with replies, but you must fill in the \"To:\" and \"Subject:\" headers manually. Prefix arg means to insert a list of preamble lines at the beginning of the digest. One line is generated for each message being digestified. The variable `vm-digest-preamble-format' determines the format of the preamble lines. If invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages will be put into the digest. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are included in the digest." (interactive "P") (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((dir default-directory) (miming (and vm-send-using-mime (equal vm-digest-send-type "mime"))) mp mail-buffer work-buffer b ms start header-end boundary) (unless mlist ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-operable-messages for marks or threads. (setq mlist (vm-select-operable-messages 1 (vm-interactive-p) "Send as digest"))) ;; if messages were selected use them, otherwise the whole folder (cond ((cdr mlist) (vm-retrieve-operable-messages 1 mlist)) ((not (y-or-n-p "Send the entire folder as a digest? ")) (error "aborted")) ((vm-find vm-message-list (lambda (m) (vm-body-to-be-retrieved-of m))) (error "Headers-only external messages present in the folder")) (t (setq mlist vm-message-list))) (save-restriction (widen) (vm-mail-internal :buffer-name (format "digest from %s" (buffer-name)) :subject (and vm-forwarding-subject-format (let ((vm-summary-uninteresting-senders nil)) (concat (vm-summary-sprintf vm-forwarding-subject-format (car mlist)) (if (cdr mlist) (format " [and %d more messages]" (length (cdr mlist)))))))) ;; current buffer is mail-buffer (setq mail-buffer (current-buffer)) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list mlist default-directory dir) (if miming (progn ;; buffer is changed for only the mime case (setq work-buffer (vm-make-work-buffer "*vm-digest-buffer*")) (set-buffer work-buffer) (setq header-end (point)) (insert "\n") (setq start (point-marker))) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "\n")) (goto-char (match-end 0)) (setq start (point-marker) header-end (match-beginning 0))) (vm-inform 5 "Building %s digest..." vm-digest-send-type) (cond ((equal vm-digest-send-type "mime") (setq boundary (vm-mime-encapsulate-messages mlist :keep-list vm-mime-digest-headers :discard-regexp vm-mime-digest-discard-header-regexp :always-use-digest t)) (goto-char header-end) (insert "MIME-Version: 1.0\n") (insert (if vm-mime-avoid-folding-content-type "Content-Type: multipart/digest; boundary=\"" "Content-Type: multipart/digest;\n\tboundary=\"") boundary "\"\n") (insert "Content-Transfer-Encoding: " (vm-determine-proper-content-transfer-encoding (point) (point-max)) "\n")) ((equal vm-digest-send-type "rfc934") (vm-rfc934-encapsulate-messages mlist vm-rfc934-digest-headers vm-rfc934-digest-discard-header-regexp)) ((equal vm-digest-send-type "rfc1153") (vm-rfc1153-encapsulate-messages mlist vm-rfc1153-digest-headers vm-rfc1153-digest-discard-header-regexp)) ((equal vm-digest-send-type nil) (while mlist (vm-no-frills-encapsulate-message (car mlist) (append vm-forwarded-headers vm-forwarded-mime-headers) vm-unforwarded-header-regexp) ; nil? (insert "\n") (setq mlist (cdr mlist))))) (goto-char start) (setq mp mlist) (when miming ;; restore buffer in the mime case (set-buffer mail-buffer) (mail-text) (save-excursion (vm-attach-object work-buffer :type "multipart/digest" :params (list (concat "boundary=\"" boundary "\"")) :disposition '("inline") :description "forwarded messages" :mimed t) (add-hook 'kill-buffer-hook `(lambda () (if (eq (current-buffer) ,mail-buffer) (kill-buffer ,work-buffer)))))) (when prefix (vm-inform 6 "Building digest preamble...") ;; (if miming ;; (progn ;; (set-buffer mail-buffer) ;; (mail-text))) (while mp (let ((vm-summary-uninteresting-senders nil)) (insert (vm-summary-sprintf vm-digest-preamble-format (car mp)) "\n")) (if vm-digest-center-preamble (progn (forward-char -1) (center-line) (forward-char 1))) (setq mp (cdr mp)))) (mail-position-on-field "To") (vm-inform 5 "Building %s digest... done" vm-digest-send-type))) (run-hooks 'vm-send-digest-hook) (run-hooks 'vm-mail-mode-hook)) ;;;###autoload (defun vm-send-rfc934-digest (&optional preamble) "Like vm-send-digest but always sends an RFC 934 digest." (interactive "P") (let ((vm-digest-send-type "rfc934")) (vm-send-digest preamble))) ;;;###autoload (defun vm-send-rfc1153-digest (&optional preamble) "Like vm-send-digest but always sends an RFC 1153 digest." (interactive "P") (let ((vm-digest-send-type "rfc1153")) (vm-send-digest preamble))) ;;;###autoload (defun vm-send-mime-digest (&optional preamble) "Like vm-send-digest but always sends an MIME (multipart/digest) digest." (interactive "P") (let ((vm-digest-send-type "mime")) (vm-send-digest preamble))) ;;;###autoload (defun vm-continue-composing-message (&optional not-picky) "Find and select the most recently used mail composition buffer. If the selected buffer is already a Mail mode buffer then it is buried before beginning the search. Non Mail mode buffers and unmodified Mail buffers are skipped. Prefix arg means unmodified Mail mode buffers are not skipped. If no suitable buffer is found, the current buffer remains selected." (interactive "P") (if (eq major-mode 'mail-mode) (vm-bury-buffer (current-buffer))) (let ((b (vm-find-composition-buffer not-picky))) (if (not (or (null b) (eq b (current-buffer)))) (progn ;; avoid having the window configuration code choose a ;; different composition buffer. (vm-unbury-buffer b) (set-buffer b) (if (and vm-mutable-frame-configuration vm-frame-per-composition (vm-multiple-frames-possible-p) ;; only pop up a frame if there's an undisplay ;; hook in place to make the frame go away. vm-undisplay-buffer-hook) (let ((w (vm-get-buffer-window b))) (if (null w) (vm-goto-new-frame 'composition) (select-window w) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-window-frame w)))) ;; need to do this here too, since XEmacs has per ;; frame buffer lists. (vm-unbury-buffer b) (vm-set-hooks-for-frame-deletion))) (vm-display b t '(vm-continue-composing-message) '(vm-continue-composing-message composing-message))) (vm-inform 5 "No composition buffers found")))) ;;;###autoload (defun vm-mail-to-mailto-url (url) "Creates a message composition buffer to send mail to the URL. This command can be invoked from external agents via an emacsclient." (interactive "s") (vm-session-initialization) (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (let ((list (vm-parse url "^mailto:\\([^?]*\\)\\??\\|\\([^&]+\\)&?" '(1 2))) to subject in-reply-to cc references newsgroups body tem header value header-list) (setq to (car list) to (vm-url-decode-string to) list (cdr list)) (while list (setq tem (vm-parse (car list) "\\([^=]+\\)=?")) (if (null (nth 1 tem)) nil (setq header (downcase (vm-url-decode-string (car tem))) value (vm-url-decode-string (nth 1 tem))) (if (member header '("subject" "in-reply-to" "cc" "references" "newsgroups" "body")) ;; set the variable let-bound above (set (intern header) value) ;; we'll insert the header later (setq header-list (cons header (cons value header-list))))) (setq list (cdr list))) (vm-mail-internal :to to :subject subject :in-reply-to in-reply-to :cc cc :references references :newsgroups newsgroups) (save-excursion (goto-char (point-min)) (while header-list (insert (car header-list) ": ") (capitalize-region (point) (save-excursion (beginning-of-line) (point))) (insert (nth 1 header-list) "\n") (setq header-list (nthcdr 2 header-list))) (if (null body) nil (mail-text) (save-excursion (insert (vm-url-decode-string body) "\n")) ;; CRLF to LF for line breaks in the body (while (search-forward "\r\n" nil t) (replace-match "\n")))) (run-hooks 'vm-mail-hook) (run-hooks 'vm-mail-mode-hook))) ;; external variables (defvar mail-mode-map) (defvar mail-aliases) (defvar mail-default-reply-to) (defvar mail-signature-file) (defvar mail-personal-alias-file) (defun vm-sanitize-buffer-name (buffer-name) "Replace chars matching `vm-drop-buffer-name-chars' by an \"_\"." (let ((r vm-drop-buffer-name-chars)) (when buffer-name (if r (setq buffer-name (vm-replace-in-string buffer-name r "_" t))) (if (>= (length buffer-name) vm-buffer-name-limit) (setq buffer-name (concat (substring buffer-name 0 (- vm-buffer-name-limit 4)) "..."))))) buffer-name) (defvar vm-compositions-exist nil) (defvar vm-composition-buffer-count 0 "The current number of composition buffers.") (defvar vm-ml-composition-buffer-count "" "The modeline string displayed for the current number of composition buffers.") (defvar dnd-protocol-alist) (defvar ns-input-file) (defun vm-update-ml-composition-buffer-count () (setq vm-ml-composition-buffer-count (format "%d composition%s" vm-composition-buffer-count (if (= vm-composition-buffer-count 1) "" "s")))) (defun vm-forget-composition-buffer () (setq vm-composition-buffer-count (- vm-composition-buffer-count 1)) (setq vm-compositions-exist (> vm-composition-buffer-count 0)) (vm-update-ml-composition-buffer-count)) (defun vm-new-composition-buffer () (setq vm-composition-buffer-count (+ 1 vm-composition-buffer-count)) (setq vm-compositions-exist t) (vm-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'vm-forget-composition-buffer nil t) (add-hook 'vm-mail-send-hook 'vm-forget-composition-buffer nil t) (vm-update-ml-composition-buffer-count)) (defun vm-select-recipient-from-sender () "Select a recipient's address from the current message's sender, if there is a current message." (when (and vm-mail-use-sender-address (memq major-mode '(vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode))) (vm-select-folder-buffer) (vm-get-header-contents (car vm-message-pointer) "From:"))) ;;;###autoload (defun* vm-mail-internal (&key buffer-name to guessed-to subject in-reply-to cc references newsgroups) "Create a message buffer and set it up according to args. Fills in the headers as given by the arguments. Binds the `vm-mail-mode-map' and hooks" (let ((folder-buffer nil)) (when (memq major-mode '(vm-mode vm-virtual-mode)) (setq folder-buffer (current-buffer))) (setq buffer-name (if buffer-name (vm-decode-mime-encoded-words-in-string buffer-name) "mail to ?")) (setq buffer-name (vm-sanitize-buffer-name buffer-name)) (set-buffer (generate-new-buffer buffer-name)) ;; FSF Emacs: try to prevent write-region (called to handle FCC) from ;; asking the user to choose a safe coding system. (if (and vm-fsfemacs-mule-p (fboundp 'set-buffer-file-coding-system)) (set-buffer-file-coding-system 'raw-text)) ;; avoid trying to write auto-save files in potentially ;; unwritable directories. (setq default-directory (or vm-mail-auto-save-directory vm-folder-directory (expand-file-name "~/"))) (auto-save-mode (if auto-save-default 1 -1)) (mail-mode) ;; TM infests mail mode, uninfest it if VM's MIME stuff is in ;; use. (when vm-send-using-mime (vm-mail-mode-remove-tm-hooks)) (use-local-map vm-mail-mode-map) ;; make mail-mode-map the parent of this vm-mail-mode-map, if we can. ;; do it only once. (unless vm-mail-mode-map-parented (cond ((fboundp 'set-keymap-parents) (set-keymap-parents vm-mail-mode-map (list mail-mode-map)) (setq vm-mail-mode-map-parented t)) ((consp mail-mode-map) (nconc vm-mail-mode-map mail-mode-map) (setq vm-mail-mode-map-parented t)))) (when (boundp 'dnd-protocol-alist) (set (make-local-variable 'dnd-protocol-alist) (append vm-dnd-protocol-alist dnd-protocol-alist))) (setq vm-mail-buffer folder-buffer mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu))) (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-install-mail-mode-menu)) (if (fboundp 'mail-aliases-setup) ; use mail-abbrevs.el if present (mail-aliases-setup) (when (eq mail-aliases t) (setq mail-aliases nil) (when (file-exists-p (or mail-personal-alias-file "~/.mailrc")) (build-mail-aliases)))) (when (stringp vm-mail-header-from) (insert "From: " vm-mail-header-from "\n")) (setq to (if to (vm-decode-mime-encoded-words-in-string to)) guessed-to (if guessed-to (vm-decode-mime-encoded-words-in-string guessed-to)) subject (if subject (vm-decode-mime-encoded-words-in-string subject)) cc (if cc (vm-decode-mime-encoded-words-in-string cc))) (insert "To: " (or to guessed-to "") "\n") (and cc (insert "Cc: " cc "\n")) (insert "Subject: " (or subject "") "\n") (and newsgroups (insert "Newsgroups: " newsgroups "\n")) (and in-reply-to (insert "In-Reply-To: " in-reply-to "\n")) (and references (insert "References: " references "\n")) (insert "X-Mailer: VM " (vm-version) " under ") (if (boundp 'emacs-version) (insert emacs-version) (insert "Unknown Emacs")) ;; (if (functionp 'emacsw32-version) ;; (insert " [" (emacsw32-version) "]")) (if (boundp 'system-configuration) (insert " (" system-configuration ")")) (insert "\n") ;; REPLYTO environmental variable support ;; note that in FSF Emacs v19.29 we would initialize if the ;; value was t. nil is the trigger value used now. (and (eq mail-default-reply-to nil) (setq mail-default-reply-to (getenv "REPLYTO"))) (when mail-default-reply-to (insert "Reply-To: " mail-default-reply-to "\n")) (when mail-self-blind (insert "Bcc: " (cond ((and vm-xemacs-p (fboundp 'user-mail-address)) (user-mail-address)) ((and (boundp 'user-mail-address) (stringp user-mail-address)) user-mail-address) (t (user-login-name))) ?\n)) (when mail-archive-file-name (insert "FCC: " mail-archive-file-name "\n")) (when mail-default-headers (insert mail-default-headers)) (unless (= (preceding-char) ?\n) (insert ?\n)) (insert mail-header-separator "\n") (condition-case err (when mail-signature (save-excursion (save-restriction (narrow-to-region (point) (point)) (cond ((stringp mail-signature) (insert mail-signature)) ((eq mail-signature t) (insert-file-contents (or (and (boundp 'mail-signature-file) (stringp mail-signature-file) mail-signature-file) "~/.signature"))) (t (let ((str (eval mail-signature))) (if (stringp str) (insert str))))) (goto-char (point-min)) (if (looking-at "\n*-- \n") nil (insert "\n-- \n")) (goto-char (point-max))))) (error (vm-warn 1 2 "Cound not read signature file: %s" (cdr err)))) ;; move this buffer to the head of the buffer list so window ;; config stuff will select it as the composition buffer. (vm-unbury-buffer (current-buffer)) ;; make a new frame if the user wants it. (when (and vm-mutable-frame-configuration vm-frame-per-composition (vm-multiple-frames-possible-p)) (vm-goto-new-frame 'composition) (vm-set-hooks-for-frame-deletion)) ;; now do window configuration (vm-display (current-buffer) t '(vm-mail vm-mail-other-frame vm-mail-other-window vm-reply vm-reply-other-frame vm-reply-include-text vm-reply-include-text-other-frame vm-followup vm-followup-other-frame vm-followup-include-text vm-followup-include-text-other-frame vm-send-digest vm-send-digest-other-frame vm-send-rfc934-digest vm-send-rfc934-digest-other-frame vm-send-rfc1153-digest vm-send-rfc1153-digest-other-frame vm-send-mime-digest vm-send-mime-digest-other-frame vm-forward-message vm-forward-message-other-frame vm-forward-message-all-headers vm-forward-message-all-headers-other-frame vm-resend-message vm-resend-message-other-frame vm-resend-bounced-message vm-resend-bounced-message-other-frame) (list this-command 'composing-message)) (cond ((null to) (mail-position-on-field "To" t)) ((null subject) (mail-position-on-field "Subject" t))) (cond ((and vm-xemacs-p (fboundp 'start-itimer) (null (get-itimer "vm-rename-mail")) (start-itimer "vm-rename-mail" 'vm-update-composition-buffer-name 1.5 1.5 t))) ((and (fboundp 'run-with-idle-timer) (null vm-update-composition-buffer-name-timer)) (setq vm-update-composition-buffer-name-timer (run-with-idle-timer 1.5 t 'vm-update-composition-buffer-name)))) (vm-new-composition-buffer) (run-hooks 'mail-setup-hook))) ;;;###autoload (defun vm-reply-other-frame (count) "Like vm-reply, but run in a newly created frame." (interactive "p") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-reply count)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-reply-include-text-other-frame (count) "Like vm-reply-include-text, but run in a newly created frame." (interactive "p") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-reply-include-text count)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-followup-other-frame (count) "Like vm-followup, but run in a newly created frame." (interactive "p") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-followup count)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-followup-include-text-other-frame (count) "Like vm-followup-include-text, but run in a newly created frame." (interactive "p") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-followup-include-text count)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-forward-message-all-headers-other-frame () "Like vm-forward-message-all-headers, but run in a newly created frame." (interactive) (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-forward-message-all-headers)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-forward-message-other-frame () "Like vm-forward-message, but run in a newly created frame." (interactive) (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-forward-message)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-forward-message-plain-other-frame () "Like vm-forward-message-plain, but run in a newly created frame." (interactive) (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-forward-message-plain)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-resend-message-other-frame () "Like vm-resend-message, but run in a newly created frame." (interactive) (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-resend-message)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-resend-bounced-message-other-frame () "Like vm-resend-bounced-message, but run in a newly created frame." (interactive) (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-resend-bounced-message)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-send-digest-other-frame (&optional prefix) "Like vm-send-digest, but run in a newly created frame." (interactive "P") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-send-digest prefix)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-send-rfc934-digest-other-frame (&optional prefix) "Like vm-send-rfc934-digest, but run in a newly created frame." (interactive "P") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-send-rfc934-digest prefix)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-send-rfc1153-digest-other-frame (&optional prefix) "Like vm-send-rfc1153-digest, but run in a newly created frame." (interactive "P") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-send-rfc1153-digest prefix)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-send-mime-digest-other-frame (&optional prefix) "Like vm-send-mime-digest, but run in a newly created frame." (interactive "P") (when (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-send-mime-digest prefix)) (when (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) (defvar enriched-mode) ;;;###autoload (defun vm-preview-composition () "Show how the current composition buffer might be displayed in a MIME-aware mail reader. VM copies and encodes the current mail composition buffer and displays it as a mail folder. Type `q' to quit this temp folder and return to composing your message." (interactive) (when (not (eq major-mode 'mail-mode)) (error "Command must be used in a VM Mail mode buffer.")) (let ((temp-buffer nil) (mail-buffer (current-buffer)) (enriched (and (boundp 'enriched-mode) enriched-mode)) e-list) (unwind-protect (progn (setq temp-buffer (generate-new-buffer "composition preview")) (set-buffer temp-buffer) ;; so vm-mime-xxxx-encode-composition won't complain (setq major-mode 'mail-mode) (set (make-local-variable 'enriched-mode) enriched) (vm-insert-region-from-buffer mail-buffer) (goto-char (point-min)) (unless (vm-mail-mode-get-header-contents "From") (insert "From: " (user-login-name) "\n")) (unless (vm-mail-mode-get-header-contents "Message-ID") (insert (format "Message-ID: \n" (random 1000000) (random 1000000)))) (unless (vm-mail-mode-get-header-contents "Date") (insert "Date: " (format-time-string "%a, %d %b %Y %T %z" (current-time)) "\n")) (when (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:"))) (vm-mime-encode-composition)) (when vm-mail-reorder-message-headers (vm-reorder-message-headers nil :keep-list vm-mail-header-order :discard-regexp 'none)) (vm-remove-mail-mode-header-separator) (vm-munge-message-separators 'mmdf (point-min) (point-max)) (goto-char (point-min)) (insert (vm-leading-message-separator 'mmdf)) (goto-char (point-max)) (unless (eq (preceding-char) ?\n) (insert ?\n)) (insert (vm-trailing-message-separator 'mmdf)) (set-buffer-modified-p nil) ;; point of no return, don't kill it if the user quits (setq temp-buffer nil) (let ((vm-auto-decode-mime-messages t)) (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode))) (vm-inform 5 (substitute-command-keys "Type \\[vm-quit] to continue composing your message")) ;; temp buffer, don't offer to save it. (setq buffer-offer-save nil) (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup))) (when temp-buffer (kill-buffer temp-buffer))))) (defun vm-update-composition-buffer-name () (when (and (eq major-mode 'mail-mode) (save-match-data (string-match "^\\(mail\\|reply\\) to " (buffer-name)))) (let ((to (mail-fetch-field "To")) (cc (mail-fetch-field "Cc")) (curbufname (buffer-name)) (deactivate-mark) fmt newbufname (ellipsis "")) (cond (vm-reply-list (setq fmt "reply to %s%s")) (t (setq fmt "mail to %s%s on \"%s\""))) (setq to (vm-parse-addresses to) cc (vm-parse-addresses cc)) (when (or (cdr to) (and (car to) (car cc))) (setq ellipsis ", ...")) (setq newbufname (or (car to) (car cc) "foo (?)") newbufname (funcall vm-chop-full-name-function newbufname) newbufname (or (car newbufname) (car (cdr newbufname))) newbufname (format fmt newbufname ellipsis (mail-fetch-field "Subject"))) (unless (equal newbufname curbufname) (setq newbufname (vm-sanitize-buffer-name newbufname)) (rename-buffer newbufname t))))) ;;;###autoload (defun vm-mail-mode-remove-tm-hooks () (remove-hook 'mail-setup-hook 'turn-on-mime-edit) (remove-hook 'mail-setup-hook 'mime/decode-message-header) (remove-hook 'mail-setup-hook 'mime/editor-mode) (remove-hook 'mail-send-hook 'mime-edit-maybe-translate) (remove-hook 'mail-send-hook 'mime-editor/maybe-translate)) (defun vm-mail-mode-show-headers () "Display any hidden headers in a composition buffer." (interactive) (mapc 'delete-overlay (overlays-in (point-min) (save-excursion (mail-text) (point)))) (if (local-variable-p 'line-move-ignore-invisible (current-buffer)) (setq line-move-ignore-invisible nil))) (make-variable-buffer-local 'line-move-ignore-invisible) (defun vm-mail-mode-hide-headers () "Hides and protects headers listed in `vm-mail-mode-hidden-headers'. With a prefix arg, call `vm-mail-mode-show-headers' instead." (interactive) (let ((case-fold-search t) (header-regexp (regexp-opt vm-mail-mode-hidden-headers)) (header-end (save-excursion (mail-text) (point))) start end o) (setq header-regexp (concat "^" header-regexp)) (setq line-move-ignore-invisible t) (save-excursion (goto-char (point-min)) (while (re-search-forward header-regexp header-end t) (setq start (match-beginning 0) end (1- (re-search-forward "^[^ \t]" header-end))) (goto-char end) (let ((o (or (car (overlays-at start)) (make-overlay start end)))) (when (not (overlay-get o 'invisible)) (overlay-put o 'invisible t) (overlay-put o 'read-only t))))))) ;;;###autoload (defun vm-dnd-attach-file (uri action) "Insert a drag and drop file as a MIME attachment in a VM composition buffer. URI is the url of the file as described in `dnd-protocol-alist'. ACTION is ignored." (let ((file (dnd-get-local-file-name uri t)) type) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when (and file (file-regular-p file)) (setq type (or (vm-mime-default-type-from-filename file) "application/octet-stream")) (vm-attach-file file type)))) ;;;###autoload (defun vm-ns-attach-file () "Insert a drag and drop file as a MIME attachment in a VM composition buffer. This is a version of `vm-dnd-attach-file' that is needed for Mac and NextStep." (interactive) (let ((file (car ns-input-file)) type) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (when (and file (file-regular-p file)) (setq ns-input-file (cdr ns-input-file)) (setq type (or (vm-mime-default-type-from-filename file) "application/octet-stream")) (vm-attach-file file type)))) (defun vm-mail-mode-hide-headers-hook () "Hook which handles `vm-mail-mode-hidden-headers'." (when vm-mail-mode-hidden-headers (vm-mail-mode-hide-headers))) (add-hook 'vm-mail-mode-hook 'vm-mail-mode-hide-headers-hook) ;;; vm-reply.el ends here vm-8.2.0b/lisp/vm-sort.el0000755000175000017500000007232011676442160015475 0ustar srivastasrivasta;;; vm-sort.el --- Sorting and moving messages inside VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1993, 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code (provide 'vm-sort) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-thread) (require 'vm-motion) (require 'vm-page) (require 'vm-window) (require 'vm-undo) ) (declare-function vm-sort-insert-auto-folder-names "vm-avirtual" ()) ;;;###autoload (defun vm-move-message-forward (count) "Move a message forward in a VM folder. Prefix arg COUNT causes the current message to be moved COUNT messages forward. A negative COUNT causes movement to be backward instead of forward. COUNT defaults to 1. The current message remains selected after being moved. If vm-move-messages-physically is non-nil, the physical copy of the message in the folder is moved. A nil value means just change the presentation order and leave the physical order of the folder undisturbed." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if vm-move-messages-physically (vm-error-if-folder-read-only)) (vm-display nil nil '(vm-move-message-forward vm-move-message-backward vm-move-message-forward-physically vm-move-message-backward-physically) (list this-command)) (let* ((ovmp vm-message-pointer) vmp-prev ovmp-prev (vm-message-pointer vm-message-pointer) (direction (if (> count 0) 'forward 'backward)) (count (vm-abs count))) (while (not (zerop count)) (vm-move-message-pointer direction) (vm-decrement count)) (if (> (string-to-number (vm-number-of (car vm-message-pointer))) (string-to-number (vm-number-of (car ovmp)))) (setq vm-message-pointer (cdr vm-message-pointer))) (if (eq vm-message-pointer ovmp) () (if (null vm-message-pointer) (setq vmp-prev (vm-last vm-message-list)) (setq vmp-prev (vm-reverse-link-of (car vm-message-pointer)))) (setq ovmp-prev (vm-reverse-link-of (car ovmp))) ;; lock out interrupts to preserve message list integrity. (let ((inhibit-quit t)) (if ovmp-prev (progn (setcdr ovmp-prev (cdr ovmp)) (and (cdr ovmp) (vm-set-reverse-link-of (car (cdr ovmp)) ovmp-prev))) (setq vm-message-list (cdr ovmp)) (vm-set-reverse-link-of (car vm-message-list) nil)) (if vmp-prev (progn (setcdr vmp-prev ovmp) (vm-set-reverse-link-of (car ovmp) vmp-prev)) (setq vm-message-list ovmp) (vm-set-reverse-link-of (car vm-message-list) nil)) (setcdr ovmp vm-message-pointer) (and vm-message-pointer (vm-set-reverse-link-of (car vm-message-pointer) ovmp)) (if (and vm-move-messages-physically (not (eq major-mode 'vm-virtual-mode))) (vm-physically-move-message (car ovmp) (car vm-message-pointer))) (setq vm-ml-sort-keys nil) (if (not vm-folder-read-only) (progn (setq vm-message-order-changed t) (vm-mark-folder-modified-p (current-buffer)) (vm-clear-modification-flag-undos)))) (cond ((null ovmp-prev) (setq vm-numbering-redo-start-point vm-message-list vm-numbering-redo-end-point vm-message-pointer vm-summary-pointer (car vm-message-list))) ((null vmp-prev) (setq vm-numbering-redo-start-point vm-message-list vm-numbering-redo-end-point (cdr ovmp-prev) vm-summary-pointer (car ovmp-prev))) ((or (not vm-message-pointer) (< (string-to-number (vm-number-of (car ovmp-prev))) (string-to-number (vm-number-of (car vm-message-pointer))))) (setq vm-numbering-redo-start-point (cdr ovmp-prev) vm-numbering-redo-end-point (cdr ovmp) vm-summary-pointer (car (cdr ovmp-prev)))) (t (setq vm-numbering-redo-start-point ovmp vm-numbering-redo-end-point (cdr ovmp-prev) vm-summary-pointer (car ovmp-prev)))) (if vm-summary-buffer (let (list mp) (vm-copy-local-variables vm-summary-buffer 'vm-summary-pointer) (setq vm-need-summary-pointer-update t) (setq mp vm-numbering-redo-start-point) (while (not (eq mp vm-numbering-redo-end-point)) (vm-mark-for-summary-update (car mp)) (setq list (cons (car mp) list) mp (cdr mp))) (vm-mapc (function (lambda (m p) (vm-set-su-start-of m (car p)) (vm-set-su-end-of m (car (cdr p))))) (setq list (nreverse list)) (sort (mapcar (function (lambda (p) (list (vm-su-start-of p) (vm-su-end-of p)))) list) (function (lambda (p q) (< (car p) (car q)))))))))) (if vm-move-messages-physically ;; clip region is messed up (vm-present-current-message) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-move-message-backward (count) "Move a message backward in a VM folder. Prefix arg COUNT causes the current message to be moved COUNT messages backward. A negative COUNT causes movement to be forward instead of backward. COUNT defaults to 1. The current message remains selected after being moved. If vm-move-messages-physically is non-nil, the physical copy of the message in the folder is moved. A nil value means just change the presentation order and leave the physical order of the folder undisturbed." (interactive "p") (vm-move-message-forward (- count))) ;;;###autoload (defun vm-move-message-forward-physically (count) "Like vm-move-message-forward but always move the message physically." (interactive "p") (let ((vm-move-messages-physically t)) (vm-move-message-forward count))) ;;;###autoload (defun vm-move-message-backward-physically (count) "Like vm-move-message-backward but always move the message physically." (interactive "p") (let ((vm-move-messages-physically t)) (vm-move-message-backward count))) ;; move message m to be before m-dest ;; and fix up the location markers afterwards. ;; m better not equal m-dest. ;; of m-dest is nil, move m to the end of buffer. ;; ;; consider carefully the effects of insertion on markers ;; and variables containg markers before you modify this code. (defun vm-physically-move-message (m m-dest) (save-excursion (vm-save-restriction (widen) ;; Make sure vm-headers-of and vm-text-of are non-nil in ;; their slots before we try to move them. (Simply ;; referencing the slot with their slot function is ;; sufficient to guarantee this.) Otherwise, they be ;; initialized in the middle of the message move and get the ;; offset applied to them twice by way of a relative offset ;; from one of the other location markers that has already ;; been moved. ;; ;; Also, and more importantly, vm-vheaders-of might run ;; vm-reorder-message-headers, which can add text to ;; message. This MUST NOT happen after offsets have been ;; computed for the message move or varying levels of chaos ;; will ensue. In the case of BABYL files, where ;; vm-reorder-message-headers can add a lot of new text, ;; folder curroption can be massive. (vm-text-of m) (vm-vheaders-of m) (let ((dest-start (if m-dest (vm-start-of m-dest) (point-max))) (buffer-read-only nil) offset doomed-start doomed-end) (goto-char dest-start) (insert-buffer-substring (current-buffer) (vm-start-of m) (vm-end-of m)) (setq doomed-start (marker-position (vm-start-of m)) doomed-end (marker-position (vm-end-of m)) offset (- (vm-start-of m) dest-start)) (set-marker (vm-start-of m) (- (vm-start-of m) offset)) (set-marker (vm-headers-of m) (- (vm-headers-of m) offset)) (set-marker (vm-text-end-of m) (- (vm-text-end-of m) offset)) (set-marker (vm-end-of m) (- (vm-end-of m) offset)) (set-marker (vm-text-of m) (- (vm-text-of m) offset)) (set-marker (vm-vheaders-of m) (- (vm-vheaders-of m) offset)) ;; now fix the start of m-dest since it didn't ;; move forward with its message. (and m-dest (set-marker (vm-start-of m-dest) (vm-end-of m))) ;; delete the old copy of the message (delete-region doomed-start doomed-end))))) ;;;###autoload (defun vm-so-sortable-datestring (m) "Returns the date string of M. The date returned is obtained from the \"Date\" header of the message, if it exists, or the date the message was received in VM. If `vm-sort-messages-by-delivery-date' is non-nil, then the \"Delivery-Date\" header is used instead of the \"Date\" header." (or (vm-sortable-datestring-of m) (progn (vm-set-sortable-datestring-of m (condition-case nil (vm-timezone-make-date-sortable (or (if vm-sort-messages-by-delivery-date (vm-get-header-contents m "Delivery-Date:") (vm-get-header-contents m "Date:")) (vm-grok-From_-date m) "Thu, 1 Jan 1970 00:00:00 GMT")) (error "1970010100:00:00"))) (vm-sortable-datestring-of m)))) ;;;###autoload (defun vm-so-sortable-subject (m) "Returns the subject string of M, after stripping redundant prefixes and suffixes, which is suitable for sorting by subject. The string is MIME-decoded with possible properties." (or (vm-sortable-subject-of m) (progn (vm-set-sortable-subject-of m (let ((case-fold-search t) (subject (vm-su-subject m))) (if (and vm-subject-ignored-prefix (string-match vm-subject-ignored-prefix subject) (zerop (match-beginning 0))) (setq subject (substring subject (match-end 0)))) (if (and vm-subject-ignored-suffix (string-match vm-subject-ignored-suffix subject) (= (match-end 0) (length subject))) (setq subject (substring subject 0 (match-beginning 0)))) (setq subject (vm-with-string-as-temp-buffer subject (function vm-collapse-whitespace))) (if (and vm-subject-significant-chars (natnump vm-subject-significant-chars) (< vm-subject-significant-chars (length subject))) (setq subject (substring subject 0 vm-subject-significant-chars))) subject )) (vm-sortable-subject-of m)))) (defvar vm-sort-compare-header nil "the header to sort on.") (defvar vm-sort-compare-header-history nil) ;;;###autoload (defun vm-sort-messages (keys &optional lets-get-physical) "Sort message in a folder by the specified KEYS. KEYS is a string of sort keys, separated by spaces or tabs. If messages compare equal by the first key, the second key will be compared and so on. When called interactively the keys will be read from the minibuffer. Valid keys are \"date\" \"reversed-date\" \"activity\" \"reversed-activity\" \"author\" \"reversed-author\" \"full-name\" \"reversed-full-name\" \"subject\" \"reversed-subject\" \"recipients\" \"reversed-recipients\" \"line-count\" \"reversed-line-count\" \"byte-count\" \"reversed-byte-count\" \"physical-order\" \"reversed-physical-order\" \"spam-score\" \"reversed-spam-score\" Optional second arg (prefix arg interactively) means the sort should change the physical order of the messages in the folder. Normally VM changes presentation order only, leaving the folder in the order in which the messages arrived." (interactive (let ((last-command last-command) (this-command this-command)) (list (vm-read-string (if (or current-prefix-arg vm-move-messages-physically) "Physically sort messages by: " "Sort messages by: ") vm-supported-sort-keys t) current-prefix-arg))) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) ;; only squawk if interactive. The thread display uses this ;; function and doesn't expect errors. (if (vm-interactive-p) (vm-error-if-folder-empty)) ;; ditto (if (and (vm-interactive-p) (or vm-move-messages-physically lets-get-physical)) (vm-error-if-folder-read-only)) (vm-display nil nil '(vm-sort-messages) '(vm-sort-messages)) (let (key-list key-funcs key ml-keys physical-order-list old-message-list new-message-list mp-old mp-new old-start doomed-start doomed-end offset (order-did-change nil) virtual physical auto-folder-p) (setq key-list (vm-parse keys "[ \t]*\\([^ \t,]+\\)") ml-keys (and key-list (mapconcat (function identity) key-list "/")) key-funcs nil old-message-list vm-message-list virtual (eq major-mode 'vm-virtual-mode) physical (and (or lets-get-physical vm-move-messages-physically) (not vm-folder-read-only) (not virtual))) (unless key-list (error "No sort keys specified.")) (while key-list (setq key (car key-list)) (cond ((equal key "auto-folder") (setq auto-folder-p t) (setq key-funcs (cons 'vm-sort-compare-auto-folder key-funcs))) ((equal key "author") (setq key-funcs (cons 'vm-sort-compare-author key-funcs))) ((equal key "reversed-author") (setq key-funcs (cons 'vm-sort-compare-author-r key-funcs))) ((equal key "full-name") (setq key-funcs (cons 'vm-sort-compare-full-name key-funcs))) ((equal key "reversed-full-name") (setq key-funcs (cons 'vm-sort-compare-full-name-r key-funcs))) ((equal key "date") (setq key-funcs (cons 'vm-sort-compare-date key-funcs))) ((equal key "reversed-date") (setq key-funcs (cons 'vm-sort-compare-date-r key-funcs))) ((equal key "activity") (setq vm-summary-show-threads t) (setq key-funcs (cons 'vm-sort-compare-activity key-funcs))) ((equal key "reversed-activity") (setq vm-summary-show-threads t) (setq key-funcs (cons 'vm-sort-compare-activity-r key-funcs))) ;; ((equal key "thread-oldest-date") ;; (setq vm-summary-show-threads t) ;; (setq key-funcs (cons 'vm-sort-compare-thread-oldest-date ;; key-funcs))) ;; ((equal key "reversed-thread-oldest-date") ;; (setq vm-summary-show-threads t) ;; (setq key-funcs (cons 'vm-sort-compare-thread-oldest-date-r ;; key-funcs))) ((equal key "subject") (setq key-funcs (cons 'vm-sort-compare-subject key-funcs))) ((equal key "reversed-subject") (setq key-funcs (cons 'vm-sort-compare-subject-r key-funcs))) ((equal key "recipients") (setq key-funcs (cons 'vm-sort-compare-recipients key-funcs))) ((equal key "reversed-recipients") (setq key-funcs (cons 'vm-sort-compare-recipients-r key-funcs))) ((equal key "byte-count") (setq key-funcs (cons 'vm-sort-compare-byte-count key-funcs))) ((equal key "reversed-byte-count") (setq key-funcs (cons 'vm-sort-compare-byte-count-r key-funcs))) ((equal key "line-count") (setq key-funcs (cons 'vm-sort-compare-line-count key-funcs))) ((equal key "reversed-line-count") (setq key-funcs (cons 'vm-sort-compare-line-count-r key-funcs))) ((equal key "spam-score") (setq key-funcs (cons 'vm-sort-compare-spam-score key-funcs))) ((equal key "reversed-spam-score") (setq key-funcs (cons 'vm-sort-compare-spam-score-r key-funcs))) ((equal key "physical-order") (setq key-funcs (cons 'vm-sort-compare-physical-order key-funcs))) ((equal key "reversed-physical-order") (setq key-funcs (cons 'vm-sort-compare-physical-order-r key-funcs))) ((equal key "header") (setq vm-sort-compare-header nil) (setq key-funcs (cons 'vm-sort-compare-header key-funcs))) ((equal key "thread") (vm-build-threads-if-unbuilt) (vm-build-thread-lists) (setq key-funcs (cons 'vm-sort-compare-thread key-funcs))) (t (let ((compare (intern (format "vm-sort-compare-%s" key)))) (if (functionp compare) (setq key-funcs (cons compare key-funcs)) (error "Unknown key: %s" key))))) (setq key-list (cdr key-list))) (setq key-funcs (nreverse key-funcs)) ;; if this is not a thread sort and threading is enabled, ;; then disable threading and make sure the whole summary is ;; regenerated (to recalculate %I everywhere). (when vm-summary-show-threads (vm-build-threads-if-unbuilt) (vm-build-thread-lists) (setq key-funcs (cons 'vm-sort-compare-thread key-funcs))) (vm-inform 6 "Sorting messages...") (let ((vm-key-functions key-funcs)) (setq new-message-list (sort (copy-sequence old-message-list) 'vm-sort-compare-xxxxxx)) ;; only need to do this sort if we're going to physically ;; move messages later. (if physical (setq vm-key-functions '(vm-sort-compare-physical-order) physical-order-list (sort (copy-sequence old-message-list) 'vm-sort-compare-xxxxxx)))) (vm-inform 6 "Sorting messages... done") (let ((inhibit-quit t)) (setq mp-old old-message-list mp-new new-message-list) (while mp-new (if (eq (car mp-old) (car mp-new)) (setq mp-old (cdr mp-old) mp-new (cdr mp-new)) (setq order-did-change t) ;; unless a full redo has been requested, the numbering ;; start point now points to a cons in the old message ;; list. therefore we just change the variable ;; directly to avoid the list scan that ;; vm-set-numbering-redo-start-point does. (cond ((not (eq vm-numbering-redo-start-point t)) (setq vm-numbering-redo-start-point mp-new vm-numbering-redo-end-point nil))) (if vm-summary-buffer (progn (setq vm-need-summary-pointer-update t) ;; same logic as numbering reset above... (cond ((not (eq vm-summary-redo-start-point t)) (setq vm-summary-redo-start-point mp-new))) ;; start point of this message's summary is now ;; wrong relative to where it is in the ;; message list. fix it and the summary rebuild ;; will take care of the rest. (vm-set-su-start-of (car mp-new) (vm-su-start-of (car mp-old))))) (setq mp-new nil))) (if (and physical (vm-has-message-order)) (let ((buffer-read-only nil)) ;; the folder is being physically ordered so we don't ;; need a message order header to be stuffed, nor do ;; we need to retain one in the folder buffer. so we ;; strip out any existing message order header and ;; say there are no changes to prevent a message ;; order header from being stuffed later. (vm-remove-message-order) (setq vm-message-order-changed nil) (vm-inform 6 "Moving messages... ") (widen) (setq mp-old physical-order-list mp-new new-message-list) (setq old-start (vm-start-of (car mp-old))) (while mp-new (if (< (vm-start-of (car mp-old)) old-start) ;; already moved this message (setq mp-old (cdr mp-old)) (if (eq (car mp-old) (car mp-new)) (setq mp-old (cdr mp-old) mp-new (cdr mp-new)) ;; move message (vm-physically-move-message (car mp-new) (car mp-old)) ;; record start position. if vm-start-of ;; mp-old ever becomes less than old-start ;; we're running into messages that have ;; already been moved. (setq old-start (vm-start-of (car mp-old))) ;; move mp-new but not mp-old because we moved ;; mp-old down one message by inserting a ;; message in front of it. (setq mp-new (cdr mp-new))))) (vm-inform 6 "Moving messages... done") (vm-mark-folder-modified-p (current-buffer)) (vm-clear-modification-flag-undos)) (if (and order-did-change (not vm-folder-read-only)) (progn (setq vm-message-order-changed t) ;; only viewing order changed here ;; (vm-mark-folder-modified-p (current-buffer)) (vm-clear-modification-flag-undos)))) (setq vm-ml-sort-keys ml-keys) (intern (buffer-name) vm-buffers-needing-display-update) (cond (order-did-change (setq vm-message-list new-message-list) (vm-reverse-link-messages) (if vm-message-pointer (setq vm-message-pointer (or (cdr (vm-reverse-link-of (car vm-message-pointer))) vm-message-list))) (if vm-last-message-pointer (setq vm-last-message-pointer (or (cdr (vm-reverse-link-of (car vm-last-message-pointer))) vm-message-list)))))) (if (and vm-message-pointer order-did-change (or lets-get-physical vm-move-messages-physically)) ;; clip region is most likely messed up (vm-present-current-message) (vm-update-summary-and-mode-line)) (if auto-folder-p (vm-sort-insert-auto-folder-names)))) ;;;###autoload (defun vm-sort-compare-xxxxxx (msg1 msg2) (if (and vm-summary-debug (or (member (vm-number-of msg1) vm-summary-traced-messages) (member (vm-number-of msg2) vm-summary-traced-messages))) (debug "traced message")) (let ((key-funcs vm-key-functions) result (m1 msg1) (m2 msg2)) (catch 'done (unless key-funcs (throw 'done nil)) (when (eq (car key-funcs) 'vm-sort-compare-thread) (setq result (vm-sort-compare-thread m1 m2)) (if (consp result) (progn (setq m1 (car result) m2 (cdr result) key-funcs (cdr key-funcs)) (if (or (null m1) (null m2)) (progn (if vm-summary-debug (debug "null message")) (throw 'done t)))) (throw 'done result))) (while key-funcs (if (eq '= (setq result (funcall (car key-funcs) m1 m2))) (setq key-funcs (cdr key-funcs)) (throw 'done result))) ;; if all else fails try physical order (if (eq m1 m2) nil (vm-sort-compare-physical-order m1 m2))))) (defun vm-sort-compare-thread (m1 m2) (let ((root1 (vm-thread-root-sym m1)) (root2 (vm-thread-root-sym m2)) (list1 (vm-thread-list m1)) (list2 (vm-thread-list m2)) ;; (criterion (if vm-sort-threads-by-youngest-date ;; 'youngest-date ;; 'oldest-date)) p1 p2 d1 d2) (catch 'done (cond ;; ((not (eq (car list1) (car list2))) ;; ;; different reference threads ;; (let ((date1 (vm-th-thread-date-of (car list1) criterion)) ;; (date2 (vm-th-thread-date-of (car list2) criterion))) ;; (cond ((string-lessp date1 date2) t) ;; ((string-equal date1 date2) ;; (string-lessp (format "%s" root1) (format "%s" root2))) ;; (t nil)))) ((eq (car list1) (car list2)) ;; within the same reference thread (setq list1 (cdr list1) list2 (cdr list2)) (if (not vm-sort-subthreads) ;; no further sorting for internal messages of threads (when (and list1 list2) (throw 'done (cons m1 m2))) (while (and list1 list2) (setq p1 (car list1) p2 (car list2)) (cond ((null (vm-th-message-of p1)) (setq list1 (cdr list1))) ((null (vm-th-message-of p2)) (setq list2 (cdr list2))) ((string-equal p1 p2) (setq list1 (cdr list1) list2 (cdr list2))) (t (throw 'done (cons (vm-th-message-of p1) (vm-th-message-of p2))))))) (cond (list1 nil) ; list2=nil, m2 ancestor of m1 (list2 t) ; list1=nil, m1 ancestor of m2 ((not (eq (vm-thread-symbol m1) ; m1 and m2 different (vm-thread-symbol m2))) (cons m1 m2)) ((eq m1 (vm-th-message-of (vm-thread-symbol m1))) t) ; list1=list2=nil, m2 copy of m1 (t nil))) ;; list1=list2=nil, m1 copy of m2 ((eq root1 root2) ;; within the same subject thread (while (null (vm-th-message-of (car list1))) (setq list1 (cdr list1))) (while (null (vm-th-message-of (car list2))) (setq list2 (cdr list2))) (cons (vm-th-message-of (car list1)) (vm-th-message-of (car list2)))) ((not (eq root1 root2)) ;; different threads (cons (vm-th-message-of root1) (vm-th-message-of root2))) )))) (defun vm-sort-compare-author (m1 m2) (let ((s1 (vm-su-from m1)) (s2 (vm-su-from m2))) (cond ((string-lessp s1 s2) t) ((string-equal s1 s2) '=) (t nil)))) (defun vm-sort-compare-author-r (m1 m2) (let ((s1 (vm-su-from m1)) (s2 (vm-su-from m2))) (cond ((string-lessp s1 s2) nil) ((string-equal s1 s2) '=) (t t)))) (defun vm-sort-compare-full-name (m1 m2) (let ((s1 (vm-su-full-name m1)) (s2 (vm-su-full-name m2))) (cond ((string-lessp s1 s2) t) ((string-equal s1 s2) '=) (t nil)))) (defun vm-sort-compare-full-name-r (m1 m2) (let ((s1 (vm-su-full-name m1)) (s2 (vm-su-full-name m2))) (cond ((string-lessp s1 s2) nil) ((string-equal s1 s2) '=) (t t)))) (defun vm-sort-compare-date (m1 m2) (let ((s1 (vm-so-sortable-datestring m1)) (s2 (vm-so-sortable-datestring m2))) (cond ((string-lessp s1 s2) t) ((string-equal s1 s2) '=) (t nil)))) (defun vm-sort-compare-date-r (m1 m2) (let ((s1 (vm-so-sortable-datestring m1)) (s2 (vm-so-sortable-datestring m2))) (cond ((string-lessp s1 s2) nil) ((string-equal s1 s2) '=) (t t)))) (defun vm-sort-compare-activity (m1 m2) (let ((d1 (vm-th-youngest-date-of (vm-thread-symbol m1))) (d2 (vm-th-youngest-date-of (vm-thread-symbol m2)))) (cond ((string-lessp d1 d2) t) ((string-equal d1 d2) '=) (t nil)))) (defun vm-sort-compare-activity-r (m1 m2) (let ((d1 (vm-th-youngest-date-of (vm-thread-symbol m1))) (d2 (vm-th-youngest-date-of (vm-thread-symbol m2)))) (cond ((string-lessp d1 d2) nil) ((string-equal d1 d2) '=) (t t)))) ;; (defun vm-sort-compare-thread-oldest-date (m1 m2) ;; (let ((d1 (vm-th-oldest-date-of (vm-thread-symbol m1))) ;; (d2 (vm-th-oldest-date-of (vm-thread-symbol m2)))) ;; (cond ((string-lessp d1 d2) t) ;; ((string-equal d1 d2) '=) ;; (t nil)))) ;; (defun vm-sort-compare-thread-oldest-date-r (m1 m2) ;; (let ((d1 (vm-th-oldest-date-of (vm-thread-symbol m1))) ;; (d2 (vm-th-oldest-date-of (vm-thread-symbol m2)))) ;; (cond ((string-lessp d1 d2) nil) ;; ((string-equal d1 d2) '=) ;; (t t)))) (defun vm-sort-compare-recipients (m1 m2) (let ((s1 (vm-su-to m1)) (s2 (vm-su-to m2))) (cond ((string-lessp s1 s2) t) ((string-equal s1 s2) '=) (t nil)))) (defun vm-sort-compare-recipients-r (m1 m2) (let ((s1 (vm-su-to m1)) (s2 (vm-su-to m2))) (cond ((string-lessp s1 s2) nil) ((string-equal s1 s2) '=) (t t)))) (defun vm-sort-compare-subject (m1 m2) (let ((s1 (vm-so-sortable-subject m1)) (s2 (vm-so-sortable-subject m2))) (cond ((string-lessp s1 s2) t) ((string-equal s1 s2) '=) (t nil)))) (defun vm-sort-compare-subject-r (m1 m2) (let ((s1 (vm-so-sortable-subject m1)) (s2 (vm-so-sortable-subject m2))) (cond ((string-lessp s1 s2) nil) ((string-equal s1 s2) '=) (t t)))) (defun vm-sort-compare-line-count (m1 m2) (let ((n1 (string-to-number (vm-su-line-count m1))) (n2 (string-to-number (vm-su-line-count m2)))) (cond ((< n1 n2) t) ((= n1 n2) '=) (t nil)))) (defun vm-sort-compare-line-count-r (m1 m2) (let ((n1 (string-to-number (vm-su-line-count m1))) (n2 (string-to-number (vm-su-line-count m2)))) (cond ((> n1 n2) t) ((= n1 n2) '=) (t nil)))) (defun vm-sort-compare-byte-count (m1 m2) (let ((n1 (string-to-number (vm-su-byte-count m1))) (n2 (string-to-number (vm-su-byte-count m2)))) (cond ((< n1 n2) t) ((= n1 n2) '=) (t nil)))) (defun vm-sort-compare-byte-count-r (m1 m2) (let ((n1 (string-to-number (vm-su-byte-count m1))) (n2 (string-to-number (vm-su-byte-count m2)))) (cond ((> n1 n2) t) ((= n1 n2) '=) (t nil)))) (defun vm-sort-compare-spam-score (m1 m2) (let ((s1 (vm-su-spam-score m1)) (s2 (vm-su-spam-score m2))) (cond ((< s1 s2) t) ((= s1 s2) '=) (t nil)))) (defun vm-sort-compare-spam-score-r (m1 m2) (let ((s1 (vm-su-spam-score m1)) (s2 (vm-su-spam-score m2))) (cond ((< s1 s2) nil) ((= s1 s2) '=) (t t)))) ;;;###autoload (defun vm-sort-compare-physical-order (m1 m2) (let ((r1 (vm-real-message-of m1)) (r2 (vm-real-message-of m2)) n1 n2) (if (and r1 r2 (setq n1 (marker-position (vm-start-of r1))) (setq n2 (marker-position (vm-start-of r2)))) (cond ((< n1 n2) t) ((= n1 n2) '=) (t nil)) '=))) ;;;###autoload (defun vm-sort-compare-physical-order-r (m1 m2) (let ((n1 (vm-start-of m1)) (n2 (vm-start-of m2))) (cond ((> n1 n2) t) ((= n1 n2) '=) (t nil)))) (add-to-list 'vm-supported-sort-keys "header") (defun vm-get-headers-of (m &optional headers) (save-excursion (save-restriction (widen) (let ((end (vm-text-of m))) (set-buffer (vm-buffer-of m)) (goto-char (vm-start-of m)) (while (re-search-forward "^[^: \n\t]+:" end t) (add-to-list 'headers (match-string 0))) headers)))) (defun vm-sort-compare-header (m1 m2) (if (null vm-sort-compare-header) (setq vm-sort-compare-header (completing-read (if (car vm-sort-compare-header-history) (format "Sort hy header (%s): " (car vm-sort-compare-header-history)) "Sort hy header: ") (mapcar (lambda (h) (list h)) (vm-get-headers-of m2 (vm-get-headers-of m1))) nil nil nil 'vm-sort-compare-header-history (car vm-sort-compare-header-history))) (string< (vm-get-header-contents m1 vm-sort-compare-header) (vm-get-header-contents m2 vm-sort-compare-header)))) ;;; vm-sort.el ends here vm-8.2.0b/lisp/vm-folder.el0000755000175000017500000060621011676442160015762 0ustar srivastasrivasta;;; vm-folder.el --- VM folder related functions ;; ;; This file is part of VM ;; ;; Copyright (C) 1989-2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; Copyright (C) 2008-2010 Uday S. Reddy ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-folder) (eval-when-compile (require 'vm-misc) (require 'vm-summary) (require 'vm-window) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-toolbar) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-mark) (require 'vm-virtual) (require 'vm-mime) (require 'vm-sort) (require 'vm-thread) (require 'vm-pop) (require 'vm-imap) ) ;; vm-xemacs.el is a fake file to fool the Emacs 23 compiler (declare-function get-itimer "vm-xemacs.el" (name)) (declare-function start-itimer "vm-xemacs.el" (name function value &optional restart is-idle with-args &rest function-arguments)) (declare-function set-itimer-restart "vm-xemacs.el" (itimer restart)) (declare-function vm-update-draft-count "vm.el" ()) (declare-function vm "vm.el" (&optional folder &key read-only access-method reload revisit)) (declare-function vm-mode "vm.el" (&optional read-only)) ;; Operations for vm-folder-access-data (defsubst vm-folder-pop-maildrop-spec () (aref vm-folder-access-data 0)) (defsubst vm-folder-pop-process () (aref vm-folder-access-data 1)) (defsubst vm-set-folder-pop-maildrop-spec (val) (aset vm-folder-access-data 0 val)) (defsubst vm-set-folder-pop-process (val) (aset vm-folder-access-data 1 val)) ;; the maildrop spec of the imap folder (defsubst vm-folder-imap-maildrop-spec () (aref vm-folder-access-data 0)) ;; current imap process of the folder - each folder has a separate one (defsubst vm-folder-imap-process () (aref vm-folder-access-data 1)) ;; the UIDVALIDITY value of the imap folder on the server (defsubst vm-folder-imap-uid-validity () (aref vm-folder-access-data 2)) ;; the list of uid's and flags of the messages in the imap folder on ;; the server (msg-num . uid . size . flags list) (defsubst vm-folder-imap-uid-list () (aref vm-folder-access-data 3)) ;; the number of messages in the imap folder on the server (defsubst vm-folder-imap-mailbox-count () (aref vm-folder-access-data 4)) ;; flag indicating whether the imap folder allows writing (defsubst vm-folder-imap-read-write () (aref vm-folder-access-data 5)) ;; flag indicating whether the imap folder allows deleting (defsubst vm-folder-imap-can-delete () (aref vm-folder-access-data 6)) ;; flag indicating whether the imap server has body-peek functionality (defsubst vm-folder-imap-body-peek () (aref vm-folder-access-data 7)) ;; list of permanent flags storable on the imap server (defsubst vm-folder-imap-permanent-flags () (aref vm-folder-access-data 8)) ;; obarray of uid's with message numbers as their values (on the server) (defsubst vm-folder-imap-uid-obarray () (aref vm-folder-access-data 9)) ; obarray(uid, msg-num) ;; obarray of uid's with flags lists as their values (on the server) (defsubst vm-folder-imap-flags-obarray () (aref vm-folder-access-data 10)) ; obarray(uid, (size . flags list)) ; cons-pair shared with imap-uid-list ;; the number of recent messages in the imap folder on the server (defsubst vm-folder-imap-recent-count () (aref vm-folder-access-data 11)) ;; the number of messages in the imap folder on the server, when last retrieved (defsubst vm-folder-imap-retrieved-count () (aref vm-folder-access-data 12)) (defsubst vm-set-folder-imap-maildrop-spec (val) (aset vm-folder-access-data 0 val)) (defsubst vm-set-folder-imap-process (val) (aset vm-folder-access-data 1 val)) (defsubst vm-set-folder-imap-uid-validity (val) (aset vm-folder-access-data 2 val)) (defsubst vm-set-folder-imap-uid-list (val) (aset vm-folder-access-data 3 val)) (defsubst vm-set-folder-imap-mailbox-count (val) (aset vm-folder-access-data 4 val)) (defsubst vm-set-folder-imap-read-write (val) (aset vm-folder-access-data 5 val)) (defsubst vm-set-folder-imap-can-delete (val) (aset vm-folder-access-data 6 val)) (defsubst vm-set-folder-imap-body-peek (val) (aset vm-folder-access-data 7 val)) (defsubst vm-set-folder-imap-permanent-flags (val) (aset vm-folder-access-data 8 val)) (defsubst vm-set-folder-imap-uid-obarray (val) (aset vm-folder-access-data 9 val)) (defsubst vm-set-folder-imap-flags-obarray (val) (aset vm-folder-access-data 10 val)) (defsubst vm-set-folder-imap-recent-count (val) (aset vm-folder-access-data 11 val)) (defsubst vm-set-folder-imap-retrieved-count (val) (aset vm-folder-access-data 12 val)) (defun vm-set-buffer-modified-p (flag &optional buffer) "Sets the `buffer-modified-p' of the current folder to FLAG. Optional argument BUFFER can ask for it to be done for some other folder. This function is deprecated. Use `vm-mark-folder-modified-p' or `vm-unmark-folder-modified-p' instead." (if flag (vm-mark-folder-modified-p buffer) (vm-unmark-folder-modified-p buffer))) (defun vm-mark-folder-modified-p (&optional buffer) "Sets the `buffer-modified-p' flag of the current folder to t. Optional argument BUFFER can ask for it to be done for some other folder. This function also zeroes `vm-messages-not-on-disk' and schedules the folder for redisplay." (with-current-buffer (or buffer (current-buffer)) (set-buffer-modified-p t) (vm-increment vm-modification-counter) (intern (buffer-name) vm-buffers-needing-display-update) (setq vm-messages-not-on-disk 0))) (defun vm-unmark-folder-modified-p (buffer) "Sets the `buffer-modified-p' flag of the current folder to nil." (with-current-buffer (or buffer (current-buffer)) (set-buffer-modified-p nil) (vm-increment vm-modification-counter) (intern (buffer-name) vm-buffers-needing-display-update))) (defun vm-reset-buffer-modified-p (value buffer) "Sets the `buffer-modified-p' flag of BUFFER to VALUE. This is not meant for changing the flag for folders. Use `vm-mark-folder-modified-p' or `vm-unset-folder-modified-p' instead." (with-current-buffer buffer (set-buffer-modified-p value))) (defun vm-restore-buffer-modified-p (value buffer) "Restores the `buffer-modified-p' flag of BUFFER to a saved VALUE. This is the same as `vm-reset-buffer-modified-p' but represents a specific intent." (with-current-buffer buffer (set-buffer-modified-p value))) (defun vm-message-position (m) "Return a message-pointer pointing to the message M in the `vm-message-list'." (memq m vm-message-list)) (defun vm-number-messages (&optional start-point end-point) "Set the number-of and padded-number-of slots of messages in vm-message-list. If non-nil, START-POINT should point to a cons cell in vm-message-list and the numbering will begin there, else the numbering will begin at the head of vm-message-list. If START-POINT is non-nil the reverse-link-of slot of the message in the cons must be valid and the message pointed to (if any) must have a non-nil number-of slot, because it is used to determine what the starting message number should be. If non-nil, END-POINT should point to a cons cell in vm-message-list and the numbering will end with the message just before this cell. A nil value means numbering will be done until the end of vm-message-list is reached." (let ((n 1) (message-list vm-message-list)) (when (and start-point (vm-reverse-link-of (car start-point))) (if (null (vm-number-of (car (vm-reverse-link-of (car start-point))))) (vm-warn 0 2 "Bad numbering start-point; please report bug.") (setq n (1+ (string-to-number (vm-number-of (car (vm-reverse-link-of (car start-point)))))) message-list start-point))) (while (not (eq message-list end-point)) (vm-set-number-of (car message-list) (int-to-string n)) (vm-set-padded-number-of (car message-list) (format "%3d" n)) (setq n (1+ n) message-list (cdr message-list))) (or end-point (setq vm-ml-highest-message-number (int-to-string (1- n)))) (if vm-summary-buffer (vm-copy-local-variables vm-summary-buffer 'vm-ml-highest-message-number)))) (defun vm-set-numbering-redo-start-point (start-point) "Set vm-numbering-redo-start-point to START-POINT if appropriate. Also mark the current buffer as needing a display update. START-POINT should be a cons in vm-message-list or just t. (t means start from the beginning of vm-message-list.) If START-POINT is closer to the head of vm-message-list than vm-numbering-redo-start-point or is equal to t, then vm-numbering-redo-start-point is set to match it. If START-POINT is nil, nothing is updated." (when start-point (intern (buffer-name) vm-buffers-needing-display-update) (cond ((eq vm-numbering-redo-start-point t) nil) ((and (consp start-point) (consp vm-numbering-redo-start-point)) (let ((mp vm-message-list)) (while (and mp (not (or (eq (car mp) (car start-point)) (eq (car mp) (car vm-numbering-redo-start-point))))) (setq mp (cdr mp))) (when (null mp) (error "Something is wrong in vm-set-numbering-redo-start-point")) (when (eq (car mp) (car start-point)) (setq vm-numbering-redo-start-point start-point)))) (t (setq vm-numbering-redo-start-point start-point))))) (defun vm-set-numbering-redo-end-point (end-point) "Set vm-numbering-redo-end-point to END-POINT if appropriate. Also mark the current buffer as needing a display update. END-POINT should be a cons in vm-message-list or just t. (t means number all the way to the end of vm-message-list.) If END-POINT is closer to the end of vm-message-list or is equal to t, then vm-numbering-redo-start-point is set to match it. The number-of slot is used to determine proximity to the end of vm-message-list, so this slot must be valid in END-POINT's message and the message in the cons pointed to by vm-numbering-redo-end-point. If END-PIONT is nil, nothing is updated." (when end-point (intern (buffer-name) vm-buffers-needing-display-update) (cond ((eq end-point t) (setq vm-numbering-redo-end-point t)) ((and (consp end-point) (> (string-to-number (vm-number-of (car end-point))) (string-to-number (vm-number-of (car vm-numbering-redo-end-point))))) (setq vm-numbering-redo-end-point end-point)) ((null end-point) (setq vm-numbering-redo-end-point end-point))))) (defun vm-do-needed-renumbering () "Number messages in vm-message-list as specified by vm-numbering-redo-start-point and vm-numbering-redo-end-point. vm-numbering-redo-start-point = t means start at the head of vm-message-list. vm-numbering-redo-end-point = t means number all the way to the end of vm-message-list. Otherwise the variables' values should be conses in vm-message-list or nil." (when vm-numbering-redo-start-point (vm-number-messages (if (consp vm-numbering-redo-start-point) vm-numbering-redo-start-point) vm-numbering-redo-end-point) (setq vm-numbering-redo-start-point nil vm-numbering-redo-end-point nil))) (defun vm-set-summary-redo-start-point (start-point) "Set vm-summary-redo-start-point to START-POINT if appropriate. Also mark the current buffer as needing a display update. START-POINT should be a cons in vm-message-list or just t. (t means start from the beginning of vm-message-list.) If START-POINT is closer to the head of vm-message-list than vm-summary-redo-start-point or is equal to t, then vm-summary-redo-start-point is set to match it. If START-POINT is nil, nothing is updated." (when start-point (intern (buffer-name) vm-buffers-needing-display-update) (cond ((eq vm-summary-redo-start-point t) nil) ((and (consp start-point) (consp vm-summary-redo-start-point)) (let ((mp vm-message-list)) (while (and mp (not (or (eq mp start-point) (eq mp vm-summary-redo-start-point)))) (setq mp (cdr mp))) (when (null mp) (error "Something is wrong in vm-set-summary-redo-start-point")) (when (eq mp start-point) (setq vm-summary-redo-start-point start-point)))) (t (setq vm-summary-redo-start-point start-point))))) (defun vm-mark-for-summary-update (m &optional dont-kill-cache) "Mark message M and all its mirrored mesages for a summary update. Also mark M's buffer as needing a display update. Any virtual messages of M and their buffers are similarly marked for update. If M is a virtual message and virtual mirroring is in effect for M (i.e. attribute-of eq attributes-of M's real message), M's real message and its buffer are scheduled for an update. Optional arg DONT-KILL-CACHE non-nil means don't invalidate the summary-of slot for any messages marked for update. This is meant to be used by functions that update message information that is not cached in the summary-of slot, e.g. message numbers and thread indentation." (cond ((eq m (vm-real-message-of m)) ;; this is a real message. ;; its summary and modeline need to be updated. (unless dont-kill-cache ;; toss the cache. this also tosses the cache of any ;; virtual messages mirroring this message. the summary ;; entry cache must be cleared when an attribute of a ;; message that could appear in the summary has changed. (vm-set-summary-of m nil)) (when (vm-su-start-of m) (vm-add-to-list m vm-messages-needing-summary-update)) (intern (buffer-name (vm-buffer-of m)) vm-buffers-needing-display-update) ;; find the virtual messages of this real message that ;; need a summary update. (dolist (v-m (vm-virtual-messages-of m)) (when (eq (vm-attributes-of m) (vm-attributes-of v-m)) (when (vm-su-start-of v-m) (vm-add-to-list v-m vm-messages-needing-summary-update)) ;; don't trust blindly. The user could have killed some ;; of these buffers (when (buffer-name (vm-buffer-of v-m)) (intern (buffer-name (vm-buffer-of v-m)) vm-buffers-needing-display-update))))) (t ;; this is a virtual message. ;; ;; if this message has virtual messages then we need to ;; schedule updates for all the virtual messages that ;; share a cache with this message and we need to ;; schedule an update for the underlying real message ;; since we are mirroring it. ;; ;; if there are no virtual messages, then this virtual ;; message is not mirroring its real message so we need ;; only take care of this one message. (if (vm-virtual-messages-of m) (progn ;; schedule updates for all the virtual message who share ;; the same cache as this message. (dolist (v-m (vm-virtual-messages-of m)) (when (eq (vm-attributes-of m) (vm-attributes-of v-m)) (when (vm-su-start-of v-m) (vm-add-to-list v-m vm-messages-needing-summary-update)) (when (buffer-name (vm-buffer-of v-m)) (intern (buffer-name (vm-buffer-of v-m)) vm-buffers-needing-display-update)))) ;; now take care of the real message (unless dont-kill-cache ;; toss the cache. this also tosses the cache of ;; any virtual messages sharing the same cache as ;; this message. (vm-set-summary-of m nil)) (when (vm-su-start-of (vm-real-message-of m)) (vm-add-to-list (vm-real-message-of m) vm-messages-needing-summary-update)) (intern (buffer-name (vm-buffer-of (vm-real-message-of m))) vm-buffers-needing-display-update)) (unless dont-kill-cache (vm-set-virtual-summary-of m nil)) (when (vm-su-start-of m) (vm-add-to-list m vm-messages-needing-summary-update)) (intern (buffer-name (vm-buffer-of m)) vm-buffers-needing-display-update))))) (defun vm-do-needed-mode-line-update () "Do a modeline update for the current folder buffer. This means setting up all the various vm-ml attribute variables in the folder buffer and copying necessary variables to the folder buffer's summary and presentation buffers, and then forcing Emacs to update all modelines. If a virtual folder being updated has no messages, then erase-buffer is called on its buffer. If any type of folder is empty, erase-buffer is called on its presentation buffer, if any." ;; XXX This last bit should probably should be moved to ;; XXX vm-expunge-folder. (if (null vm-message-pointer) (progn ;; erase the leftover message if the folder is really empty. (if (eq major-mode 'vm-virtual-mode) (let ((buffer-read-only nil) (omodified (buffer-modified-p))) (unwind-protect (erase-buffer) (vm-restore-buffer-modified-p omodified (current-buffer))))) (if (and vm-presentation-buffer (buffer-name vm-presentation-buffer)) (let ((omodified (buffer-modified-p))) (unwind-protect (with-current-buffer vm-presentation-buffer (let ((buffer-read-only nil)) (erase-buffer))) (vm-restore-buffer-modified-p omodified (current-buffer)))))) ;; try to avoid calling vm-su-labels if possible so as to ;; avoid loading vm-summary.el. (if (vm-labels-of (car vm-message-pointer)) (setq vm-ml-labels (vm-su-labels (car vm-message-pointer))) (setq vm-ml-labels nil)) (setq vm-ml-message-number (vm-number-of (car vm-message-pointer))) (setq vm-ml-message-new (vm-new-flag (car vm-message-pointer))) (setq vm-ml-message-unread (vm-unread-flag (car vm-message-pointer))) (setq vm-ml-message-read (and (not (vm-new-flag (car vm-message-pointer))) (not (vm-unread-flag (car vm-message-pointer))))) (setq vm-ml-message-edited (vm-edited-flag (car vm-message-pointer))) (setq vm-ml-message-filed (vm-filed-flag (car vm-message-pointer))) (setq vm-ml-message-written (vm-written-flag (car vm-message-pointer))) (setq vm-ml-message-replied (vm-replied-flag (car vm-message-pointer))) (setq vm-ml-message-forwarded (vm-forwarded-flag (car vm-message-pointer))) (setq vm-ml-message-redistributed (vm-redistributed-flag (car vm-message-pointer))) (setq vm-ml-message-deleted (vm-deleted-flag (car vm-message-pointer))) (setq vm-ml-message-marked (vm-mark-of (car vm-message-pointer)))) (if (and vm-summary-buffer (buffer-name vm-summary-buffer)) (let ((modified (buffer-modified-p))) (vm-copy-local-variables vm-summary-buffer 'default-directory 'vm-ml-message-new 'vm-ml-message-unread 'vm-ml-message-read 'vm-ml-message-edited 'vm-ml-message-replied 'vm-ml-message-forwarded 'vm-ml-message-filed 'vm-ml-message-written 'vm-ml-message-deleted 'vm-ml-message-marked 'vm-ml-message-redistributed 'vm-ml-message-number 'vm-ml-highest-message-number 'vm-folder-read-only 'vm-folder-type 'vm-virtual-folder-definition 'vm-virtual-mirror 'vm-ml-sort-keys 'vm-ml-labels 'vm-spooled-mail-waiting 'vm-message-list) (vm-reset-buffer-modified-p modified vm-summary-buffer))) (if (and vm-presentation-buffer (buffer-name vm-presentation-buffer)) (let ((modified (buffer-modified-p))) (vm-copy-local-variables vm-presentation-buffer 'default-directory 'vm-ml-message-new 'vm-ml-message-unread 'vm-ml-message-read 'vm-ml-message-edited 'vm-ml-message-replied 'vm-ml-message-forwarded 'vm-ml-message-filed 'vm-ml-message-written 'vm-ml-message-deleted 'vm-ml-message-marked 'vm-ml-message-number 'vm-ml-message-redistributed 'vm-ml-highest-message-number 'vm-folder-read-only 'vm-folder-type 'vm-virtual-folder-definition 'vm-virtual-mirror 'vm-ml-labels 'vm-spooled-mail-waiting 'vm-message-list) (vm-reset-buffer-modified-p modified vm-presentation-buffer))) (vm-force-mode-line-update)) (defun vm-update-summary-and-mode-line () "Update summary and mode line for all VM folder and summary buffers. Really this updates all the visible status indicators. Message lists are renumbered. Summary entries are wiped and regenerated. Mode lines are updated. Toolbars are updated." (save-excursion (vm-update-draft-count) (mapatoms (function (lambda (b) (setq b (get-buffer (symbol-name b))) (when b (set-buffer b) (intern (buffer-name) vm-buffers-needing-undo-boundaries) (vm-check-for-killed-summary) (when (and vm-use-toolbar (vm-toolbar-support-possible-p)) (vm-toolbar-update-toolbar)) (when vm-summary-show-threads (vm-build-threads-if-unbuilt)) (vm-do-needed-renumbering) (when vm-summary-buffer (vm-do-needed-summary-rebuild)) (vm-do-needed-mode-line-update)))) vm-buffers-needing-display-update) (fillarray vm-buffers-needing-display-update 0)) (when vm-messages-needing-summary-update (let ((n 1) (ms vm-messages-needing-summary-update) m) (while ms (setq m (car ms)) (unless (or (eq (vm-deleted-flag m) 'expunged) (equal (vm-message-id-number-of m) "Q")) (vm-update-message-summary (car ms))) (if (eq (mod n 10) 0) (vm-inform 6 "Recreating summary... %s" n)) (setq n (1+ n)) (setq ms (cdr ms))) (vm-inform 6 "Recreating summary... done") (setq vm-messages-needing-summary-update nil))) (vm-do-needed-folders-summary-update) (vm-force-mode-line-update)) (defun vm-reverse-link-messages () "Set reverse links for all messages in vm-message-list." (let ((mp vm-message-list) (prev nil)) (while mp (vm-set-reverse-link-of (car mp) prev) (setq prev mp mp (cdr mp))))) (defun vm-match-ordered-header (alist) "Try to match a header in ALIST and return the matching cell. This is used by header ordering code. ALIST looks like this ((\"From\") (\"To\")). This function returns the alist element whose car matches the header starting at point. The header ordering code uses the cdr of the element returned to hold headers to be output later." (let ((case-fold-search t)) (catch 'match (while alist (if (looking-at (car (car alist))) (throw 'match (car alist))) (setq alist (cdr alist))) nil))) (defun vm-match-header (&optional header-name) "Match a header and save some state information about the matched header. Optional first arg HEADER-NAME means match the header only if it matches HEADER-NAME. HEADER-NAME should be a string containing a header name. The string should end with a colon if just that name should be matched. A string that does not end in a colon will match all headers that begin with that string. State information is stored in vm-matched-header-vector bound to a vector of this form. [ header-start header-end header-name-start header-name-end header-contents-start header-contents-end ] Elements are integers. There are functions to access and use this info." (let ((case-fold-search t) (header-name-regexp "\\([^ \t\n:]+\\):")) (if (if header-name (and (looking-at header-name) (looking-at header-name-regexp)) (looking-at header-name-regexp)) (save-excursion (aset vm-matched-header-vector 0 (point)) (aset vm-matched-header-vector 2 (point)) (aset vm-matched-header-vector 3 (match-end 1)) (goto-char (match-end 0)) ;; skip leading whitespace (skip-chars-forward " \t") (aset vm-matched-header-vector 4 (point)) (forward-line 1) (while (looking-at "[ \t]") (forward-line 1)) (aset vm-matched-header-vector 1 (point)) ;; drop the trailing newline (aset vm-matched-header-vector 5 (1- (point))))))) (defun vm-matched-header () "Returns the header last matched by vm-match-header. Trailing newline is included." (vm-buffer-substring-no-properties (aref vm-matched-header-vector 0) (aref vm-matched-header-vector 1))) (defun vm-matched-header-name () "Returns the name of the header last matched by vm-match-header." (vm-buffer-substring-no-properties (aref vm-matched-header-vector 2) (aref vm-matched-header-vector 3))) (defun vm-matched-header-contents () "Returns the contents of the header last matched by vm-match-header. Trailing newline is not included." (vm-buffer-substring-no-properties (aref vm-matched-header-vector 4) (aref vm-matched-header-vector 5))) (defun vm-matched-header-start () "Returns the start position of the header last matched by vm-match-header." (aref vm-matched-header-vector 0)) (defun vm-matched-header-end () "Returns the end position of the header last matched by vm-match-header." (aref vm-matched-header-vector 1)) (defun vm-matched-header-name-start () "Returns the start position of the name of the header last matched by vm-match-header." (aref vm-matched-header-vector 2)) (defun vm-matched-header-name-end () "Returns the end position of the name of the header last matched by vm-match-header." (aref vm-matched-header-vector 3)) (defun vm-matched-header-contents-start () "Returns the start position of the contents of the header last matched by vm-match-header." (aref vm-matched-header-vector 4)) (defun vm-matched-header-contents-end () "Returns the end position of the contents of the header last matched by vm-match-header." (aref vm-matched-header-vector 5)) (defun vm-get-folder-type (&optional file start end ignore-visited) "Return a symbol indicating the folder type of the current buffer. This function works by examining the beginning of a folder. If optional arg FILE is present the type of FILE is returned instead. If FILE is being visited, the type of the buffer is returned. If optional second and third arg START and END are provided, vm-get-folder-type will examine the text between those buffer positions. START and END default to 1 and (buffer-size) + 1. If IGNORED-VISITED is non-nil, even if FILE is being visited, its buffer is ignored and the disk copy of FILE is examined. Returns nil if folder has no type (empty) unknown if the type is not known to VM mmdf for MMDF folders babyl for BABYL folders From_ for BSD UNIX From_ folders BellFrom_ for old SysV From_ folders From_-with-Content-Length for new SysV folders that use the Content-Length header If vm-trust-From_-with-Content-Length is non-nil, From_-with-Content-Length is returned if the first message in the folder has a Content-Length header and the folder otherwise looks like a From_ folder. Since BellFrom_ and From_ folders cannot be reliably distinguished from each other, you must tell VM which one your system uses by setting the variable vm-default-From_-folder-type to either From_ or BellFrom_. For folders that could be From_ or BellFrom_ folders, the value of vm-default-From_folder-type will be returned." (let ((temp-buffer nil) (b nil) (case-fold-search nil)) (unwind-protect (save-excursion (if file (progn (if (not ignore-visited) (setq b (vm-get-file-buffer file))) (if b (set-buffer b) (setq temp-buffer (vm-make-work-buffer)) (set-buffer temp-buffer) (if (file-readable-p file) (condition-case nil (let ((coding-system-for-read (vm-binary-coding-system))) (insert-file-contents file nil 0 4096)) (wrong-number-of-arguments (call-process "sed" file temp-buffer nil "-n" "1,/^$/p"))))))) (save-excursion (save-restriction (or start (setq start 1)) (or end (setq end (1+ (buffer-size)))) (widen) (narrow-to-region start end) (goto-char (point-min)) (cond ((zerop (buffer-size)) nil) ((looking-at "\n*From ") (if (not vm-trust-From_-with-Content-Length) vm-default-From_-folder-type (let ((case-fold-search t)) (re-search-forward vm-content-length-search-regexp nil t)) (cond ((match-beginning 1) vm-default-From_-folder-type) ((match-beginning 0) 'From_-with-Content-Length) (t vm-default-From_-folder-type)))) ((looking-at "\001\001\001\001\n") 'mmdf) ((looking-at "BABYL OPTIONS:") 'babyl) (t 'unknown))))) (and temp-buffer (kill-buffer temp-buffer))))) (defun vm-convert-folder-type (old-type new-type) "Convert buffer from OLD-TYPE to NEW-TYPE. OLD-TYPE and NEW-TYPE should be symbols returned from vm-get-folder-type. This should be called on non-live buffers like crash boxes. This will confuse VM if called on a folder buffer in vm-mode." (let ((vm-folder-type old-type) (pos-list nil) beg end) (goto-char (point-min)) (vm-skip-past-folder-header) (while (vm-find-leading-message-separator) (setq pos-list (cons (point-marker) pos-list)) (vm-skip-past-leading-message-separator) (setq pos-list (cons (point-marker) pos-list)) (vm-find-trailing-message-separator) (setq pos-list (cons (point-marker) pos-list)) (vm-skip-past-trailing-message-separator) (setq pos-list (cons (point-marker) pos-list))) (setq pos-list (nreverse pos-list)) (goto-char (point-min)) (vm-convert-folder-header old-type new-type) (while pos-list (setq beg (car pos-list)) (goto-char (car pos-list)) (insert-before-markers (vm-leading-message-separator new-type)) (delete-region (car pos-list) (car (cdr pos-list))) (vm-convert-folder-type-headers old-type new-type) (setq pos-list (cdr (cdr pos-list))) (setq end (marker-position (car pos-list))) (goto-char (car pos-list)) (insert-before-markers (vm-trailing-message-separator new-type)) (delete-region (car pos-list) (car (cdr pos-list))) (goto-char beg) (vm-munge-message-separators new-type beg end) (setq pos-list (cdr (cdr pos-list)))))) (defun vm-convert-folder-header (old-type new-type) "Convert the folder header form OLD-TYPE to NEW-TYPE. The folder header is the text at the beginning of a folder that is a legal part of the folder but is not part of the first message. This is for dealing with BABYL files." (if (eq old-type 'babyl) (save-excursion (let ((beg (point)) (case-fold-search t)) (cond ((and (looking-at "BABYL OPTIONS:") (search-forward "\037" nil t)) (delete-region beg (point))))))) (if (eq new-type 'babyl) ;; insert before markers so that message location markers ;; for the first message get moved forward. (insert-before-markers "BABYL OPTIONS:\nVersion: 5\n\037"))) (defun vm-skip-past-folder-header () "Move point past the folder header. The folder header is the text at the beginning of a folder that is a legal part of the folder but is not part of the first message. This is for dealing with BABYL files." (cond ((eq vm-folder-type 'babyl) (search-forward "\037" nil 0)))) (defun vm-convert-folder-type-headers (old-type new-type) "Convert headers in the message around point from OLD-TYPE to NEW-TYPE. This means to add/delete Content-Length and any other headers related to folder-type as needed for folder type conversions. This function expects point to be at the beginning of the header section of a message, and it only deals with that message." (let (length) ;; get the length now before the content-length headers are ;; removed. (if (eq new-type 'From_-with-Content-Length) (let (start) (save-excursion (save-excursion (search-forward "\n\n" nil 0) (setq start (point))) (let ((vm-folder-type old-type)) (vm-find-trailing-message-separator)) (setq length (- (point) start))))) ;; chop out content-length header if new format doesn't need ;; it or if the new format computed his own copy. (if (or (eq old-type 'From_-with-Content-Length) (eq new-type 'From_-with-Content-Length)) (save-excursion (while (and (let ((case-fold-search t)) (re-search-forward vm-content-length-search-regexp nil t)) (null (match-beginning 1)) (progn (goto-char (match-beginning 0)) (vm-match-header vm-content-length-header))) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; insert the content-length header if needed (if (eq new-type 'From_-with-Content-Length) (save-excursion (insert vm-content-length-header " " (int-to-string length) "\n"))))) (defun vm-munge-message-separators (folder-type start end) "Munge message separators of FOLDER-TYPE found between START and END. This function is used to eliminate message separators for a particular folder type that happen to occur in a message. \">\" is prepended to such separators." (save-excursion ;; when munging From-type separators it is best to use the ;; least forgiving of the folder types, so that we don't ;; create folders that other mailers or older versions of VM ;; will misparse. (if (eq folder-type 'From_) (setq folder-type 'BellFrom_)) (let ((vm-folder-type folder-type)) (cond ((memq folder-type '(From_ From_-with-Content-Length mmdf BellFrom_ babyl)) (setq end (vm-marker end)) (goto-char start) (while (and (vm-find-leading-message-separator) (< (point) end)) (insert ">")) (set-marker end nil)))))) (defun vm-compatible-folder-p (file) "Return non-nil if FILE is a compatible folder with the current buffer. The current folder must have vm-folder-type initialized. FILE is compatible if - it is empty - the current folder is empty - the two folder types are equal" (let ((type (vm-get-folder-type file))) (or (not (and vm-folder-type type)) (eq vm-folder-type type)))) (defun vm-leading-message-separator (&optional folder-type message for-other-folder) "Returns a leading message separator for the current folder. Defaults to returning a separator for the current folder type. Optional first arg FOLDER-TYPE means return a separator for that folder type instead. Optional second arg MESSAGE should be a message struct. This is used generating BABYL separators, because they contain message attributes and labels that must must be copied from the message. Optional third arg FOR-OTHER-FOLDER non-nil means that this separator will be used a `foreign' folder. This means that the `deleted' attributes should not be copied for BABYL folders." (let ((type (or folder-type vm-folder-type))) (cond ((memq type '(From_ From_-with-Content-Length BellFrom_)) (concat "From VM " (current-time-string) "\n")) ((eq type 'mmdf) "\001\001\001\001\n") ((eq type 'babyl) (cond (message (concat "\014\n0," (vm-babyl-attributes-string message for-other-folder) ",\n*** EOOH ***\n")) (t "\014\n0, recent, unseen,,\n*** EOOH ***\n")))))) (defun vm-trailing-message-separator (&optional folder-type) "Returns a trailing message separator for the current folder. Defaults to returning a separator for the current folder type. Optional first arg FOLDER-TYPE means return a separator for that folder type instead." (let ((type (or folder-type vm-folder-type))) (cond ((eq type 'From_) "\n") ((eq type 'From_-with-Content-Length) "") ((eq type 'BellFrom_) "") ((eq type 'mmdf) "\001\001\001\001\n") ((eq type 'babyl) "\037")))) (defun vm-folder-header (&optional folder-type label-obarray) "Returns a folder header for the current folder. Defaults to returning a folder header for the current folder type. Optional first arg FOLDER-TYPE means return a folder header for that folder type instead. Optional second arg LABEL-OBARRAY should be an obarray of labels that have been used in this folder. This is used for BABYL folders." (let ((type (or folder-type vm-folder-type))) (cond ((eq type 'babyl) (let ((list nil)) (if label-obarray (mapatoms (function (lambda (sym) (setq list (cons sym list)))) label-obarray)) (if list (format "BABYL OPTIONS:\nVersion: 5\nLabels: %s\n\037" (mapconcat (function symbol-name) list ", ")) "BABYL OPTIONS:\nVersion: 5\n\037"))) (t "")))) ;; This separator regexp is a bit too permissive. ;; Jose Manuel Garcia-Patos suggests the following ;; "^From .+[@]?.+ .+ [+-]?[0-9][0-9][0-9][0-9]$" (defvar vm-leading-message-separator-regexp-From_ "^From .*[0-9]$" "Regular expression that matches the leading message separator in From_ type mail folders.") (defvar vm-leading-message-separator-regexp-BellFrom_ "^From .*[0-9]$" "Regular expression that matches the leading message separator in BellFrom_ type mail folders.") (defvar vm-leading-message-separator-regexp-From_-with-Content-Length "\\(^\\|\n+\\)From " "Regular expression that matches the leading message separator in From_-with-Content-Length type mail folders.") (defvar vm-leading-message-separator-regexp-mmdf "^\001\001\001\001" "Regular expression that matches the leading message separator in mmdf_ type mail folders.") (defun vm-find-leading-message-separator () "Find the next leading message separator in a folder. Returns non-nil if the separator is found, nil otherwise." (cond ((eq vm-folder-type 'From_) (let ((case-fold-search nil)) (catch 'done (while (re-search-forward vm-leading-message-separator-regexp-From_ nil 'no-error) (goto-char (match-beginning 0)) (if (or (< (point) 3) (equal (char-after (- (point) 2)) ?\n)) (throw 'done t) (forward-char 1))) nil ))) ((eq vm-folder-type 'BellFrom_) (let ((case-fold-search nil)) (if (re-search-forward vm-leading-message-separator-regexp-BellFrom_ nil 'no-error) (progn (goto-char (match-beginning 0)) t ) nil ))) ((eq vm-folder-type 'From_-with-Content-Length) (let ((case-fold-search nil)) (if (re-search-forward vm-leading-message-separator-regexp-From_-with-Content-Length nil 'no-error) (progn (goto-char (match-end 1)) t) nil ))) ((eq vm-folder-type 'mmdf) (let ((case-fold-search nil)) (if (re-search-forward vm-leading-message-separator-regexp-mmdf nil 'no-error) (progn (goto-char (match-beginning 0)) t ) nil ))) ((eq vm-folder-type 'baremessage) (goto-char (point-max))) ((eq vm-folder-type 'babyl) (let ((reg1 "\014\n[01],") (case-fold-search nil)) (catch 'done (while (re-search-forward reg1 nil 'no-error) (goto-char (match-beginning 0)) (if (and (not (bobp)) (= (preceding-char) ?\037)) (throw 'done t) (forward-char 1))) nil ))))) (defun vm-find-trailing-message-separator () "Find the next trailing message separator in a folder." (cond ((eq vm-folder-type 'From_) (vm-find-leading-message-separator) (forward-char -1)) ((eq vm-folder-type 'BellFrom_) (vm-find-leading-message-separator)) ((eq vm-folder-type 'From_-with-Content-Length) (let ((reg1 "^From ") content-length (start-point (point)) (case-fold-search nil)) (if (and (let ((case-fold-search t)) (re-search-forward vm-content-length-search-regexp nil t)) (null (match-beginning 1)) (progn (goto-char (match-beginning 0)) (vm-match-header vm-content-length-header))) (progn (setq content-length (string-to-number (vm-matched-header-contents))) ;; if search fails, we'll be at point-max ;; if specified content-length is too long, go to point-max (if (search-forward "\n\n" nil 0) (if (>= (- (point-max) (point)) content-length) (forward-char content-length) (goto-char (point-max)))) ;; Some systems seem to add a trailing newline that's ;; not counted in the Content-Length header. Allow ;; any number of them to avoid trouble. (skip-chars-forward "\n"))) (if (or (eobp) (looking-at reg1)) nil (goto-char start-point) (if (re-search-forward reg1 nil 0) (forward-char -5))))) ((eq vm-folder-type 'mmdf) (vm-find-leading-message-separator)) ((eq vm-folder-type 'baremessage) (goto-char (point-max))) ((eq vm-folder-type 'babyl) (vm-find-leading-message-separator) (forward-char -1)))) (defun vm-skip-past-leading-message-separator () "Move point past a leading message separator at point." (cond ((memq vm-folder-type '(From_ BellFrom_ From_-with-Content-Length)) (let ((reg1 "^>From ") (case-fold-search nil)) (forward-line 1) (while (looking-at reg1) (forward-line 1)))) ((eq vm-folder-type 'mmdf) (forward-char 5) ;; skip >From. Either SCO's MMDF implementation leaves this ;; stuff in the message, or many sysadmins have screwed up ;; their mail configuration. Either way I'm tired of getting ;; bug reports about it. (let ((reg1 "^>From ") (case-fold-search nil)) (while (looking-at reg1) (forward-line 1)))) ((eq vm-folder-type 'babyl) (search-forward "\n*** EOOH ***\n" nil 0)))) (defun vm-skip-past-trailing-message-separator () "Move point past a trailing message separator at point." (cond ((eq vm-folder-type 'From_) (if (not (eobp)) (forward-char 1))) ((eq vm-folder-type 'From_-with-Content-Length)) ((eq vm-folder-type 'BellFrom_)) ((eq vm-folder-type 'mmdf) (forward-char 5)) ((eq vm-folder-type 'babyl) (forward-char 1)))) (defun vm-build-message-list () "Build a chain of message structures, stored them in vm-message-list. Finds the start and end of each message and fills in the relevant fields in the message structures. Also finds the beginning of the header section and the end of the text section and fills in these fields in the message structures. vm-text-of and vm-vheaders-of fields don't get filled until they are needed. If vm-message-list already contained messages, the end of the last known message is found and then the parsing of new messages begins there and the message are appended to vm-message-list. vm-folder-type is initialized here." (setq vm-folder-type (vm-get-folder-type)) (save-excursion (let ((tail-cons nil) (n 0) ;; Just for yucks, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 25)) message last-end) (if vm-message-list ;; there are already messages, therefore we're supposed ;; to add to this list. (let ((mp vm-message-list) (end (point-min))) ;; first we have to find physical end of the folder ;; prior to the new messages that just came in. (while mp (if (< end (vm-end-of (car mp))) (setq end (vm-end-of (car mp)))) (if (not (consp (cdr mp))) (setq tail-cons mp)) (setq mp (cdr mp))) (goto-char end)) ;; there are no messages so we're building the whole list. ;; start from the beginning of the folder. (goto-char (point-min)) ;; whine about newlines at the beginning of the folder. ;; technically I think this is corruption, but there are ;; too many busted mail-do-fcc's installed out there to ;; do more than whine. (if (and (memq vm-folder-type '(From_ BellFrom_ From_-with-Content-Length)) (= (following-char) ?\n)) (vm-warn 0 2 "Warning: newline found at beginning of folder, %s" (or buffer-file-name (buffer-name)))) (vm-skip-past-folder-header)) (setq last-end (point)) ;; parse the messages, set the markers that specify where ;; things are. (while (vm-find-leading-message-separator) (setq message (vm-make-message)) (vm-set-message-type-of message vm-folder-type) (vm-set-message-access-method-of message vm-folder-access-method) (vm-set-start-of message (vm-marker (point))) (vm-skip-past-leading-message-separator) (vm-set-headers-of message (vm-marker (point))) (vm-find-trailing-message-separator) (vm-set-text-end-of message (vm-marker (point))) (vm-skip-past-trailing-message-separator) (setq last-end (point)) (vm-set-end-of message (vm-marker (point))) (vm-set-reverse-link-of message tail-cons) (if (null tail-cons) (setq vm-message-list (list message) tail-cons vm-message-list) (setcdr tail-cons (list message)) (setq tail-cons (cdr tail-cons))) (vm-increment n) (if (zerop (% n modulus)) (vm-inform 7 "Parsing messages... %d" n))) (if (>= n modulus) (vm-inform 7 "Parsing messages... done")) (if (and (not (= last-end (point-max))) (not (eq vm-folder-type 'unknown))) (vm-warn 1 2 "Warning: garbage found at end of folder, %s, starting at %d" (or buffer-file-name (buffer-name)) last-end))))) (defun vm-build-header-order-alist (vheaders) (let ((order-alist (cons nil nil)) list) (setq list order-alist) (while vheaders (setcdr list (cons (cons (car vheaders) nil) nil)) (setq list (cdr list) vheaders (cdr vheaders))) (cdr order-alist))) ;; Reorder the headers in a message. ;; ;; If a message struct is passed into this function, then we're ;; operating on a message in a folder buffer. Headers are ;; grouped so that the headers that the user wants to see are at ;; the end of the headers section so we can narrow to them. This ;; is done according to the preferences specified in ;; vm-visible-header and vm-invisible-header-regexp. The ;; vheaders field of the message struct is also set. This ;; function is called on demand whenever a vheaders field is ;; discovered to be nil for a particular message. ;; ;; If the message argument is nil, then we are operating on a ;; freestanding message that is not part of a folder buffer. The ;; keep-list and discard-regexp parameters are used in this case. ;; Headers not matched by the keep list or matched by the discard ;; list are stripped from the message. The remaining headers ;; are ordered according to the order of the keep list. ;;;###autoload (defun* vm-reorder-message-headers (message &optional &key (keep-list nil) (discard-regexp nil)) (interactive (progn (goto-char (point-min)) (list nil vm-mail-header-order "NO_MATCH_ON_HEADERS:"))) (save-excursion (when message (with-current-buffer (vm-buffer-of message) (setq keep-list vm-visible-headers discard-regexp vm-invisible-header-regexp))) (save-excursion (save-restriction (widen) ;; if there is a cached regexp that points to the already ;; ordered headers then use it and avoid a lot of work. (if (and message (vm-vheaders-regexp-of message)) (save-excursion (goto-char (vm-headers-of message)) (let ((case-fold-search t)) (re-search-forward (vm-vheaders-regexp-of message) (vm-text-of message) t)) (vm-set-vheaders-of message (vm-marker (match-beginning 0)))) ;; oh well, we gotta do it the hard way. ;; ;; header-alist will contain an assoc list version of ;; keep-list. For messages associated with a folder ;; buffer: when a matching header is found, the ;; header's start and end positions are added to its ;; corresponding assoc cell. The positions of unwanted ;; headers are remember also so that they can be copied ;; to the top of the message, to be out of sight after ;; narrowing. Once the positions have all been ;; recorded a new copy of the headers is inserted in ;; the proper order and the old headers are deleted. ;; ;; For free standing messages, unwanted headers are ;; stripped from the message, unremembered. (vm-save-restriction (let ((header-alist (vm-build-header-order-alist keep-list)) (buffer-read-only nil) (work-buffer nil) (extras nil) list end-of-header vheader-offset (folder-buffer (current-buffer)) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock directory ;; is on a slow device. We don't need locking here because ;; in a mail context reordering headers is harmless. (buffer-file-name nil) (case-fold-search t) (unwanted-list nil) unwanted-tail new-header-start old-header-start (old-buffer-modified-p (buffer-modified-p))) (unwind-protect (progn (if message (progn ;; for babyl folders, keep an untouched ;; copy of the headers between the ;; attributes line and the *** EOOH *** ;; line. (if (and (eq vm-folder-type 'babyl) (null (vm-babyl-frob-flag-of message))) (progn (goto-char (vm-start-of message)) (forward-line 2) (vm-set-babyl-frob-flag-of message t) (insert-buffer-substring (current-buffer) (vm-headers-of message) (1- (vm-text-of message))) ;; Yep, messages can come in ;; without the two newlines after ;; the header section. (if (not (eq (char-after (1- (point))) ?\n)) (insert ?\n)))) (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert-buffer-substring folder-buffer (vm-headers-of message) (vm-text-of message)) (goto-char (point-min)))) (setq old-header-start (point)) ;; as we loop through the headers, skip >From ;; lines. these can occur anywhere in the ;; header section if the message has been ;; manhandled by some dumb delivery agents ;; (SCO and Solaris are the usual suspects.) ;; it's a tough ol' world. (while (progn (while (looking-at ">From ") (forward-line)) (and (not (= (following-char) ?\n)) (vm-match-header))) (setq end-of-header (vm-matched-header-end) list (vm-match-ordered-header header-alist)) ;; don't display/keep this header if ;; keep-list not matched ;; and discard-regexp is nil ;; or ;; discard-regexp is matched (if (or (and (null list) (null discard-regexp)) (and discard-regexp (not (eq 'none discard-regexp)) discard-regexp (looking-at discard-regexp))) ;; delete the unwanted header if not doing ;; work for a folder buffer, otherwise ;; remember the start and end of the ;; unwanted header so we can copy it ;; later. (if (not message) (delete-region (point) end-of-header) (if (null unwanted-list) (setq unwanted-list (cons (point) (cons end-of-header nil)) unwanted-tail unwanted-list) (if (= (point) (car (cdr unwanted-tail))) (setcar (cdr unwanted-tail) end-of-header) (setcdr (cdr unwanted-tail) (cons (point) (cons end-of-header nil))) (setq unwanted-tail (cdr (cdr unwanted-tail))))) (goto-char end-of-header)) ;; got a match ;; stuff the start and end of the header ;; into the cdr of the returned alist ;; element. (if list ;; reverse point and end-of-header. ;; list will be nreversed later. (setcdr list (cons end-of-header (cons (point) (cdr list)))) ;; reverse point and end-of-header. ;; list will be nreversed later. (setq extras (cons end-of-header (cons (point) extras)))) (goto-char end-of-header))) (setq new-header-start (point)) (while unwanted-list (insert-buffer-substring (current-buffer) (car unwanted-list) (car (cdr unwanted-list))) (setq unwanted-list (cdr (cdr unwanted-list)))) ;; remember the offset of where the visible ;; header start so we can initialize the ;; vm-vheaders-of field later. (if message (setq vheader-offset (- (point) new-header-start))) (while header-alist (setq list (nreverse (cdr (car header-alist)))) (while list (insert-buffer-substring (current-buffer) (car list) (car (cdr list))) (setq list (cdr (cdr list)))) (setq header-alist (cdr header-alist))) ;; now the headers that were not explicitly ;; undesirable, if any. (setq extras (nreverse extras)) (while extras (insert-buffer-substring (current-buffer) (car extras) (car (cdr extras))) (setq extras (cdr (cdr extras)))) (delete-region old-header-start new-header-start) ;; update the folder buffer if we're supposed to. ;; lock out interrupts. (if message (let ((inhibit-quit t)) (set-buffer (vm-buffer-of message)) (goto-char (vm-headers-of message)) (insert-buffer-substring work-buffer) (delete-region (point) (vm-text-of message)) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))) (when work-buffer (kill-buffer work-buffer))) (if message (progn (vm-set-vheaders-of message (vm-marker (+ (vm-headers-of message) vheader-offset))) ;; cache a regular expression that can be used to ;; find the start of the reordered header the next ;; time this folder is visited. (goto-char (vm-vheaders-of message)) (if (vm-match-header) (vm-set-vheaders-regexp-of message (concat "^" (vm-matched-header-name) ":")))))))))))) ;; Thunderbird source code files describing the status flags ;; http://mxr.mozilla.org/seamonkey/source/mailnews/base/public/nsMsgMessageFlags.h#45 ;; http://mxr.mozilla.org/seamonkey/source/mailnews/base/public/nsMsgMessageFlags.h#108 ;; Commentary here: ;; http://www.eyrich-net.org/mozilla/X-Mozilla-Status.html?en (defun vm-read-thunderbird-status (message) (let (status) (setq status (vm-get-header-contents message "X-Mozilla-Status:")) (when status (setq status (string-to-number status 16)) ;; read flag (vm-set-unread-flag-of message (= 0 (logand status #x0001))) ;; answered flag (vm-set-replied-flag-of message (not (= 0 (logand status #x0002)))) ;; flagged flag (vm-set-flagged-flag-of message (not (= 0 (logand status #x0004)))) ;; deleted flag (vm-set-deleted-flag-of message (not (= 0 (logand status #x0008)))) ;; (unless (= 0 (logand status #x0010)) ; subject with "Re:" prefix ;; nil) ;; folded flag (vm-set-folded-flag-of message (not (= 0 (logand status #x0020)))) ;; (unless (= 0 (logand status #x0080)) ; offline article ;; nil) ;; watched flag (vm-set-watched-flag-of message (not (= 0 (logand status #x0100)))) ;; (unless (= 0 (logand status #x0200)) ; authenticated sender ;; nil) ;; (unless (= 0 (logand status #x0400)) ; remote POP article ;; nil) ;; (unless (= 0 (logand status #x0800)) ; queued ;; nil) ;; forwarded (vm-set-forwarded-flag-of message (not (= 0 (logand status #x1000))))) (setq status (vm-get-header-contents message "X-Mozilla-Status2:")) (when status (if (> (length status) 4) (progn (setq status (substring status 0 -4)) ; ignore the last 4 hextets, ; which are assumed to be 0000 (setq status (string-to-number status 16))) ;; handle badly formatted status strings written by older versions (setq status (string-to-number status 16)) (setq status (/ status #x1000))) ;; new on the server (vm-set-new-flag-of message (not (= 0 (logand status #x0001)))) ;; ignored thread (vm-set-ignored-flag-of message (not (= 0 (logand status #x0004)))) ;; (unless (= 0 (logand status #x0020)) ; deleted on the server ;; nil) ;; read-receipt requested (vm-set-read-receipt-flag-of message (not (= 0 (logand status #x0040)))) ;; read-receipt sent (vm-set-read-receipt-sent-flag-of message (not (logand status #x0080))) ;; (unless (= 0 (logand status #x0100)) ; template ;; nil) ;; has attachments (vm-set-attachments-flag-of message (not (= 0 (logand status #x1000)))) ;; nil) ;; (unless (= 0 (logand status #x0E00)) ;; nil) ;; FIXME care for message labels ) (vm-mark-for-summary-update message) (vm-set-stuff-flag-of message t))) (defun vm-read-attributes (message-list) "Reads the message attributes and cached header information. Reads the message attributes and cached header information from the header portion of the each message, if our X-VM- attributes header is present. If the header is not present, assume the message is new, unless we are being compatible with Berkeley Mail in which case we also check for a Status header. If a message already has attributes don't bother checking the headers. This function also discovers and stores the position where the message text begins. Totals are gathered for use by vm-emit-totals-blurb. Supports version 4 format of attribute storage, for backward compatibility." (save-excursion (let ((mp (or message-list vm-message-list)) (vm-new-count 0) (vm-unread-count 0) (vm-deleted-count 0) (vm-total-count 0) (modulus (+ (% (vm-abs (random)) 11) 25)) (case-fold-search t) oldpoint data cache) (while mp (vm-increment vm-total-count) (if (vm-attributes-of (car mp)) () (goto-char (vm-headers-of (car mp))) ;; find start of text section and save it (search-forward "\n\n" (vm-text-end-of (car mp)) 0) (vm-set-text-of (car mp) (point-marker)) ;; now look for our header (goto-char (vm-headers-of (car mp))) (cond ((re-search-forward vm-attributes-header-regexp (vm-text-of (car mp)) t) (goto-char (match-beginning 2)) (condition-case () (progn (setq oldpoint (point) data (read (current-buffer)) cache (cadr data)) (when (and (or (not (listp data)) (not (> (length data) 1))) (not (vectorp data))) (error "Bad x-vm-v5-data at %d in buffer %s: %S" oldpoint (buffer-name) data) (sit-for 1)) data) (error (vm-warn 1 1 "Bad x-vm-v5-data header at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq data (list (make-vector vm-attributes-vector-length nil) (make-vector vm-cached-data-vector-length nil) nil)) ;; In lieu of a valid attributes header ;; assume the message is new. avoid ;; vm-set-new-flag because it asks for a ;; summary update. (vm-set-new-flag-in-vector (car data) t))) ;; support version 4 format (cond ((vectorp data) (setq data (vm-convert-v4-attributes data)) ;; tink the message stuff flag so that if the ;; user saves we get rid of the old v4 ;; attributes header. otherwise we could be ;; dealing with these things for all eternity. (vm-set-stuff-flag-of (car mp) t)) (t ;; extend vectors if necessary to accomodate ;; more caching and attributes without alienating ;; other version 5 folders. (cond ((< (length (car data)) vm-attributes-vector-length) ;; tink the message stuff flag so that if ;; the user saves we get rid of the old ;; short vector. otherwise we could be ;; dealing with these things for all ;; eternity. (vm-set-stuff-flag-of (car mp) t) (setcar data (vm-extend-vector (car data) vm-attributes-vector-length)))) (cond ((< (length cache) vm-cached-data-vector-length) ;; tink the message stuff flag so that if ;; the user saves we get rid of the old ;; short vector. otherwise we could be ;; dealing with these things for all ;; eternity. (vm-set-stuff-flag-of (car mp) t) (setcar (cdr data) (vm-extend-vector cache vm-cached-data-vector-length)) (setq cache (cadr data)))))) ;; data list might not be long enough for (nth 2 ...) but ;; that's OK because nth returns nil if you overshoot the ;; end of the list. (unless (and (vectorp cache) (= (length cache) vm-cached-data-vector-length) (or (null (aref cache 7)) (stringp (aref cache 7))) (or (null (aref cache 11)) (stringp (aref cache 11)))) (vm-warn 0 2 "Bad VM cache data: %S" cache) (vm-set-stuff-flag-of (car mp) t) (setcar (cdr data) (setq cache (make-vector vm-cached-data-vector-length nil)))) (vm-set-labels-of (car mp) (nth 2 data)) (vm-set-cached-data-of (car mp) cache) (vm-set-attributes-of (car mp) (car data))) ((and vm-berkeley-mail-compatibility (re-search-forward vm-berkeley-mail-status-header-regexp (vm-text-of (car mp)) t)) (vm-set-cached-data-of (car mp) (make-vector vm-cached-data-vector-length nil)) (goto-char (match-beginning 1)) (vm-set-attributes-of (car mp) (make-vector vm-attributes-vector-length nil)) (vm-set-unread-flag (car mp) (not (looking-at ".*R.*")) 'norecord)) (t (vm-set-cached-data-of (car mp) (make-vector vm-cached-data-vector-length nil)) (vm-set-attributes-of (car mp) (make-vector vm-attributes-vector-length nil)) ;; In lieu of a valid attributes header ;; assume the message is new. avoid ;; vm-set-new-flag because it asks for a ;; summary update. (vm-set-new-flag-of (car mp) t))) ;; let babyl attributes override the normal VM ;; attributes header. (cond ((eq vm-folder-type 'babyl) (vm-read-babyl-attributes (car mp)))) ;; read the status flags of Thunderbird (if vm-folder-read-thunderbird-status (vm-read-thunderbird-status (car mp)))) (cond ((vm-deleted-flag (car mp)) (vm-increment vm-deleted-count)) ((vm-new-flag (car mp)) (vm-increment vm-new-count)) ((vm-unread-flag (car mp)) (vm-increment vm-unread-count))) (if (zerop (% vm-total-count modulus)) (vm-inform 6 "Reading attributes... %d" vm-total-count)) (setq mp (cdr mp))) (if (>= vm-total-count modulus) (vm-inform 6 "Reading attributes... done")) (if (null message-list) (setq vm-totals (list vm-modification-counter vm-total-count vm-new-count vm-unread-count vm-deleted-count)))))) (defun vm-read-babyl-attributes (message) (let ((case-fold-search t) (labels nil) (vect (make-vector vm-attributes-vector-length nil))) (vm-set-attributes-of message vect) (save-excursion (goto-char (vm-start-of message)) ;; skip past ^L\n (forward-char 2) (vm-set-babyl-frob-flag-of message (if (= (following-char) ?1) t nil)) ;; skip past 0, (forward-char 2) ;; loop, noting attributes as we go. (while (and (not (eobp)) (not (looking-at ","))) (cond ((looking-at " unseen,") (vm-set-unread-flag-of message t)) ((looking-at " recent,") (vm-set-new-flag-of message t)) ((looking-at " deleted,") (vm-set-deleted-flag-of message t)) ((looking-at " answered,") (vm-set-replied-flag-of message t)) ((looking-at " forwarded,") (vm-set-forwarded-flag-of message t)) ((looking-at " filed,") (vm-set-filed-flag-of message t)) ((looking-at " redistributed,") (vm-set-redistributed-flag-of message t)) ;; only VM knows about these, as far as I know. ((looking-at " edited,") (vm-set-forwarded-flag-of message t)) ((looking-at " written,") (vm-set-forwarded-flag-of message t))) (skip-chars-forward "^,") (and (not (eobp)) (forward-char 1))) (and (not (eobp)) (forward-char 1)) (while (looking-at " \\([^\000-\040,\177-\377]+\\),") (setq labels (cons (vm-buffer-substring-no-properties (match-beginning 1) (match-end 1)) labels)) (goto-char (match-end 0))) (vm-set-labels-of message labels)))) (defun vm-set-default-attributes (message-list) (let ((mp (or message-list vm-message-list)) attr access-method cache) (while mp (setq attr (make-vector vm-attributes-vector-length nil) cache (make-vector vm-cached-data-vector-length nil)) (vm-set-cached-data-of (car mp) cache) (vm-set-attributes-of (car mp) attr) ;; make message be new by default, but avoid vm-set-new-flag ;; because it asks for a summary update for the message. (vm-set-new-flag-of (car mp) t) (vm-set-unread-flag-of (car mp) t) (setq access-method (vm-message-access-method-of (car mp))) (cond ((eq access-method 'imap) (vm-imap-set-default-attributes (car mp))) ((eq access-method 'pop) (vm-pop-set-default-attributes (car mp)))) ;; since this function is usually called in lieu of reading ;; attributes from the buffer, the buffer attributes may be ;; untrustworthy. tink the message stuff flag to force the ;; new attributes out if the user saves. (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp))))) (defun vm-compute-totals () (save-excursion (vm-select-folder-buffer) (let ((mp vm-message-list) (vm-new-count 0) (vm-unread-count 0) (vm-deleted-count 0) (vm-total-count 0)) (while mp (vm-increment vm-total-count) (cond ((vm-deleted-flag (car mp)) (vm-increment vm-deleted-count)) ((vm-new-flag (car mp)) (vm-increment vm-new-count)) ((vm-unread-flag (car mp)) (vm-increment vm-unread-count))) (setq mp (cdr mp))) (setq vm-totals (list vm-modification-counter vm-total-count vm-new-count vm-unread-count vm-deleted-count))))) (defun vm-emit-totals-blurb () (interactive) (save-excursion (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (equal (nth 0 vm-totals) vm-modification-counter)) (vm-compute-totals)) (if (equal (nth 1 vm-totals) 0) (vm-inform 5 "No messages.") (vm-inform 5 "%d message%s, %d new, %d unread, %d deleted" (nth 1 vm-totals) (if (= (nth 1 vm-totals) 1) "" "s") (nth 2 vm-totals) (nth 3 vm-totals) (nth 4 vm-totals))))) (defun vm-convert-v4-attributes (data) (list (apply 'vector (nconc (vm-vector-to-list data) (make-list (- vm-attributes-vector-length (length data)) nil))) (make-vector vm-cached-data-vector-length nil))) (defun vm-gobble-last-modified () (let ((case-fold-search t) (time nil) time lim oldpoint) (save-excursion (vm-save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-last-modified-header-regexp lim t) (condition-case () (progn (setq oldpoint (point) time (read (current-buffer))) (unless (consp time) (error "Bad last-modified header at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) time ) (error (vm-warn 1 1 "Bad last-modified header at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq time '(0 0 0))))))) time )) (defun vm-gobble-labels () (let ((case-fold-search t) lim) (save-excursion (vm-save-restriction (widen) (if (eq vm-folder-type 'babyl) (progn (goto-char (point-min)) (vm-skip-past-folder-header) (setq lim (point)) (goto-char (point-min)) (if (re-search-forward "^Labels:" lim t) (let (string list) (setq string (buffer-substring (point) (progn (end-of-line) (point))) list (vm-parse string "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*")) (mapc (function (lambda (s) (intern (downcase s) vm-label-obarray))) list)))) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-labels-header-regexp lim t) (let ((oldpoint (point)) list) (condition-case () (progn (setq list (read (current-buffer))) (unless (listp list) (error "Bad global label list at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) list ) (error (vm-warn 1 1 "Bad global label list at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq list nil) )) (vm-startup-apply-labels list)))))) t )) (defun vm-startup-apply-labels (labels) (mapcar (function (lambda (s) (intern s vm-label-obarray))) labels)) ;; Go to the message specified in a bookmark and eat the bookmark. ;; Returns non-nil if successful, nil otherwise. (defun vm-gobble-bookmark () (let ((case-fold-search t) (n nil) lim oldpoint) (save-excursion (vm-save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-bookmark-header-regexp lim t) (condition-case () (progn (setq oldpoint (point) n (read (current-buffer))) (unless (natnump n) (error "Bad bookmark at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) n ) (error (vm-warn 1 1 "Bad bookmark at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq n 1)))))) (vm-startup-apply-bookmark n) t )) (defun vm-startup-apply-bookmark (n) (if n (vm-record-and-change-message-pointer vm-message-pointer (nthcdr (1- n) vm-message-list)))) (defun vm-gobble-pop-retrieved () (let ((case-fold-search t) ob lim oldpoint) (save-excursion (vm-save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-pop-retrieved-header-regexp lim t) (condition-case () (progn (setq oldpoint (point) ob (read (current-buffer))) (unless (listp ob) (error "Bad pop-retrieved header at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) (setq vm-pop-retrieved-messages ob)) (error (vm-warn 1 1 "Bad pop-retrieved header at %d in buffer %s, ignoring" oldpoint (buffer-name))))))) t )) (defun vm-gobble-imap-retrieved () (let ((case-fold-search t) ob lim oldpoint) (save-excursion (vm-save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-imap-retrieved-header-regexp lim t) (condition-case () (progn (setq oldpoint (point) ob (read (current-buffer))) (unless (listp ob) (error "Bad imap-retrieved header at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) (setq vm-imap-retrieved-messages ob)) (error (vm-warn 1 1 "Bad imap-retrieved header at %d in buffer %s, ignoring" oldpoint (buffer-name))))))) t )) (defun vm-gobble-visible-header-variables () (save-excursion (vm-save-restriction (let ((case-fold-search t) lim) (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-vheader-header-regexp lim t) (let (vis invis (got nil)) (condition-case () (setq vis (read (current-buffer)) invis (read (current-buffer)) got t) (error nil)) (if got (vm-startup-apply-header-variables vis invis)))))))) (defun vm-startup-apply-header-variables (vis invis) ;; if the variables don't match the values stored when this ;; folder was saved, then we have to discard any cached ;; vheader info so the user will see the right headers. (and (or (not (equal vis vm-visible-headers)) (not (equal invis vm-invisible-header-regexp))) (let ((mp vm-message-list)) (vm-inform 6 "Discarding visible header info...") (while mp (vm-set-vheaders-regexp-of (car mp) nil) (vm-set-vheaders-of (car mp) nil) (setq mp (cdr mp)))))) ;; Read and delete the header that gives the folder's desired ;; message order. (defun vm-gobble-message-order () (let ((case-fold-search t) lim order) (save-excursion (save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-message-order-header-regexp lim t) (let ((oldpoint (point))) (condition-case nil (progn (setq order (read (current-buffer))) (unless (listp order) (error "Bad order header at %d in buffer %s" oldpoint (buffer-name)) (sit-for 1)) order ) (error (vm-warn 1 1 "Bad order header at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq order nil))) (if order (progn (vm-inform 6 "Reordering messages...") (vm-startup-apply-message-order order) (vm-inform 6 "Reordering messages... done"))))))))) (defun vm-has-message-order () (let ((case-fold-search t) lim order) (save-excursion (save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (re-search-forward vm-message-order-header-regexp lim t))))) (defun vm-startup-apply-message-order (order) (let (list-length v (mp vm-message-list)) (setq list-length (length vm-message-list) v (make-vector (max list-length (length order)) nil)) (while (and order mp) (condition-case nil (aset v (1- (car order)) (car mp)) (args-out-of-range nil)) (setq order (cdr order) mp (cdr mp))) ;; lock out interrupts while the message list is in ;; an inconsistent state. (let ((inhibit-quit t)) (setq vm-message-list (delq nil (append v mp)) vm-message-order-changed nil vm-message-order-header-present t vm-message-pointer (memq (car vm-message-pointer) vm-message-list)) (vm-set-numbering-redo-start-point t) (vm-reverse-link-messages)))) ;; Read the header that gives the folder's cached summary format ;; If the current summary format is different, then the cached ;; summary lines are discarded. (defun vm-gobble-summary () (let ((case-fold-search t) summary lim) (save-excursion (vm-save-restriction (widen) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-summary-header-regexp lim t) (let ((oldpoint (point))) (condition-case () (setq summary (read (current-buffer))) (error (vm-warn 1 1 "Bad summary header at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq summary ""))) (vm-startup-apply-summary summary))))))) (defun vm-startup-apply-summary (summary) (if (not (equal summary vm-summary-format)) (if vm-restore-saved-summary-formats (progn (make-local-variable 'vm-summary-format) (setq vm-summary-format summary)) (let ((mp vm-message-list)) (while mp (vm-set-summary-of (car mp) nil) ;; force restuffing of cache to clear old ;; summary entry cache. (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp))))))) ;; Add a X-VM-Storage header (defun vm-add-storage-header (mp &rest args) (save-excursion (let ((buffer-read-only nil) opoint) (goto-char (vm-headers-of (car mp))) (setq opoint (point)) (insert-before-markers vm-storage-header " (") (when args (insert-before-markers (format "%s" (car args)))) (setq args (cdr args)) (while args (insert-before-markers (format " %s" (car args))) (setq args (cdr args))) (insert-before-markers ")\n") (set-marker (vm-headers-of (car mp)) opoint)))) ;; This is now replaced by vm-mime-encode-words-in-cache-vector ;; ;; (defun vm-encode-words-in-cache-vector (list) ;; (vm-mapvector (lambda (e) ;; (if (stringp e) ;; (vm-mime-encode-words-in-string e) ;; e)) ;; list)) (defun vm-stuff-message-data (m &optional for-other-folder) "Stuff the attributes, labels, soft and cached data of the message M into the folder buffer. The optional argument FOR-OTHER-FOLDER indicates . USR 2010-03-06" (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (vm-mime-qp-encoder-program nil) ; use internal code (vm-mime-base64-encoder-program nil) ; for speed attributes cache (case-fold-search t) (buffer-read-only nil) ;; don't truncate the printing of large Lisp objects (print-length nil) opoint ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (delflag (vm-deleted-flag m))) (unwind-protect (progn ;; don't put this folder's summary entry into another folder. (if for-other-folder (vm-set-summary-of m nil) (if (vm-su-start-of m) ;; fill the summary cache if it's not done already. (vm-su-summary m))) (setq attributes (vm-attributes-of m) cache (vm-cached-data-of m)) (when (and delflag for-other-folder) (vm-set-deleted-flag-in-vector (setq attributes (copy-sequence attributes)) nil)) (when (eq vm-folder-type 'babyl) (vm-stuff-babyl-attributes m for-other-folder)) (when (eq vm-sync-thunderbird-status t) (vm-stuff-thunderbird-status m)) (goto-char (vm-headers-of m)) (while (re-search-forward vm-attributes-header-regexp (vm-text-of m) t) (delete-region (match-beginning 0) (match-end 0))) (goto-char (vm-headers-of m)) (setq opoint (point)) (insert ; insert-before-markers? vm-attributes-header " (" (let ((print-escape-newlines t)) (prin1-to-string attributes)) "\n\t" (let ((print-escape-newlines t)) (prin1-to-string (vm-mime-encode-words-in-cache-vector cache))) "\n\t" (let ((print-escape-newlines t)) (prin1-to-string (vm-labels-of m))) ")\n") (set-marker (vm-headers-of m) opoint) (cond ((and (eq vm-folder-type 'From_) vm-berkeley-mail-compatibility) (goto-char (vm-headers-of m)) (while (re-search-forward vm-berkeley-mail-status-header-regexp (vm-text-of m) t) (delete-region (match-beginning 0) (match-end 0))) (goto-char (vm-headers-of m)) (cond ((not (vm-new-flag m)) (insert-before-markers vm-berkeley-mail-status-header (if (vm-unread-flag m) "" "R") "O\n") (set-marker (vm-headers-of m) opoint))))) (if for-other-folder (vm-set-stuff-flag-of m nil) ; same effect as VM 7.19 (vm-set-stuff-flag-of m nil)) ; new ) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) (defun vm-stuff-folder-data (&optional abort-if-input-pending quiet) "Stuff the soft and cached data of all the messages that have the stuff-flag set in the current folder. USR 2010-04-20" (let ((newlist nil) mp len (n 0)) ;; stuff the attributes of messages that need it. ;; build a list of messages that need their attributes stuffed (setq mp vm-message-list) (while mp (if (vm-stuff-flag-of (car mp)) (setq newlist (cons (car mp) newlist))) (setq mp (cdr mp))) (when (and newlist (not quiet)) (setq len (length newlist)) (vm-inform 7 "%d message%s to stuff" len (if (= 1 len) "" "s"))) ;; now sort the list by physical order so that we ;; reduce the amount of gap motion induced by modifying ;; the buffer. what we want to avoid is updating ;; message 3, then 234, then 10, then 500, thus causing ;; large chunks of memory to be copied repeatedly as ;; the gap moves to accomodate the insertions. (if (not quiet) (vm-inform 6 "Ordering updates...")) (let ((vm-key-functions '(vm-sort-compare-physical-order-r))) (setq mp (sort newlist 'vm-sort-compare-xxxxxx))) (while (and mp (or (not abort-if-input-pending) (not (input-pending-p)))) (vm-stuff-message-data (car mp)) (setq n (1+ n)) (if (not quiet) (vm-inform 6 "Stuffing %d%% complete..." (* (/ (+ n 0.0) len) 100))) (setq mp (cdr mp))) (if mp nil t))) ;; we can be a bit lazy in this function since it's only called ;; from within vm-stuff-message-data. we don't worry about ;; restoring the modified flag, setting buffer-read-only, or ;; about not moving point. (defun vm-stuff-babyl-attributes (m for-other-folder) (goto-char (vm-start-of m)) (forward-char 2) (if (vm-babyl-frob-flag-of m) (insert "1") (insert "0")) (delete-char 1) (forward-char 1) (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+") (delete-region (match-beginning 0) (match-end 0))) (if (vm-new-flag m) (insert " recent, unseen,") (if (vm-unread-flag m) (insert " unseen,"))) (if (and (not for-other-folder) (vm-deleted-flag m)) (insert " deleted,")) (if (vm-replied-flag m) (insert " answered,")) (if (vm-forwarded-flag m) (insert " forwarded,")) (if (vm-redistributed-flag m) (insert " redistributed,")) (if (vm-filed-flag m) (insert " filed,")) (if (vm-edited-flag m) (insert " edited,")) (if (vm-written-flag m) (insert " written,")) (forward-char 1) (if (looking-at "\\( [^\000-\040,\177-\377]+,\\)+") (delete-region (match-beginning 0) (match-end 0))) (mapcar (function (lambda (label) (insert " " label ","))) (vm-labels-of m))) (defun vm-babyl-attributes-string (m for-other-folder) (concat (if (vm-new-flag m) " recent, unseen," (if (vm-unread-flag m) " unseen,")) (if (and (not for-other-folder) (vm-deleted-flag m)) " deleted,") (if (vm-replied-flag m) " answered,") (if (vm-forwarded-flag m) " forwarded,") (if (vm-redistributed-flag m) " redistributed,") (if (vm-filed-flag m) " filed,") (if (vm-edited-flag m) " edited,") (if (vm-written-flag m) " written,"))) (defun vm-babyl-labels-string (m) (let ((list nil) (labels (vm-labels-of m))) (while labels (setq list (cons "," (cons (car labels) (cons " " list))) labels (cdr labels))) (apply 'concat (nreverse list)))) (defun vm-stuff-virtual-message-data (message) (let ((virtual (vm-virtual-message-p message)) (real-m (vm-real-message-of message))) (if (or (not virtual) (and virtual (vm-virtual-messages-of message))) (with-current-buffer (vm-buffer-of real-m) (vm-stuff-message-data real-m))))) (defun vm-stuff-thunderbird-status (message) (let (status status2 status2-hi status2-lo) (setq status (vm-get-header-contents message "X-Mozilla-Status:")) (if (not status) (setq status 0) (setq status (string-to-number status 16)) ;; clear those bits we are using and keep others ... (setq status (logand status (lognot (logior #x1 #x2 #x4 #x8 #x1000)))) (goto-char (vm-headers-of message)) (if (re-search-forward "^X-Mozilla-Status: [ 0-9A-Fa-f]+\n" (vm-text-of message) t) (delete-region (match-beginning 0) (match-end 0)))) (setq status2 (vm-get-header-contents message "X-Mozilla-Status2:")) (if (not status2) (setq status2 0 status2-hi 0 status2-lo 0) (if (> (length status2) 4) (setq status2-hi (string-to-number (substring status2 0 -4) 16) status2-lo (string-to-number (substring status2 -4 nil) 16)) ;; handle badly fomatted status strings written by old ;; versions (setq status2 (string-to-number status2 16) status2-hi (/ status2 #x1000) status2-lo (mod status2 #x1000))) ;; clear those bits we are using and keep others ... (setq status2-hi (logand status2-hi (lognot (logior #x1)))) (goto-char (vm-headers-of message)) (if (re-search-forward "^X-Mozilla-Status2: [ 0-9A-Fa-f]+\n" (vm-text-of message) t) (delete-region (match-beginning 0) (match-end 0)))) (unless (vm-unread-flag message) (setq status (logior status #x1))) (when (vm-replied-flag message) (setq status (logior status #x2))) (when (vm-flagged-flag message) (setq status (logior status #x4))) (when (vm-deleted-flag message) (setq status (logior status #x8))) (when (vm-folded-flag message) (setq status (logior status #x0020))) (when (vm-watched-flag message) (setq status (logior status #x0100))) (when (vm-forwarded-flag message) (setq status (logior status #x1000))) (when (vm-new-flag message) (setq status2-hi (logior status2-hi #x0001))) (when (vm-ignored-flag message) (setq status2-hi (logior status2-hi #x0004))) (when (vm-read-receipt-flag message) (setq status2-hi (logior status2-hi #x0040))) (when (vm-read-receipt-sent-flag message) (setq status2-hi (logior status2-hi #x0080))) (when (vm-attachments-flag message) (setq status2-hi (logior status2-hi #x1000))) (goto-char (vm-headers-of message)) (insert (format "X-Mozilla-Status: %04x\n" status)) (insert (format "X-Mozilla-Status2: %04x%04x\n" status2-hi status2-lo)))) (defun vm-stuff-labels () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; don't truncate the printing of large Lisp objects (print-length nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) lim) (if (eq vm-folder-type 'babyl) (progn (goto-char (point-min)) (vm-skip-past-folder-header) (delete-region (point) (point-min)) (insert-before-markers (vm-folder-header vm-folder-type vm-label-obarray)))) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (while (re-search-forward vm-labels-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-labels-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the summary header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-labels-header " " (let ((print-escape-newlines t) (list nil)) (mapatoms (function (lambda (sym) (setq list (cons (symbol-name sym) list)))) vm-label-obarray) (prin1-to-string list)) "\n") (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) ;; Insert a bookmark into the first message in the folder. (defun vm-stuff-bookmark () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) lim) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-bookmark-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-bookmark-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the bookmark header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-bookmark-header " " (vm-number-of (car vm-message-pointer)) "\n") (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) (defun vm-stuff-last-modified () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) lim) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-last-modified-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-last-modified-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the last-modified header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-last-modified-header " " (prin1-to-string (current-time)) "\n") (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) (defun vm-stuff-pop-retrieved () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) (print-length nil) (p vm-pop-retrieved-messages) (curbuf (current-buffer)) lim) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-pop-retrieved-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-pop-retrieved-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the pop-retrieved header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-pop-retrieved-header) (if (null p) (insert " nil\n") (insert "\n (\n") (while p (insert "\t") (prin1 (car p) curbuf) (insert "\n") (setq p (cdr p))) (insert " )\n")) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) (defun vm-stuff-imap-retrieved () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) (print-length nil) (p vm-imap-retrieved-messages) (curbuf (current-buffer)) lim) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (if (re-search-forward vm-imap-retrieved-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-imap-retrieved-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the imap-retrieved header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-imap-retrieved-header) (if (null p) (insert " nil\n") (insert "\n (\n") (while p (insert "\t") (prin1 (car p) curbuf) (insert "\n") (setq p (cdr p))) (insert " )\n")) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) ;; Insert the summary format variable header into the first message. (defun vm-stuff-summary () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; don't truncate the printing of large Lisp objects (print-length nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil) lim) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (while (re-search-forward vm-summary-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-summary-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This will cause the summary header ;; to be visible if there are no non-visible headers, ;; oh well, no way around this. (insert vm-summary-header " " (let ((print-escape-newlines t)) (prin1-to-string vm-summary-format)) "\n") (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) ;; stuff the current values of the header variables for future messages. (defun vm-stuff-header-variables () (if vm-message-list (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) (print-escape-newlines t) lim ;; don't truncate the printing of large Lisp objects (print-length nil) (buffer-read-only nil) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (while (re-search-forward vm-vheader-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-vheader-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This header will be visible if there ;; are no non-visible headers, oh well, no way around this. (insert vm-vheader-header " " (prin1-to-string vm-visible-headers) " " (prin1-to-string vm-invisible-header-regexp) "\n") (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) ;; Insert a header into the first message of the folder that lists ;; the folder's message order. (defun vm-stuff-message-order () (if (cdr vm-message-list) (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) lim n (buffer-read-only nil) (mp (copy-sequence vm-message-list))) (setq mp (sort mp (function (lambda (p q) (< (vm-start-of p) (vm-start-of q)))))) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (while (re-search-forward vm-message-order-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-message-order-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) ;; To insert or to insert-before-markers, that is the question. ;; ;; If we insert-before-markers we push a header behind ;; vm-headers-of, which is clearly undesirable. So we ;; just insert. This header will be visible if there ;; are no non-visible headers, oh well, no way around this. (insert vm-message-order-header "\n\t(") (setq n 0) (while mp (insert (vm-number-of (car mp))) (setq n (1+ n) mp (cdr mp)) (and mp (insert (if (zerop (% n 15)) "\n\t " " ")))) (insert ")\n") (setq vm-message-order-changed nil vm-message-order-header-present t) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) ;; Remove the message order header. (defun vm-remove-message-order () (if (cdr vm-message-list) (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) (case-fold-search t) lim ;; This prevents file locking from occuring. Disabling ;; locking can speed things noticeably if the lock ;; directory is on a slow device. We don't need locking ;; here because the user shouldn't care about VM stuffing ;; its own status headers. (buffer-file-name nil) (buffer-read-only nil)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (search-forward "\n\n" nil t) (setq lim (point)) (goto-char (point-min)) (vm-skip-past-folder-header) (vm-skip-past-leading-message-separator) (while (re-search-forward vm-message-order-header-regexp lim t) (progn (goto-char (match-beginning 0)) (if (vm-match-header vm-message-order-header) (delete-region (vm-matched-header-start) (vm-matched-header-end))))) (setq vm-message-order-header-present nil) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))))))) (defun vm-make-index-file-name () (concat (file-name-directory buffer-file-name) "." (file-name-nondirectory buffer-file-name) vm-index-file-suffix)) (defun vm-read-index-file-maybe () (catch 'done (if (or (not (stringp buffer-file-name)) (not (stringp vm-index-file-suffix))) (throw 'done nil)) (let* ((index-file (vm-make-index-file-name)) (mtime-buffer (nth 5 (file-attributes buffer-file-name))) (mtime-index (nth 5 (file-attributes index-file)))) (if (and (file-readable-p index-file) (>= (car mtime-index) (car mtime-buffer)) (>= (car (cdr mtime-index)) (car (cdr mtime-buffer)))) (vm-read-index-file index-file) nil)))) (defun vm-read-index-file (index-file) (catch 'done (condition-case error-data (let ((work-buffer nil)) (unwind-protect (let (obj attr-list cache-list location-list label-list validity-check vis invis folder-type bookmark summary labels pop-retrieved imap-retrieved order v m (m-list nil) tail) (vm-inform 5 "Reading index file...") (setq work-buffer (vm-make-work-buffer)) (with-current-buffer work-buffer (insert-file-contents-literally index-file)) (goto-char (point-min)) ;; check version (setq obj (read work-buffer)) (if (not (eq obj 1)) (error "Unsupported index file version: %s" obj)) ;; folder type (setq folder-type (read work-buffer)) ;; validity check (setq validity-check (read work-buffer)) (if (null (vm-check-index-file-validity validity-check)) (throw 'done nil)) ;; bookmark (setq bookmark (read work-buffer)) ;; message order (setq order (read work-buffer)) ;; what summary format was used to produce the ;; folder's summary cache line. (setq summary (read work-buffer)) ;; folder-wide list of labels (setq labels (read work-buffer)) ;; what vm-visible-headers / vm-invisible-header-regexp ;; settings were used to order the headers and to ;; produce the vm-headers-regexp-of slot value. (setq vis (read work-buffer)) (setq invis (read work-buffer)) ;; location offsets ;; attributes list ;; cache list ;; label list (setq location-list (read work-buffer)) (setq attr-list (read work-buffer)) (setq cache-list (read work-buffer)) (setq label-list (read work-buffer)) (while location-list (setq v (car location-list) m (vm-make-message)) (if (null m-list) (setq m-list (list m) tail m-list) (setcdr tail (list m)) (setq tail (cdr tail))) (vm-set-start-of m (vm-marker (aref v 0))) (vm-set-headers-of m (vm-marker (aref v 1))) (vm-set-text-end-of m (vm-marker (aref v 2))) (vm-set-end-of m (vm-marker (aref v 3))) (if (null attr-list) (error "Attribute list is shorter than location list") (setq v (car attr-list)) (if (< (length v) vm-attributes-vector-length) (setq v (vm-extend-vector v vm-attributes-vector-length))) (vm-set-attributes-of m v)) (if (null cache-list) (error "Cache list is shorter than location list") (setq v (car cache-list)) (if (< (length v) vm-cached-data-vector-length) (setq v (vm-extend-vector v vm-cached-data-vector-length))) (vm-set-cached-data-of m v)) (if (null label-list) (error "Label list is shorter than location list") (vm-set-labels-of m (car label-list))) (setq location-list (cdr location-list) attr-list (cdr attr-list) cache-list (cdr cache-list) label-list (cdr label-list))) ;; pop retrieved messages (setq pop-retrieved (read work-buffer)) ;; imap retrieved messages (setq imap-retrieved (read work-buffer)) (setq vm-message-list m-list vm-folder-type folder-type vm-pop-retrieved-messages pop-retrieved vm-imap-retrieved-messages imap-retrieved) (vm-startup-apply-bookmark bookmark) (and order (vm-startup-apply-message-order order)) (if vm-summary-show-threads (progn ;; get numbering of new messages done now ;; so that the sort code only has to worry about the ;; changes it needs to make. (vm-update-summary-and-mode-line) (vm-sort-messages (or vm-ml-sort-keys "activity")))) (vm-startup-apply-summary summary) (vm-startup-apply-labels labels) (vm-startup-apply-header-variables vis invis) (vm-inform 5 "Reading index file... done") t ) (and work-buffer (kill-buffer work-buffer)))) (error (vm-warn 1 2 "Index file read of %s signaled: %s" index-file error-data) (vm-warn 1 2 "Ignoring index file..."))))) (defun vm-check-index-file-validity (blob) (save-excursion (widen) (catch 'done (cond ((not (consp blob)) (error "Validity check object not a cons: %s" blob)) ((eq (car blob) 'file) (let (ch time time2) (setq blob (cdr blob)) (setq time (car blob) time2 (vm-gobble-last-modified)) (if (and time2 (> 0 (vm-time-difference time time2))) (throw 'done nil)) (setq blob (cdr blob)) (while blob (setq ch (char-after (car blob))) (if (or (null ch) (not (eq (vm-char-to-int ch) (nth 1 blob)))) (throw 'done nil)) (setq blob (cdr (cdr blob))))) t ) (t (error "Unknown validity check type: %s" (car blob))))))) (defun vm-generate-index-file-validity-check () (save-restriction (widen) (let ((step (max 1 (/ (point-max) 11))) (pos (1- (point-max))) (lim (point-min)) (blob nil)) (while (>= pos lim) (setq blob (cons pos (cons (vm-char-to-int (char-after pos)) blob)) pos (- pos step))) (cons 'file (cons (current-time) blob))))) (defun vm-write-index-file-maybe () (catch 'done (if (not (stringp buffer-file-name)) (throw 'done nil)) (if (not (stringp vm-index-file-suffix)) (throw 'done nil)) (let ((index-file (vm-make-index-file-name))) (vm-write-index-file index-file)))) (defun vm-write-index-file (index-file) (let ((work-buffer nil)) (unwind-protect (let ((print-escape-newlines t) (print-length nil) m-list mp m) (vm-inform 6 "Sorting for index file...") (setq m-list (sort (copy-sequence vm-message-list) (function vm-sort-compare-physical-order))) (vm-inform 6 "Stuffing index file...") (setq work-buffer (vm-make-work-buffer)) (princ ";; index file version\n" work-buffer) (prin1 1 work-buffer) (terpri work-buffer) (princ ";; folder type\n" work-buffer) (prin1 vm-folder-type work-buffer) (terpri work-buffer) (princ ";; timestamp + sample of folder bytes for consistency check\n" work-buffer) (prin1 (vm-generate-index-file-validity-check) work-buffer) (terpri work-buffer) (princ ";; bookmark\n" work-buffer) (princ (if vm-message-pointer (vm-number-of (car vm-message-pointer)) "1") work-buffer) (terpri work-buffer) (princ ";; message order\n" work-buffer) (let ((n 0) (mp vm-message-list)) (princ "(" work-buffer) (setq n 0) (while mp (if (zerop (% n 15)) (princ "\n\t" work-buffer) (princ " " work-buffer)) (princ (vm-number-of (car mp)) work-buffer) (setq n (1+ n) mp (cdr mp))) (princ "\n)\n" work-buffer)) (princ ";; summary\n" work-buffer) (prin1 vm-summary-format work-buffer) (terpri work-buffer) (princ ";; labels used in this folder\n" work-buffer) (let ((list nil)) (mapatoms (function (lambda (sym) (setq list (cons (symbol-name sym) list)))) vm-label-obarray) (prin1 list work-buffer)) (terpri work-buffer) (princ ";; visible headers\n" work-buffer) (prin1 vm-visible-headers work-buffer) (terpri work-buffer) (princ ";; hidden headers\n" work-buffer) (prin1 vm-invisible-header-regexp work-buffer) (terpri work-buffer) (princ ";; location list\n" work-buffer) (princ "(\n" work-buffer) (setq mp m-list) (while mp (setq m (car mp)) (princ " [" work-buffer) (prin1 (marker-position (vm-start-of m)) work-buffer) (princ " " work-buffer) (prin1 (marker-position (vm-headers-of m)) work-buffer) (princ " " work-buffer) (prin1 (marker-position (vm-text-end-of m)) work-buffer) (princ " " work-buffer) (prin1 (marker-position (vm-end-of m)) work-buffer) (princ "]\n" work-buffer) (setq mp (cdr mp))) (princ ")\n" work-buffer) (princ ";; attribute list\n" work-buffer) (princ "(\n" work-buffer) (setq mp m-list) (while mp (setq m (car mp)) (princ " " work-buffer) (prin1 (vm-attributes-of m) work-buffer) (princ "\n" work-buffer) (setq mp (cdr mp))) (princ ")\n" work-buffer) (princ ";; cache list\n" work-buffer) (princ "(\n" work-buffer) (setq mp m-list) (while mp (setq m (car mp)) (princ " " work-buffer) (prin1 (vm-cached-data-of m) work-buffer) (princ "\n" work-buffer) (setq mp (cdr mp))) (princ ")\n" work-buffer) (princ ";; labels list\n" work-buffer) (princ "(\n" work-buffer) (setq mp m-list) (while mp (setq m (car mp)) (princ " " work-buffer) (prin1 (vm-labels-of m) work-buffer) (princ "\n" work-buffer) (setq mp (cdr mp))) (princ ")\n" work-buffer) (princ ";; retrieved POP messages\n" work-buffer) (let ((p vm-pop-retrieved-messages)) (if (null p) (princ "nil\n" work-buffer) (princ "(\n" work-buffer) (while p (princ "\t" work-buffer) (prin1 (car p) work-buffer) (princ "\n" work-buffer) (setq p (cdr p))) (princ ")\n" work-buffer))) (princ ";; retrieved IMAP messages\n" work-buffer) (let ((p vm-imap-retrieved-messages)) (if (null p) (princ "nil\n" work-buffer) (princ "(\n" work-buffer) (while p (princ "\t" work-buffer) (prin1 (car p) work-buffer) (princ "\n" work-buffer) (setq p (cdr p))) (princ ")\n" work-buffer))) (princ ";; end of index file\n" work-buffer) (vm-inform 6 "Writing index file...") (catch 'done (with-current-buffer work-buffer (condition-case data (let ((coding-system-for-write (vm-binary-coding-system)) (selective-display nil)) (write-region (point-min) (point-max) index-file)) (error (vm-warn 1 2 "Write of %s signaled: %s" index-file data) (throw 'done nil)))) (vm-error-free-call 'set-file-modes index-file (vm-octal 600)) (vm-inform 6 "Writing index file... done") t )) (and work-buffer (kill-buffer work-buffer))))) (defun vm-delete-index-file () (if (stringp vm-index-file-suffix) (let ((index-file (vm-make-index-file-name))) (vm-error-free-call 'delete-file index-file)))) (defun vm-change-all-new-to-unread () (let ((mp vm-message-list)) (while mp (if (vm-new-flag (car mp)) (progn (vm-set-new-flag (car mp) nil) (vm-set-unread-flag (car mp) t))) (setq mp (cdr mp))))) ;;;###autoload (defun vm-mark-message-unread (&optional count) "Mark the current message as unread. If the message is already new or unread, then it is left unchanged. Numeric prefix argument N means to mark the current message plus the next N-1 messages as unread. A negative N means mark the current message and the previous N-1 messages as unread. When invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages are affected, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are affected." (interactive "p") (or count (setq count 1)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Unread"))) (while mlist (if (and (not (vm-unread-flag (car mlist))) (not (vm-new-flag (car mlist)))) (vm-set-unread-flag (car mlist) t)) (setq mlist (cdr mlist)))) (vm-display nil nil '(vm-mark-message-unread) '(vm-mark-message-unread)) (vm-update-summary-and-mode-line)) (defalias 'vm-unread-message 'vm-mark-message-unread) (defalias 'vm-flag-message-unread 'vm-mark-message-unread) (make-obsolete 'vm-flag-message-unread 'vm-mark-message-unread "8.2.0") ;;;###autoload (defun vm-mark-message-read (&optional count) "Mark the current message as read, i.e., set the `unread' and `new' attributes to nil. If the message is already marked as read, then it is left unchanged. Numeric prefix argument N means to unread the current message plus the next N-1 messages. A negative N means mark the current message and the previous N-1 messages as read. When invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages are affected, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are affected." (interactive "p") (or count (setq count 1)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Mark as read"))) (while mlist (when (or (vm-unread-flag (car mlist)) (vm-new-flag (car mlist))) (vm-set-unread-flag (car mlist) nil) (vm-set-new-flag (car mlist) nil)) (setq mlist (cdr mlist)))) (vm-display nil nil '(vm-mark-message-read) '(vm-mark-message-read)) (vm-update-summary-and-mode-line)) (defalias 'vm-flag-message-read 'vm-mark-message-read) (make-obsolete 'vm-flag-message-read 'vm-mark-message-read "8.2.0") ;;;###autoload (defun vm-quit-just-bury () "Bury the current VM folder and summary buffers. The folder is not altered and Emacs is still visiting it. You can switch back to it with switch-to-buffer or by using the Buffer Menu." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (save-excursion (run-hooks 'vm-quit-hook)) (vm-garbage-collect-message) (vm-display nil nil '(vm-quit-just-bury) '(vm-quit-just-bury quitting)) (if vm-summary-buffer (vm-display vm-summary-buffer nil nil nil)) (if vm-summary-buffer (vm-bury-buffer vm-summary-buffer)) (if vm-presentation-buffer-handle (vm-display vm-presentation-buffer-handle nil nil nil)) (if vm-presentation-buffer-handle (vm-bury-buffer vm-presentation-buffer-handle)) (vm-display (current-buffer) nil nil nil) (vm-bury-buffer (current-buffer))) ;;;###autoload (defun vm-quit-just-iconify () "Iconify the frame and bury the current VM folder and summary buffers. The folder is not altered and Emacs is still visiting it." (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (save-excursion (run-hooks 'vm-quit-hook)) (vm-garbage-collect-message) (vm-display nil nil '(vm-quit-just-iconify) '(vm-quit-just-iconify quitting)) (let ((summary-buffer vm-summary-buffer) (pres-buffer vm-presentation-buffer-handle)) (vm-bury-buffer (current-buffer)) (if summary-buffer (vm-bury-buffer summary-buffer)) (if pres-buffer (vm-bury-buffer pres-buffer)) (vm-iconify-frame))) ;;;###autoload (defun vm-quit-no-change () "Quit visiting the current folder without saving changes made to the folder." (interactive) (vm-quit t t)) ;;;###autoload (defun vm-quit-no-expunge () "Quit visiting the current folder without expunging deleted messages. The setting of `vm-expunge-before-quit' is ignored." (interactive) (vm-quit t nil)) (defvar dired-listing-switches) ; defined only in FSF Emacs? ;;;###autoload (defun vm-quit (&optional no-expunge no-change) "Quit visiting the current folder, saving changes. If the customization variable `vm-expunge-before-quit' is set to non-nil value then deleted messages are expunged. Giving a prefix argument overrides the variable and no expunge is done." (interactive "P") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-display nil nil '(vm-quit vm-quit-no-change vm-quit-no-expunge) (list this-command 'quitting)) (let ((virtual (eq major-mode 'vm-virtual-mode)) (process nil)) (cond ((and (not virtual) no-change (buffer-modified-p) (or buffer-file-name buffer-offer-save) (not (zerop vm-messages-not-on-disk)) ;; Folder may have been saved with C-x C-s and attributes may have ;; been changed after that; in that case vm-messages-not-on-disk ;; would not have been zeroed. However, all modification flag ;; undos are cleared if VM actually modifies the folder buffer ;; (as opposed to the folder's attributes), so this can be used ;; to verify that there are indeed unsaved messages. (null (assq 'vm-set-buffer-modified-p vm-undo-record-list)) (not (y-or-n-p (format "%d message%s have not been saved to disk, quit anyway? " vm-messages-not-on-disk (if (= 1 vm-messages-not-on-disk) "" "s"))))) (error "Aborted")) ((and (not virtual) no-change (or buffer-file-name buffer-offer-save) (buffer-modified-p) vm-confirm-quit (not (y-or-n-p "There are unsaved changes, quit anyway? "))) (error "Aborted")) ((and (eq vm-confirm-quit t) (not (y-or-n-p "Do you really want to quit? "))) (error "Aborted"))) (save-excursion (run-hooks 'vm-quit-hook)) (when (and vm-expunge-before-quit (not no-expunge) (not no-change) (buffer-modified-p)) (vm-expunge-folder)) (vm-garbage-collect-message) (vm-garbage-collect-folder) (unless (or no-change virtual) ;; this could take a while, so give the user some feedback (vm-inform 5 "Quitting...") (unless (or vm-folder-read-only (eq major-mode 'vm-virtual-mode)) (vm-change-all-new-to-unread))) (when (and (buffer-modified-p) (or buffer-file-name buffer-offer-save) (not no-change) (not virtual)) (vm-save-folder)) (vm-virtual-quit no-expunge no-change) (cond ((and (eq vm-folder-access-method 'pop) (setq process (vm-folder-pop-process))) (vm-pop-end-session process)) ((and (eq vm-folder-access-method 'imap) (setq process (vm-folder-imap-process))) (vm-imap-end-session process)) ) (message "") ; why this? USR, 2010-05-03 (let ((summary-buffer vm-summary-buffer) (pres-buffer vm-presentation-buffer-handle) (mail-buffer (current-buffer))) (if summary-buffer (progn (vm-display summary-buffer nil nil nil) (kill-buffer summary-buffer))) (if pres-buffer (progn (vm-display pres-buffer nil nil nil) (kill-buffer pres-buffer))) (set-buffer mail-buffer) (vm-display mail-buffer nil nil nil) ;; vm-display is not supposed to change the current buffer. ;; still it's better to be safe here. (set-buffer mail-buffer) ;; if folder is selected in the folders summary, force ;; selcetion of some other folder. (if buffer-file-name (vm-mark-for-folders-summary-update buffer-file-name)) (vm-delete-auto-save-file-if-necessary) ;; this is a hack to suppress another confirmation dialogue ;; coming from kill-buffer (set-buffer-modified-p nil) ; folder buffer (kill-buffer (current-buffer))) (vm-update-summary-and-mode-line))) (defun vm-start-itimers-if-needed () (cond ((and (not (natnump vm-flush-interval)) (not (natnump vm-auto-get-new-mail)) (not (natnump vm-mail-check-interval)))) ((condition-case data (progn (require 'itimer) t) (error nil)) (when (and (natnump vm-flush-interval) (not (get-itimer "vm-flush"))) ;; name function time restart-time ;; ...... idle with-args args (start-itimer "vm-flush" 'vm-flush-itimer-function vm-flush-interval nil)) (when (and (natnump vm-auto-get-new-mail) (not (get-itimer "vm-get-mail"))) (start-itimer "vm-get-mail" 'vm-get-mail-itimer-function vm-auto-get-new-mail nil)) (when (and (natnump vm-mail-check-interval) (not (get-itimer "vm-check-mail"))) (start-itimer "vm-check-mail" 'vm-check-mail-itimer-function vm-mail-check-interval nil))) ((condition-case data (progn (require 'timer) t) (error nil)) (let (timer) (when (and (natnump vm-flush-interval) (not (vm-timer-using 'vm-flush-itimer-function)) (setq timer ;; time restart-time function args (run-at-time vm-flush-interval vm-flush-interval 'vm-flush-itimer-function nil))) (timer-set-function timer 'vm-flush-itimer-function (list timer))) (when (and (natnump vm-mail-check-interval) (not (vm-timer-using 'vm-check-mail-itimer-function)) (setq timer (run-at-time vm-mail-check-interval vm-mail-check-interval 'vm-check-mail-itimer-function nil))) (timer-set-function timer 'vm-check-mail-itimer-function (list timer))) (when (and (natnump vm-auto-get-new-mail) (not (vm-timer-using 'vm-get-mail-itimer-function)) (setq timer (run-at-time vm-auto-get-new-mail vm-auto-get-new-mail 'vm-get-mail-itimer-function nil))) (timer-set-function timer 'vm-get-mail-itimer-function (list timer))))) (t (setq vm-flush-interval t vm-auto-get-new-mail t)))) (defvar timer-list) (defun vm-timer-using (fun) (let ((p timer-list) (done nil)) (while (and p (not done)) (if (eq (aref (car p) 5) fun) (setq done t) (setq p (cdr p)))) p )) (defvar current-itimer) ;; support for vm-mail-check-interval ;; if timer argument is present, this means we're using the Emacs ;; 'timer package rather than the 'itimer package. (defun vm-check-mail-itimer-function (&optional timer) ;; FSF Emacs sets this non-nil, which means the user can't ;; interrupt the check. Bogus. (setq inhibit-quit nil) (if (integerp vm-mail-check-interval) (if timer (timer-set-time timer (timer-relative-time (current-time) vm-mail-check-interval) vm-mail-check-interval) (set-itimer-restart current-itimer vm-mail-check-interval)) ;; user has changed the variable value to something that ;; isn't a number, make the timer go away. (if timer (cancel-timer timer) (set-itimer-restart current-itimer nil))) (let ((b-list (buffer-list)) (found-one nil) oldval) (save-excursion (while (and (not (input-pending-p)) b-list) (when (buffer-live-p (car b-list)) (set-buffer (car b-list)) (when (and (eq major-mode 'vm-mode) (setq found-one t) (or (not vm-spooled-mail-waiting) vm-mail-check-always) ;; to avoid reentrance into the pop and imap code (not vm-global-block-new-mail)) (setq oldval vm-spooled-mail-waiting) (setq vm-spooled-mail-waiting (vm-check-for-spooled-mail nil t)) (unless (eq oldval vm-spooled-mail-waiting) (intern (buffer-name) vm-buffers-needing-display-update) (run-hooks 'vm-spooled-mail-waiting-hook)))) (setq b-list (cdr b-list)))) (vm-update-summary-and-mode-line) ;; make the timer go away if we didn't encounter a vm-mode buffer. (when (and (not found-one) (null b-list)) (if timer (cancel-timer timer) (set-itimer-restart current-itimer nil))))) ;; support for numeric vm-auto-get-new-mail ;; if timer argument is present, this means we're using the Emacs ;; 'timer package rather than the 'itimer package. (defun vm-get-mail-itimer-function (&optional timer) ;; FSF Emacs sets this non-nil, which means the user can't ;; interrupt mail retrieval. Bogus. (setq inhibit-quit nil) (if (integerp vm-auto-get-new-mail) (if timer (timer-set-time timer (timer-relative-time (current-time) vm-auto-get-new-mail) vm-auto-get-new-mail) (set-itimer-restart current-itimer vm-auto-get-new-mail)) ;; user has changed the variable value to something that ;; isn't a number, make the timer go away. (if timer (cancel-timer timer) (set-itimer-restart current-itimer nil))) (let ((b-list (buffer-list)) (found-one nil)) (while (and (not (input-pending-p)) b-list) (save-excursion (when (buffer-live-p (car b-list)) (set-buffer (car b-list)) (when (and (eq major-mode 'vm-mode) (setq found-one t) (not vm-global-block-new-mail) (not vm-block-new-mail) (not vm-folder-read-only) (not (and (not (buffer-modified-p)) buffer-file-name (file-newer-than-file-p (make-auto-save-file-name) buffer-file-name))) (vm-get-spooled-mail nil)) ;; don't move the message pointer unless the folder ;; was empty. (if (and (null vm-message-pointer) (vm-thoughtfully-select-message)) (vm-present-current-message) (vm-update-summary-and-mode-line))))) (setq b-list (cdr b-list))) ;; make the timer go away if we didn't encounter a vm-mode buffer. (when (and (not found-one) (null b-list)) (if timer (cancel-timer timer) (set-itimer-restart current-itimer nil))))) ;; support for numeric vm-flush-interval ;; if timer argument is present, this means we're using the Emacs ;; 'timer package rather than the 'itimer package. (defun vm-flush-itimer-function (&optional timer) (when (integerp vm-flush-interval) (if timer (timer-set-time timer (timer-relative-time (current-time) vm-flush-interval) vm-flush-interval) (set-itimer-restart current-itimer vm-flush-interval))) ;; if no vm-mode buffers are found, we might as well shut down the ;; flush itimer. (unless (vm-flush-cached-data) (if timer (cancel-timer timer) (set-itimer-restart current-itimer nil)))) ;; flush cached data in all vm-mode buffers. ;; returns non-nil if any vm-mode buffers were found. (defun vm-flush-cached-data () (save-excursion (let ((buf-list (buffer-list)) (found-one nil)) (while (and buf-list (not (input-pending-p))) (if (not (buffer-live-p (car buf-list))) nil (set-buffer (car buf-list)) (cond ((and (eq major-mode 'vm-mode) vm-message-list) (setq found-one t) (if (not (eq vm-modification-counter vm-flushed-modification-counter)) (progn (vm-stuff-last-modified) (vm-stuff-pop-retrieved) (vm-stuff-imap-retrieved) (vm-stuff-summary) (vm-stuff-labels) (and vm-message-order-changed (vm-stuff-message-order)) (and (vm-stuff-folder-data t t) (setq vm-flushed-modification-counter vm-modification-counter))))))) (setq buf-list (cdr buf-list))) ;; if we haven't checked them all return non-nil so ;; the flusher won't give up trying. (or buf-list found-one) ))) ;; This allows C-x C-s to do the right thing for VM mail buffers. ;; Note that deleted messages are not expunged. (defun vm-write-file-hook () (if (and (eq major-mode 'vm-mode) (not vm-inhibit-write-file-hook)) ;; The vm-save-restriction isn't really necessary here, since ;; the stuff routines clean up after themselves, but should remain ;; as a safeguard against the time when other stuff is added here. (vm-save-restriction (let ((buffer-read-only)) (vm-discard-fetched-messages) (vm-inform 6 "Stuffing cached data...") (vm-stuff-folder-data nil) (vm-inform 6 "Stuffing cached data... done") (if vm-message-list (progn (if (and vm-folders-summary-database buffer-file-name) (progn (vm-compute-totals) (vm-store-folder-totals buffer-file-name (cdr vm-totals)))) ;; get summary cache up-to-date (vm-inform 6 "Stuffing folder data...") (vm-update-summary-and-mode-line) (vm-stuff-bookmark) (vm-stuff-pop-retrieved) (vm-stuff-imap-retrieved) (vm-stuff-last-modified) (vm-stuff-header-variables) (vm-stuff-labels) (vm-stuff-summary) (and vm-message-order-changed (vm-stuff-message-order)) (vm-inform 6 "Stuffing folder data... done"))) nil )))) ;;;###autoload (defun vm-save-buffer (prefix) ;; This function hasn't been documented. Not clear why it is ;; different from vm-save-folder. USR, 2011-04-27 (interactive "P") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-virtual-folder) (save-buffer prefix) (intern (buffer-name) vm-buffers-needing-display-update) (setq vm-block-new-mail nil) (vm-display nil nil '(vm-save-buffer) '(vm-save-buffer)) (if (and vm-folders-summary-database buffer-file-name) (progn (vm-compute-totals) (vm-store-folder-totals buffer-file-name (cdr vm-totals)))) (vm-update-summary-and-mode-line) (vm-write-index-file-maybe)) ;;;###autoload (defun vm-write-file () ;; This function hasn't been documented. Not clear what it does. ;; USR, 2011-04-27 (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-virtual-folder) (let ((old-buffer-name (buffer-name)) (oldmodebits (and (fboundp 'default-file-modes) (default-file-modes)))) (unwind-protect (save-excursion (and oldmodebits (set-default-file-modes vm-default-folder-permission-bits)) (call-interactively 'write-file)) (and oldmodebits (set-default-file-modes oldmodebits))) (if (and vm-folders-summary-database buffer-file-name) (progn (vm-compute-totals) (vm-store-folder-totals buffer-file-name (cdr vm-totals)))) (if (not (equal (buffer-name) old-buffer-name)) (progn (vm-check-for-killed-summary) (if vm-summary-buffer (save-excursion (let ((name (buffer-name))) (set-buffer vm-summary-buffer) (rename-buffer (format "%s Summary" name) t)))) (vm-check-for-killed-presentation) (if vm-presentation-buffer-handle (save-excursion (let ((name (buffer-name))) (set-buffer vm-presentation-buffer-handle) (rename-buffer (format "%s Presentation" name) t))))))) (intern (buffer-name) vm-buffers-needing-display-update) (setq vm-block-new-mail nil) (vm-display nil nil '(vm-write-file) '(vm-write-file)) (vm-update-summary-and-mode-line) (vm-write-index-file-maybe)) (defun vm-unblock-new-mail () (setq vm-block-new-mail nil)) ;;;###autoload (defun vm-save-folder-no-expunge (&optional prefix) "Save current folder to disk. Prefix arg is handled the same as for the command `save-buffer'. Deleted messages are _not_ expunged irrespective of the variable `vm-expunge-before-save'. When applied to a virtual folder, this command runs itself on each of the underlying real folders associated with the virtual folder." (interactive (list current-prefix-arg)) (let ((vm-expunge-before-save nil)) (vm-save-folder prefix))) ;;;###autoload (defun vm-save-folder (&optional prefix) "Save current folder to disk. Prefix arg is handled the same as for the command `save-buffer'. If the customization variable `vm-expunge-before-save' is set to non-nil value then deleted messages are expunged. When applied to a virtual folder, this command runs itself on each of the underlying real folders associated with the virtual folder." (interactive (list current-prefix-arg)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-save-folder) '(vm-save-folder)) (if (eq major-mode 'vm-virtual-mode) (vm-virtual-save-folder prefix) (if (buffer-modified-p) (let (mp (newlist nil) (buffer-undo-list t)) (when vm-expunge-before-save (vm-expunge-folder)) (cond ((eq vm-folder-access-method 'pop) (vm-pop-synchronize-folder :interactive t :do-remote-expunges t :do-local-expunges t :do-retrieves nil)) ((eq vm-folder-access-method 'imap) (vm-imap-synchronize-folder :interactive t :do-remote-expunges t :do-local-expunges t :do-retrieves nil :save-attributes t))) (vm-discard-fetched-messages) ;; remove the message summary file of Thunderbird and force ;; it to rebuild it. Expect error if Thunderbird is active. (let ((msf (concat buffer-file-name ".msf"))) (if (and (eq vm-sync-thunderbird-status t) (file-exists-p msf)) (delete-file msf))) ;; stuff the attributes of messages that need it. (vm-inform 6 "Stuffing cached data...") (vm-stuff-folder-data nil) (vm-inform 6 "Stuffing cached data... done") ;; stuff bookmark and header variable values (if vm-message-list (progn ;; get summary cache up-to-date (vm-inform 6 "Stuffing folder data...") (vm-update-summary-and-mode-line) (vm-stuff-bookmark) (vm-stuff-pop-retrieved) (vm-stuff-imap-retrieved) (vm-stuff-last-modified) (vm-stuff-header-variables) (vm-stuff-labels) (vm-stuff-summary) (and vm-message-order-changed (vm-stuff-message-order)) (vm-inform 6 "Stuffing folder data... done"))) (vm-inform 5 "Saving folder %s..." (buffer-name)) (let ((vm-inhibit-write-file-hook t) (oldmodebits (and (fboundp 'default-file-modes) (default-file-modes)))) (unwind-protect (progn (and oldmodebits (set-default-file-modes vm-default-folder-permission-bits)) (save-buffer prefix)) (and oldmodebits (set-default-file-modes oldmodebits)))) (vm-unmark-folder-modified-p (current-buffer)) ; folder buffer ;; clear the modified flag in virtual folders if all the ;; real buffers associated with them are unmodified. (let ((b-list vm-virtual-buffers) rb-list one-modified) (save-excursion (while b-list (if (null (cdr (with-current-buffer (car b-list) vm-real-buffers))) (vm-unmark-folder-modified-p (car b-list)) (set-buffer (car b-list)) (setq rb-list vm-real-buffers one-modified nil) (while rb-list (if (buffer-modified-p (car rb-list)) (setq one-modified t rb-list nil) (setq rb-list (cdr rb-list)))) (if (not one-modified) (vm-unmark-folder-modified-p (car b-list)))) (setq b-list (cdr b-list))))) (vm-clear-modification-flag-undos) (setq vm-messages-not-on-disk 0) (setq vm-block-new-mail nil) (vm-write-index-file-maybe) (if (and vm-folders-summary-database buffer-file-name) (progn (vm-compute-totals) (vm-store-folder-totals buffer-file-name (cdr vm-totals)))) (vm-update-summary-and-mode-line) (and (zerop (buffer-size)) vm-delete-empty-folders buffer-file-name (or (eq vm-delete-empty-folders t) (y-or-n-p (format "%s is empty, remove it? " (or buffer-file-name (buffer-name))))) (condition-case () (progn (delete-file buffer-file-name) (vm-delete-index-file) (clear-visited-file-modtime) (vm-inform 5 "%s removed" buffer-file-name)) ;; no can do, oh well. (error nil))) ) (vm-inform 5 "No changes need to be saved")))) ;;;###autoload (defun vm-save-and-expunge-folder (&optional prefix) "Expunge folder, then save it to disk. Prefix arg is handled the same as for the command save-buffer. Expunge won't be done if folder is read-only. When applied to a virtual folder, this command works as if you had run vm-expunge-folder followed by vm-save-folder." (interactive (list current-prefix-arg)) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-display nil nil '(vm-save-and-expunge-folder) '(vm-save-and-expunge-folder)) (if (not vm-folder-read-only) (progn (vm-inform 6 "Expunging...") (vm-expunge-folder :quiet t))) (vm-save-folder prefix)) ;;;###autoload (defun vm-read-folder (folder &optional remote-spec folder-name) "Reads the FOLDER from the file system and creates a buffer. Returns the buffer created. Optional argument REMOTE-SPEC gives the maildrop specification for the server folder that the FOLDER might be caching. Optional argument FOLDER-NAME gives the name of the folder that should be used as the name of the buffer." (let ((file (or folder (expand-file-name vm-primary-inbox vm-folder-directory)))) (if (file-directory-p file) ;; MH code perhaps... ? (error "%s is a directory" file) (or (vm-get-file-buffer file) (let ((default-directory (or (and vm-folder-directory (expand-file-name vm-folder-directory)) default-directory)) (inhibit-local-variables t) (enable-local-variables nil) (enable-local-eval nil) ;; for Emacs/MULE ;; disabled because Emacs 23 doesn't like it, and it ;; is not clear if it does anything at all. USR, 2010-07-10. ;; The only place this function is called from is vm, ;; which takes care of multibyte issues. TX, 2010-07-03 ;; (default-enable-multibyte-characters nil) ;; for XEmacs/Mule (coding-system-for-read (vm-line-ending-coding-system))) (vm-inform 5 "Reading folder %s..." (or folder-name file)) (let ((buffer (find-file-noselect file t)) (hist-item (or remote-spec folder vm-primary-inbox))) (when folder-name (with-current-buffer buffer (rename-buffer folder-name t))) ;; update folder history (if (not (equal hist-item (car vm-folder-history))) (setq vm-folder-history (cons hist-item vm-folder-history))) (vm-inform 5 "Reading folder %s... done" (or folder-name file)) buffer)))))) ;;;###autoload (defun vm-revert-buffer () "Revert the current folder to its version on the disk. Same as \\[vm-revert-folder]." (interactive) (vm-select-folder-buffer-if-possible) (let ((access-method vm-folder-access-method) ; preserve these across (access-data vm-folder-access-data) ; the revert-buffer opn (summary-buffer vm-summary-buffer) (pres-buffer vm-presentation-buffer-handle)) (if summary-buffer (progn (vm-display summary-buffer nil nil nil) (kill-buffer summary-buffer))) (if pres-buffer (progn (vm-display pres-buffer nil nil nil) (kill-buffer pres-buffer))) (call-interactively 'revert-buffer) (setq vm-folder-access-data access-data) ; restore preserved data (setq vm-folder-access-method access-method) (vm (current-buffer) :access-method access-method :reload 'reload))) (defalias 'vm-revert-folder 'vm-revert-buffer) ;;;###autoload (defun vm-recover-file () "Recover the autosave file for the current folder. Same as \\[vm-recover-folder]." (interactive) (vm-select-folder-buffer-if-possible) (let ((access-method vm-folder-access-method) ; preserve these across (access-data vm-folder-access-data) ; the recover-file opn. (summary-buffer vm-summary-buffer) (pres-buffer vm-presentation-buffer-handle)) (if summary-buffer (progn (vm-display summary-buffer nil nil nil) (kill-buffer summary-buffer))) (if pres-buffer (progn (vm-display pres-buffer nil nil nil) (kill-buffer pres-buffer))) (call-interactively 'recover-file) (setq vm-folder-access-method access-method) (setq vm-folder-access-data access-data) ; restore data (vm (current-buffer) :access-method access-method :reload 'reload))) (defalias 'vm-recover-folder 'vm-recover-file) ;; It doesn't seem that any of these recover/reversion handlers are ;; working any more. Not on GNU Emacs. USR, 2010-01-23 (defun vm-handle-file-recovery-or-reversion (recovery) (if (and vm-summary-buffer (buffer-name vm-summary-buffer)) (kill-buffer vm-summary-buffer)) (vm-virtual-quit) ;; reset major mode, this will cause vm to start from scratch. (setq major-mode 'fundamental-mode) ;; If this is a recovery, we can't allow the user to get new ;; mail until a real save is performed. Until then the buffer ;; and the disk don't match. (if recovery (setq vm-block-new-mail t)) (let ((name (cond ((eq vm-folder-access-method 'pop) (vm-pop-find-name-for-buffer (current-buffer))) ((eq vm-folder-access-method 'imap) (vm-imap-find-spec-for-buffer (current-buffer)))))) (vm (or name buffer-file-name) :access-method vm-folder-access-method))) ;; detect if a recover-file is being performed ;; and handle things properly. (defun vm-handle-file-recovery () (if (and (buffer-modified-p) (eq major-mode 'vm-mode) (or (null vm-message-list) (= (vm-end-of (car vm-message-list)) 1))) (vm-handle-file-recovery-or-reversion t))) ;; detect if a revert-buffer is being performed ;; and handle things properly. (defun vm-handle-file-reversion () (if (and (not (buffer-modified-p)) (eq major-mode 'vm-mode) (or (null vm-message-list) (= (vm-end-of (car vm-message-list)) 1))) (vm-handle-file-recovery-or-reversion nil))) ;; FSF v19.23 revert-buffer doesn't mash all the markers together ;; like v18 and prior v19 versions, so the check in ;; vm-handle-file-reversion doesn't work. However v19.23 has a ;; hook we can use, after-revert-hook. (defun vm-after-revert-buffer-hook () (if (eq major-mode 'vm-mode) (vm-handle-file-recovery-or-reversion nil))) ;;;###autoload (defun vm-help () "Display help for various VM activities." (interactive) (if (eq major-mode 'vm-summary-mode) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p))) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-window-configuration t))) (pop-up-frames (and vm-mutable-frame-configuration vm-frame-per-help))) (cond ((eq last-command 'vm-help) (describe-function major-mode)) ((eq vm-system-state 'previewing) (vm-inform 0 "Type SPC to read message, n previews next message (? gives more help)")) ((memq vm-system-state '(showing reading)) (vm-inform 0 "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply (? gives more help)")) ((eq vm-system-state 'editing) (vm-inform 0 (substitute-command-keys "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change."))) ((eq major-mode 'mail-mode) (vm-inform 0 (substitute-command-keys "Type \\[vm-mail-send-and-exit] to send message, \\[kill-buffer] to discard this composition"))) (t (describe-mode))))) ;;;###autoload (defun vm-spool-move-mail (source destination) (let ((handler (and (fboundp 'find-file-name-handler) (vm-find-file-name-handler source 'vm-spool-move-mail))) status error-buffer) (if handler (funcall handler 'vm-spool-move-mail source destination) (setq error-buffer (get-buffer-create (format "*output of %s %s %s*" vm-movemail-program source destination))) (with-current-buffer error-buffer (erase-buffer)) (setq status (apply 'call-process (nconc (list vm-movemail-program nil error-buffer t) (copy-sequence vm-movemail-program-switches) (list source destination)))) (save-current-buffer (set-buffer error-buffer) (if (and (numberp status) (not (= 0 status))) (insert (format "\n%s exited with code %s\n" vm-movemail-program status))) (if (> (buffer-size) 0) (progn (vm-display-buffer error-buffer) (if (and (numberp status) (not (= 0 status))) (error "Failed getting new mail from %s" source) (vm-warn 1 2 "Warning: unexpected output from %s" vm-movemail-program))) ;; nag, nag, nag. (kill-buffer error-buffer)) t )))) (defun vm-gobble-crash-box (crash-box) (save-excursion (vm-save-restriction (widen) (let ((opoint-max (point-max)) crash-buf (buffer-read-only nil) (inbox-buffer-file buffer-file-name) (inbox-folder-type vm-folder-type) (inbox-empty (zerop (buffer-size))) got-mail crash-folder-type (old-buffer-modified-p (buffer-modified-p))) (setq crash-buf ;; crash box could contain a letter bomb... ;; force user notification of file variables for v18 Emacses ;; enable-local-variables == nil disables them for newer Emacses (let ((inhibit-local-variables t) (enable-local-variables nil) (enable-local-eval nil) (coding-system-for-read (vm-line-ending-coding-system))) (find-file-noselect crash-box))) (if (eq (current-buffer) crash-buf) (error "folder is the same file as crash box, cannot continue")) (save-excursion (set-buffer crash-buf) (setq crash-folder-type (vm-get-folder-type)) (if (and crash-folder-type vm-check-folder-types) (cond ((eq crash-folder-type 'unknown) (error "crash box %s's type is unrecognized" crash-box)) ((eq inbox-folder-type 'unknown) (error "inbox %s's type is unrecognized" inbox-buffer-file)) ((null inbox-folder-type) (if vm-default-folder-type (if (not (eq vm-default-folder-type crash-folder-type)) (if vm-convert-folder-types (progn (vm-convert-folder-type crash-folder-type vm-default-folder-type) ;; so that kill-buffer won't ask a ;; question later... (set-buffer-modified-p nil)) ; crash-buf (error "crash box %s mismatches vm-default-folder-type: %s, %s" crash-box crash-folder-type vm-default-folder-type))))) ((not (eq inbox-folder-type crash-folder-type)) (if vm-convert-folder-types (progn (vm-convert-folder-type crash-folder-type inbox-folder-type) ;; so that kill-buffer won't ask a ;; question later... (set-buffer-modified-p nil)) ; crash-buf (error "crash box %s mismatches %s's folder type: %s, %s" crash-box inbox-buffer-file crash-folder-type inbox-folder-type))))) ;; toss the folder header if the inbox is not empty (goto-char (point-min)) (if (not inbox-empty) (vm-convert-folder-header (or inbox-folder-type vm-default-folder-type) nil) (set-buffer-modified-p nil))) ; crash-buf (goto-char (point-max)) (insert-buffer-substring crash-buf 1 (1+ (with-current-buffer crash-buf (widen) (buffer-size)))) (setq got-mail (/= opoint-max (point-max))) (if (not got-mail) nil (let ((coding-system-for-write (vm-binary-coding-system)) (selective-display nil)) (write-region opoint-max (point-max) buffer-file-name t t)) (vm-increment vm-modification-counter) (vm-restore-buffer-modified-p ; folder-buffer old-buffer-modified-p (current-buffer))) (kill-buffer crash-buf) (if (not (stringp vm-keep-crash-boxes)) (vm-error-free-call 'delete-file crash-box) (let ((time (decode-time (current-time))) name) (setq name (expand-file-name (format "Z-%02d-%02d-%02d%02d%02d-%05d" (nth 4 time) (nth 3 time) (nth 2 time) (nth 1 time) (nth 0 time) (% (vm-abs (random)) 100000)) vm-keep-crash-boxes)) (while (file-exists-p name) (setq name (expand-file-name (format "Z-%02d-%02d-%02d%02d%02d-%05d" (nth 4 time) (nth 3 time) (nth 2 time) (nth 1 time) (nth 0 time) (% (vm-abs (random)) 100000)) vm-keep-crash-boxes))) (rename-file crash-box name))) got-mail )))) (defun vm-compute-spool-files (&optional all) (let ((fallback-triples nil) (crash-box (or vm-crash-box (concat vm-primary-inbox vm-crash-box-suffix))) file file-list triples) (cond ((null (vm-spool-files)) (setq triples (list (list vm-primary-inbox (concat vm-spool-directory (user-login-name)) crash-box)))) ((stringp (car (vm-spool-files))) (setq triples (mapcar (function (lambda (s) (list vm-primary-inbox s crash-box))) (vm-spool-files)))) ((consp (car (vm-spool-files))) (setq triples (vm-spool-files)))) (setq file-list (if all (mapcar 'car triples) (list buffer-file-name))) (while file-list (setq file (car file-list)) (setq file-list (cdr file-list)) (cond ((and file (consp vm-spool-file-suffixes) (stringp vm-crash-box-suffix)) (setq fallback-triples (mapcar (function (lambda (suffix) (list file (concat file suffix) (concat file vm-crash-box-suffix)))) vm-spool-file-suffixes)))) (cond ((and file vm-make-spool-file-name vm-make-crash-box-name) (setq fallback-triples (nconc fallback-triples (list (list file (save-excursion (funcall vm-make-spool-file-name file)) (save-excursion (funcall vm-make-crash-box-name file))))))))) (setq triples (append triples fallback-triples)) triples )) (defun vm-spool-check-mail (source) (let ((handler (vm-find-file-name-handler source 'vm-spool-check-mail))) (if handler (funcall handler 'vm-spool-check-mail source) (let ((size (nth 7 (file-attributes source))) (hash vm-spool-file-message-count-hash) val) (setq val (symbol-value (intern-soft source hash))) (if (and val (equal size (car val))) (> (nth 1 val) 0) (let ((count (vm-count-messages-in-file source))) (if (null count) nil (set (intern source hash) (list size count)) (vm-store-folder-totals source (list count 0 0 0)) (> count 0)))))))) (defun vm-count-messages-in-file (file &optional quietly) (let ((type (vm-get-folder-type file nil nil t)) (work-buffer nil) count) (if (or (memq type '(unknown nil)) (null vm-grep-program)) nil (unwind-protect (let (regexp) (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (cond ((memq type '(From_ BellFrom_ From_-with-Content-Length)) (setq regexp "^From ")) ((eq type 'mmdf) (setq regexp "^\001\001\001\001")) ((eq type 'babyl) (setq regexp "^\037"))) (condition-case data (progn (unless quietly (vm-inform 6 "Counting messages in %s..." file)) (call-process vm-grep-program nil t nil "-c" regexp (expand-file-name file)) (unless quietly (vm-inform 6 "Counting messages in %s... done" file))) (error (vm-warn 1 2 "Attempt to run %s on %s signaled: %s" vm-grep-program file data) (setq vm-grep-program nil))) (setq count (string-to-number (buffer-string))) (cond ((memq type '(From_ BellFrom_ From_-with-Content-Length)) t ) ((eq type 'mmdf) (setq count (/ count 2))) ((eq type 'babyl) (setq count (1- count)))) count )) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-movemail-specific-spool-file-p (file) (string-match "^po:[^:]+$" file)) (defun vm-check-for-spooled-mail (&optional interactive this-buffer-only) (if vm-global-block-new-mail nil (if (and vm-folder-access-method this-buffer-only) (cond ((eq vm-folder-access-method 'pop) (vm-pop-folder-check-mail interactive)) ((eq vm-folder-access-method 'imap) (vm-imap-folder-check-mail interactive))) (let ((triples (vm-compute-spool-files (not this-buffer-only))) ;; since we could accept-process-output here (POP code), ;; a timer process might try to start retrieving mail ;; before we finish. block these attempts. (vm-global-block-new-mail t) (vm-pop-ok-to-ask interactive) (vm-imap-ok-to-ask interactive) ;; for string-match calls below (case-fold-search nil) this-buffer crash in maildrop meth (mail-waiting nil)) (while triples (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory) maildrop (nth 1 (car triples)) crash (nth 2 (car triples))) (if (vm-movemail-specific-spool-file-p maildrop) ;; spool file is accessible only with movemail ;; so skip it. nil (setq this-buffer (eq (current-buffer) (vm-get-file-buffer in))) (when (or this-buffer (not this-buffer-only)) (if (file-exists-p crash) (setq mail-waiting t) (cond ((vm-imap-folder-spec-p maildrop) (setq meth 'vm-imap-check-mail)) ((vm-pop-folder-spec-p maildrop) (setq meth 'vm-pop-check-mail)) (t (setq meth 'vm-spool-check-mail))) (if (not interactive) ;; allow no error to be signaled (condition-case nil (setq mail-waiting (or mail-waiting (funcall meth maildrop))) (error nil)) (setq mail-waiting (or mail-waiting (funcall meth maildrop))))))) (setq triples (cdr triples))) mail-waiting )))) (defun vm-get-spooled-mail (&optional interactive) (if vm-block-new-mail (error "Can't get new mail until you save this folder.")) (cond ((eq vm-folder-access-method 'pop) (vm-pop-synchronize-folder :interactive interactive :do-retrieves t)) ((eq vm-folder-access-method 'imap) (if vm-imap-sync-on-get (progn ;; (vm-imap-synchronize-folder :interactive interactive ;; :save-attributes t) (vm-imap-synchronize-folder :interactive interactive :do-local-expunges t :do-retrieves t :save-attributes t :retrieve-attributes t)) (vm-imap-synchronize-folder :interactive interactive :do-retrieves t))) (t (vm-get-spooled-mail-normal interactive)))) (defun vm-get-spooled-mail-normal (&optional interactive) (if vm-global-block-new-mail nil (let ((triples (vm-compute-spool-files)) ;; since we could accept-process-output here (POP code), ;; a timer process might try to start retrieving mail ;; before we finish. block these attempts. (vm-global-block-new-mail t) (vm-pop-ok-to-ask interactive) (vm-imap-ok-to-ask interactive) ;; for string-match calls below (case-fold-search nil) non-file-maildrop crash in safe-maildrop maildrop popdrop retrieval-function (got-mail nil)) (if (and (not (verify-visited-file-modtime (current-buffer))) (or (null interactive) (not (yes-or-no-p (format "Folder %s changed on disk, discard those changes? " (buffer-name (current-buffer))))))) (progn (vm-warn 0 2 "Folder %s changed on disk, consider M-x revert-buffer" (buffer-name (current-buffer))) nil ) (while triples (setq in (expand-file-name (nth 0 (car triples)) vm-folder-directory)) (setq maildrop (nth 1 (car triples))) (setq crash (nth 2 (car triples))) (setq safe-maildrop maildrop) (setq non-file-maildrop nil) (cond ((vm-movemail-specific-spool-file-p maildrop) (setq non-file-maildrop t) (setq retrieval-function 'vm-spool-move-mail)) ((vm-imap-folder-spec-p maildrop) (setq non-file-maildrop t) (setq safe-maildrop (or (vm-imap-account-name-for-spec maildrop) (vm-safe-imapdrop-string maildrop))) (setq retrieval-function 'vm-imap-move-mail)) ((vm-pop-folder-spec-p maildrop) (setq non-file-maildrop t) (setq safe-maildrop (or (vm-pop-find-name-for-spec maildrop) (vm-safe-popdrop-string maildrop))) (setq retrieval-function 'vm-pop-move-mail)) (t (setq retrieval-function 'vm-spool-move-mail))) (setq crash (expand-file-name crash vm-folder-directory)) (when (eq (current-buffer) (vm-get-file-buffer in)) (when (file-exists-p crash) (vm-inform 1 "Recovering messages from %s..." crash) (setq got-mail (or (vm-gobble-crash-box crash) got-mail)) (vm-inform 1 "Recovering messages from %s... done" crash)) (when (or non-file-maildrop (and (not (equal 0 (nth 7 (file-attributes maildrop)))) (file-readable-p maildrop))) (unless non-file-maildrop (setq maildrop (expand-file-name maildrop vm-folder-directory))) (when (if got-mail ;; don't allow errors to be signaled unless no ;; mail has been appended to the incore ;; copy of the folder. otherwise the ;; user will wonder where the mail is, ;; since it is not in the crash box or ;; the spool file and doesn't _appear_ to ;; be in the folder either. (condition-case error-data (funcall retrieval-function maildrop crash) (error (vm-warn 0 2 "%s signaled: %s" retrieval-function error-data) ;; we don't know if mail was ;; put into the crash box or ;; not, so return t just to be ;; safe. t ) (quit (vm-warn 0 2 "quitting from %s..." retrieval-function) ;; we don't know if mail was ;; put into the crash box or ;; not, so return t just to be ;; safe. t )) (funcall retrieval-function maildrop crash)) (when (vm-gobble-crash-box crash) (setq got-mail t) (when (not non-file-maildrop) (vm-store-folder-totals maildrop '(0 0 0 0))) (vm-inform 5 "Got mail from %s." safe-maildrop))))) (setq triples (cdr triples))) ;; not really correct, but it is what the user expects to see. (setq vm-spooled-mail-waiting nil) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) (when got-mail (condition-case errmsg (run-hooks 'vm-retrieved-spooled-mail-hook) (t (vm-warn 0 2 "Ignoring error while running vm-retrieved-spooled-mail-hook. %S" errmsg))) (vm-assimilate-new-messages :read-attributes nil)))))) ;;;###autoload (defun vm-folder-name () "Return the current folder's name (local file name, or POP/IMAP maildrop string)." (interactive) (if vm-folder-access-method (aref vm-folder-access-data 0) buffer-file-name)) ;; This function is now obsolete. USR, 2011-12-26 (defun vm-safe-popdrop-string (maildrop) "Return a human-readable version of a pop MAILDROP string." (or (and (string-match "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?\\([^:]*\\):[^:]*:[^:]*:\\([^:]*\\):[^:]*" maildrop) (concat (substring maildrop (match-beginning 3) (match-end 3)) "@" (substring maildrop (match-beginning 2) (match-end 2)))) "???")) (defun vm-popdrop-sans-password (source) "Return popdrop SOURCE, but replace the password by a \"*\"." (mapconcat 'identity (append (reverse (cdr (reverse (vm-parse source "\\([^:]*\\):?")))) '("*")) ":")) (defun vm-popdrop-sans-personal-info (source) "Return popdrop SOURCE, but replace the login and password by a \"*\"." (mapconcat 'identity (append (reverse (cdr (cdr (reverse (vm-parse source "\\([^:]*\\):?"))))) '("*" "*")) ":")) ;; This function is now obsolete. USR, 2011-12-26 (defun vm-safe-imapdrop-string (maildrop) "Return a human-readable version of an imap MAILDROP string." (or (and (string-match "^\\(imap\\|imap-ssl\\|imap-ssh\\):\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*" maildrop) (concat (substring maildrop (match-beginning 4) (match-end 4)) "@" (substring maildrop (match-beginning 2) (match-end 2)) " [" (substring maildrop (match-beginning 3) (match-end 3)) "]")) "???")) (defun vm-imapdrop-sans-password (source) (let (source-list) (setq source-list (vm-parse source "\\([^:]*\\):?")) (concat (nth 0 source-list) ":" (nth 1 source-list) ":" (nth 2 source-list) ":" (nth 3 source-list) ":" (nth 4 source-list) ":" (nth 5 source-list) ":" "*"))) (defun vm-imapdrop-sans-password-and-mailbox (source) (let (source-list) (setq source-list (vm-parse source "\\([^:]*\\):?")) (concat (nth 0 source-list) ":" (nth 1 source-list) ":" (nth 2 source-list) ":" "*:" (nth 4 source-list) ":" (nth 5 source-list) ":" "*"))) (defun vm-imapdrop-sans-personal-info (source) (let (source-list) (setq source-list (vm-parse source "\\([^:]*\\):?")) (concat (nth 0 source-list) ":" (nth 1 source-list) ":" (nth 2 source-list) ":" "*:" (nth 4 source-list) ":" "*:" "*"))) (defun vm-maildrop-sans-password (drop) (or (and (string-match "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?\\([^:]*\\):[^:]*:[^:]*:\\([^:]*\\):[^:]*" drop) (vm-popdrop-sans-password drop)) (and (string-match "^\\(imap\\|imap-ssl\\|imap-ssh\\):\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*" drop) (vm-imapdrop-sans-password drop)) drop)) (defun vm-maildrop-sans-personal-info (drop) (or (and (string-match "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?\\([^:]*\\):[^:]*:[^:]*:\\([^:]*\\):[^:]*" drop) (vm-popdrop-sans-personal-info drop)) (and (string-match "^\\(imap\\|imap-ssl\\|imap-ssh\\):\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*" drop) (vm-imapdrop-sans-personal-info drop)) drop)) (defun vm-maildrop-alist-sans-password (alist) (vm-mapcar (lambda (pair-xxx) (cons (vm-maildrop-sans-password (car pair-xxx)) (cdr pair-xxx))) alist)) (defun vm-maildrop-alist-sans-personal-info (alist) (vm-mapcar (lambda (pair-xxx) (cons (vm-maildrop-sans-personal-info (car pair-xxx)) (cdr pair-xxx))) alist)) ;;;###autoload (defun vm-get-new-mail (&optional arg) "Move any new mail that has arrived in any of the spool files for the current folder into the folder. New mail is appended to the disk and buffer copies of the folder. Prefix arg means to gather mail from a user specified folder, instead of the usual spool files. The file name will be read from the minibuffer. Unlike when getting mail from a spool file, the source file is left undisturbed after its messages have been copied. When applied to a virtual folder, this command runs itself on each of the underlying real folders associated with this virtual folder. A prefix argument has no effect when this command is applied to virtual folder; mail is always gathered from the spool files." (interactive "P") (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-error-if-folder-read-only) (let* ((folder (buffer-name)) (description (if (consp (car (vm-spool-files))) ; folder-specific spool files (format "new mail for %s" (buffer-name)) (format "new mail"))) totals-blurb) (cond ((eq major-mode 'vm-virtual-mode) (vm-virtual-get-new-mail)) ((not (eq major-mode 'vm-mode)) (error "Can't get mail for a non-VM folder buffer")) ((null arg) ;; This is redundant now. USR, 2011-12-26 ;; (if (not (eq major-mode 'vm-mode)) ;; (vm-mode)) (vm-inform 5 "Checking for %s..." description) (if (vm-get-spooled-mail t) (progn ;; say this NOW, before the non-previewers read ;; a message, alter the new message count and ;; confuse themselves. (setq totals-blurb (vm-emit-totals-blurb)) (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) (if (vm-thoughtfully-select-message) (vm-present-current-message) (vm-update-summary-and-mode-line)) (vm-inform 5 totals-blurb)) (vm-inform 5 "No new %s" description) (and (vm-interactive-p) (vm-sit-for 4) (vm-inform 5 "")) )) (t (let ((buffer-read-only nil) folder mcount) (setq folder (read-file-name "Gather mail from folder: " vm-folder-directory nil t)) (if (and vm-check-folder-types (not (vm-compatible-folder-p folder))) (error "Folder %s is not the same format as this folder." folder)) (save-excursion (vm-save-restriction (widen) (goto-char (point-max)) (let ((coding-system-for-read (vm-binary-coding-system))) (insert-file-contents folder)))) (setq mcount (length vm-message-list)) (if (vm-assimilate-new-messages) (progn ;; say this NOW, before the non-previewers read ;; a message, alter the new message count and ;; confuse themselves. (setq totals-blurb (vm-emit-totals-blurb)) (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) (if (vm-thoughtfully-select-message) (vm-present-current-message) (vm-update-summary-and-mode-line)) (vm-inform 5 totals-blurb) ;; The gathered messages are actually still on disk ;; unless the user deletes the folder himself. ;; However, users may not understand what happened if ;; the messages go away after a "quit, no save". (setq vm-messages-not-on-disk (+ vm-messages-not-on-disk (- (length vm-message-list) mcount)))) (vm-inform 5 "No messages gathered."))))))) ;; returns list of new messages if there were any new messages, nil otherwise (defun* vm-assimilate-new-messages (&key (read-attributes t) (run-hooks t) gobble-order labels) ;; We are only guessing what this function does. USR, 2010-05-20 ;; This is called in a Folder buffer, which already has messages ;; loaded into it, but some of the messages (the "new" messages) ;; have not been parsed and separated yet. ;; The function first builds a vm-message-list. ;; If READ-ATTRIBUTES is non-nil, it reads the message ;; attributes in the X-VM-v5-Data headers and stores them. ;; If GOBBLE-ORDER is non-nil, it reads the X-VM-Message-Order ;; header and uses it to reorder the messages. ;; If vm-summary-show-threads is non-nil, it builds threads. ;; If vm-ml-sort-keys is non-nil, sorts the messages accordingly. ;; If LABELS is non-nil, they are added to the message labels of all ;; the new messages. ;; If RUN-HOOKS is t, arrived-message-hook functions are ;; called. Normally, this argument is nil for the first ;; time vm-assimilate-new-messages is called in a folder. It is ;; t for subsequent calls when new mail is being incorporated. (let ((tail-cons (vm-last vm-message-list)) b-list new-messages) (save-excursion (vm-save-restriction (widen) (vm-build-message-list) (when (or (null tail-cons) (cdr tail-cons)) (unless vm-assimilate-new-messages-sorted (setq vm-ml-sort-keys nil)) (if read-attributes (vm-read-attributes (cdr tail-cons)) (vm-set-default-attributes (cdr tail-cons))) ;; Yuck. This has to be done here instead of in the ;; vm function because this needs to be done before ;; any initial thread sort (so that if the thread ;; sort matches the saved order the folder won't be ;; modified) but after the message list is created. ;; Since thread sorting is done here this has to be ;; done here too. (when gobble-order (vm-gobble-message-order)) (when (or (vectorp vm-thread-obarray) vm-summary-show-threads) ;; may need threads for sorting (vm-build-threads (cdr tail-cons))))) (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list)) (when new-messages (vm-set-numbering-redo-start-point new-messages) (vm-set-summary-redo-start-point new-messages))) ;; Only update the folders summary count here if new messages ;; have arrived, not when we're reading the folder for the ;; first time, and not if we cannot assume that all the arrived ;; messages should be considered new. Use gobble-order as a ;; first time indicator along with the new messages being equal ;; to the whole message list. (when new-messages (if (and (not read-attributes) (or (not (eq new-messages vm-message-list)) (null gobble-order))) (vm-modify-folder-totals buffer-file-name 'arrived (length new-messages))) ;; copy the new-messages list because sorting might scramble ;; it. Also something the user does when ;; vm-arrived-message-hook is run might affect it. ;; vm-assimilate-new-messages returns this value so it must ;; not be mangled. (setq new-messages (copy-sequence new-messages)) ;; add the labels (when (and labels vm-burst-digest-messages-inherit-labels) (mapc (lambda (m) (vm-set-labels-of m (copy-sequence labels))) new-messages)) (when vm-summary-show-threads ;; get numbering of new messages done now ;; so that the sort code only has to worry about the ;; changes it needs to make. (vm-update-summary-and-mode-line) (vm-sort-messages (or vm-ml-sort-keys (if vm-summary-show-threads "activity" "date")))) (when (and run-hooks (or vm-arrived-message-hook vm-arrived-messages-hook)) ;; seems wise to do this so that if the user runs VM ;; commands here they start with as much of a clean ;; slate as we can provide, given we're currently deep ;; in the guts of VM. (vm-update-summary-and-mode-line) (when (and vm-arrived-message-hook (not (eq vm-folder-access-method 'imap))) (mapc (lambda (m) (vm-run-hook-on-message 'vm-arrived-message-hook m)) new-messages)) (run-hooks 'vm-arrived-messages-hook)) (when vm-virtual-buffers (save-excursion (setq b-list vm-virtual-buffers) (while b-list ;; buffer might be dead (when (buffer-name (car b-list)) (let (tail-cons) (set-buffer (car b-list)) (setq tail-cons (vm-last vm-message-list)) (vm-build-virtual-message-list new-messages) (when (or (null tail-cons) (cdr tail-cons)) (if (not vm-assimilate-new-messages-sorted) (setq vm-ml-sort-keys nil)) (if (vectorp vm-thread-obarray) (vm-build-threads (cdr tail-cons))) (vm-set-summary-redo-start-point (or (cdr tail-cons) vm-message-list)) (vm-set-numbering-redo-start-point (or (cdr tail-cons) vm-message-list)) (unless vm-message-pointer (setq vm-message-pointer vm-message-list vm-need-summary-pointer-update t) (if vm-message-pointer (vm-present-current-message))) (when vm-summary-show-threads (vm-update-summary-and-mode-line) (vm-sort-messages (or vm-ml-sort-keys "activity"))) ))) (setq b-list (cdr b-list))))) (when vm-ml-sort-keys (vm-sort-messages vm-ml-sort-keys))) new-messages )) (defun vm-select-operable-messages (prefix &optional interactive op-description) "Return a list of all marked messages, messages indicated by the PREFIX argument or messages in a collapsed thread, in that order. Marked messages are returned only if the previous command was `vm-next-command-uses-marks'. PREFIX is used if it is not 1 or INTERACTIVE is nil, returning a number of messages around `vm-message-pointer' equal to (abs prefix), either backward (if prefix is negative) or forward (if positive). OP-DESCRIPTION is a string describing the opeartion being peformed, which is used in interactive confirmations." (cond ((eq last-command 'vm-next-command-uses-marks) (vm-marked-messages)) ((not (= prefix 1)) (let ((direction (if (< prefix 0) 'backward 'forward)) (count (vm-abs prefix)) (vm-message-pointer vm-message-pointer) ; why this? mlist) (unless (eq vm-circular-folders t) (vm-check-count prefix)) (while (not (zerop count)) (setq mlist (cons (car vm-message-pointer) mlist)) (vm-decrement count) (unless (zerop count) (vm-move-message-pointer direction))) (nreverse mlist))) ((and interactive (vm-summary-operation-p) vm-summary-enable-thread-folding vm-summary-show-threads vm-enable-thread-operations (vm-thread-root-p (vm-current-message)) (vm-collapsed-root-p (vm-current-message)) (or (eq vm-enable-thread-operations t) (y-or-n-p (format "%s all messages in thread? " op-description)))) (vm-thread-subtree (vm-current-message))) (t (list (vm-current-message))) )) (defun vm-display-startup-message () (if (sit-for 5) (let ((lines vm-startup-message-lines)) (vm-inform 8 "VM %s. Type ? for help." (vm-version)) (setq vm-startup-message-displayed t) (while (and (sit-for 4) lines) (vm-inform 8 (substitute-command-keys (car lines))) (setq lines (cdr lines))))) (vm-inform 8 "")) ;;;###autoload (defun vm-toggle-read-only () (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (setq vm-folder-read-only (not vm-folder-read-only)) (intern (buffer-name) vm-buffers-needing-display-update) (vm-inform 5 "Folder is now %s" (if vm-folder-read-only "read-only" "modifiable")) (vm-display nil nil '(vm-toggle-read-only) '(vm-toggle-read-only)) (vm-update-summary-and-mode-line)) (defvar scroll-in-place) ;; this does the real major mode scutwork. (defun vm-mode-internal (&optional access-method reload) "Turn on vm-mode in the current buffer. ACCESS-METHOD is either 'pop or 'imap for server folders. If RELOAD is non-Nil, then the folder is being recovered. So, folder-access-data should be preserved." (widen) (make-local-variable 'require-final-newline) ;; don't kill local variables, as there is some state we'd like to ;; keep. rather than non-portably marking the variables we ;; want to keep, just avoid calling kill-local-variables and ;; reset everything that needs to be reset. (setq major-mode 'vm-mode mode-line-format vm-mode-line-format mode-name "VM" ;; must come after the setting of major-mode mode-popup-menu (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-mode-menu)) buffer-read-only t ;; If the user quits a vm-mode buffer, the default action is ;; to kill the buffer. Make a note that we should offer to ;; save this buffer even if it has no file associated with it. ;; We have no idea of the value of the data in the buffer ;; before it was put into vm-mode. buffer-offer-save t require-final-newline nil ;; don't let CR's in folders be mashed into LF's because of a ;; stupid user setting. selective-display nil vm-thread-obarray 'bonk vm-thread-subject-obarray 'bonk vm-label-obarray (make-vector 29 0) vm-last-message-pointer nil vm-modification-counter 0 vm-message-list nil vm-message-pointer nil vm-message-order-changed nil vm-message-order-header-present nil vm-imap-retrieved-messages nil vm-pop-retrieved-messages nil vm-summary-buffer nil vm-system-state nil vm-undo-record-list nil vm-undo-record-pointer nil vm-virtual-buffers (vm-link-to-virtual-buffers) vm-folder-type (vm-get-folder-type)) (when (not reload) (cond ((eq access-method 'pop) (setq vm-folder-access-method 'pop) (setq vm-folder-access-data (make-vector vm-folder-pop-access-data-length nil))) ((eq access-method 'imap) (setq vm-folder-access-method 'imap) (setq vm-folder-access-data (make-vector vm-folder-imap-access-data-length nil))))) (use-local-map vm-mode-map) ;; if the user saves after M-x recover-file, let them get new ;; mail again. (vm-make-local-hook 'after-save-hook) (add-hook 'after-save-hook 'vm-unblock-new-mail nil t) (when (vm-menu-support-possible-p) (vm-menu-install-menus)) (add-hook 'kill-buffer-hook 'vm-garbage-collect-folder) (add-hook 'kill-buffer-hook 'vm-garbage-collect-message) ;; avoid the XEmacs file dialog box. (defvar use-dialog-box) (make-local-variable 'use-dialog-box) (setq use-dialog-box nil) ;; mail folders are precious. protect them by default. (make-local-variable 'file-precious-flag) (setq file-precious-flag vm-folder-file-precious-flag) ;; scroll in place messes with scroll-up and this loses (make-local-variable 'scroll-in-place) (setq scroll-in-place nil) (run-hooks 'vm-mode-hook) ;; compatibility (run-hooks 'vm-mode-hooks)) (defun vm-link-to-virtual-buffers () "If there are visited virtual folders that depend on the current real folder, then link them to the current folder and update their contents." (let ((b-list (buffer-list)) (vbuffers nil) (folder-buffer (current-buffer)) folders folder clauses) (save-excursion (while b-list (set-buffer (car b-list)) (cond ((eq major-mode 'vm-virtual-mode) (setq clauses (cdr vm-virtual-folder-definition)) (while clauses (setq folders (car (car clauses))) (while folders (setq folder (car folders)) (if (eq folder-buffer (or (and (stringp folder) (vm-get-file-buffer (expand-file-name folder vm-folder-directory))) (and (listp folder) (eval folder)))) (setq vbuffers (cons (car b-list) vbuffers) vm-real-buffers (cons folder-buffer vm-real-buffers) folders nil clauses nil)) (setq folders (cdr folders))) (setq clauses (cdr clauses))))) (setq b-list (cdr b-list))) vbuffers ))) ;;;###autoload (defun vm-change-folder-type (type) "Change folder type to TYPE. TYPE may be one of the following symbol values: From_ From_-with-Content-Length BellFrom_ mmdf babyl Interactively TYPE will be read from the minibuffer." (interactive (let ((this-command this-command) (last-command last-command) (types vm-supported-folder-types)) (save-current-buffer (vm-select-folder-buffer) (vm-error-if-virtual-folder) (setq types (vm-delqual (symbol-name vm-folder-type) (copy-sequence types))) (list (intern (vm-read-string "Change folder to type: " types)))))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-virtual-folder) (if (not (memq type '(From_ BellFrom_ From_-with-Content-Length mmdf babyl))) (error "Unknown folder type: %s" type)) (if (or (null vm-folder-type) (eq vm-folder-type 'unknown)) (error "Current folder's type is unknown, can't change it.")) (let ((mp vm-message-list) (buffer-read-only nil) (old-type vm-folder-type) ;; no interruptions (inhibit-quit t) (n 0) ;; Just for laughs, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 5)) text-end opoint) (save-excursion (vm-save-restriction (widen) (setq vm-folder-type type) (goto-char (point-min)) (vm-convert-folder-header old-type type) (while mp (goto-char (vm-start-of (car mp))) (setq opoint (point)) (insert (vm-leading-message-separator type (car mp))) (if (> (vm-headers-of (car mp)) (vm-start-of (car mp))) (delete-region (point) (vm-headers-of (car mp))) (set-marker (vm-headers-of (car mp)) (point)) ;; if headers-of == start-of then so could vheaders-of ;; and text-of. clear them to force a recompute. (vm-set-vheaders-of (car mp) nil) (vm-set-text-of (car mp) nil)) (vm-convert-folder-type-headers old-type type) (goto-char (vm-text-end-of (car mp))) (setq text-end (point)) (insert-before-markers (vm-trailing-message-separator type)) (delete-region (vm-text-end-of (car mp)) (vm-end-of (car mp))) (set-marker (vm-text-end-of (car mp)) text-end) (goto-char (vm-headers-of (car mp))) (vm-munge-message-separators type (vm-headers-of (car mp)) (vm-text-end-of (car mp))) (vm-set-byte-count-of (car mp) nil) (vm-set-babyl-frob-flag-of (car mp) nil) (vm-set-message-type-of (car mp) type) ;; Technically we should mark each message for a ;; summary update since the message byte counts might ;; have changed. But I don't think anyone cares that ;; much and the summary regeneration would make this ;; process slower. (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (vm-inform 5 "Converting... %d" n)))))) (vm-clear-modification-flag-undos) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) (vm-inform 5 "Conversion complete.") ;; message separator strings may have leaked into view (if (> (point-max) (vm-text-end-of (car vm-message-pointer))) (narrow-to-region (point-min) (vm-text-end-of (car vm-message-pointer)))) (vm-display nil nil '(vm-change-folder-type) '(vm-change-folder-type))) (defun vm-register-global-garbage-files (files) "Add global garbage collection actions to delete all of FILES." (while files (setq vm-global-garbage-alist (cons (cons (car files) 'delete-file) vm-global-garbage-alist) files (cdr files)))) (defun vm-garbage-collect-global () "Carry out all the registered global garbage collection actions." (save-excursion (while vm-global-garbage-alist (condition-case nil (funcall (cdr (car vm-global-garbage-alist)) (car (car vm-global-garbage-alist))) (error nil)) (setq vm-global-garbage-alist (cdr vm-global-garbage-alist))))) (defun vm-register-folder-garbage-files (files) "Add folder garbage collection actions to delete all of FILES." (vm-register-global-garbage-files files) (save-excursion (vm-select-folder-buffer) (while files (setq vm-folder-garbage-alist (cons (cons (car files) 'delete-file) vm-folder-garbage-alist) files (cdr files))))) (defun vm-register-folder-garbage (action garbage) "Add a folder garbage-collection action to carry out ACTION on argument GARBAGE." (save-excursion (vm-select-folder-buffer) (setq vm-folder-garbage-alist (cons (cons garbage action) vm-folder-garbage-alist)))) (defun vm-garbage-collect-folder () "Carry out all the folder garbage-collection actions." (save-excursion (while vm-folder-garbage-alist (condition-case nil (funcall (cdr (car vm-folder-garbage-alist)) (car (car vm-folder-garbage-alist))) (error nil)) (setq vm-folder-garbage-alist (cdr vm-folder-garbage-alist))))) (defun vm-register-fetched-message (m) "Register real message M as having been fetched into its folder temporarily. Such fetched messages are discarded before the folder is saved." (save-current-buffer (set-buffer (vm-buffer-of m)) ;; m should have retrieve=nil, i.e., already retrieved (vm-assert (vm-body-retrieved-of m)) (let ((vm-folder-read-only nil) (modified (buffer-modified-p))) (if (memq m vm-fetched-messages) (progn ;; at the moment, this case doesn't arise. USR, 2010-06-11 ;; move m to the rear (setq vm-fetched-messages (delq m vm-fetched-messages)) (setq vm-fetched-messages ; add-to-list is no good on XEmacs (nconc vm-fetched-messages (list m)))) (if vm-fetched-message-limit (while (>= vm-fetched-message-count vm-fetched-message-limit) (let ((mm (car vm-fetched-messages))) ;; These tests should always come out true, but we are ;; not confident. A lot could have happened since the ;; message was first loaded. (when (and (vm-body-retrieved-of mm) (vm-body-to-be-discarded-of mm)) (vm-discard-real-message-body mm)) (vm-unregister-fetched-message mm)))) (setq vm-fetched-messages (nconc vm-fetched-messages (list m))) (vm-increment vm-fetched-message-count) (vm-set-body-to-be-discarded-of m t) (vm-restore-buffer-modified-p modified (vm-buffer-of m)))))) (defun vm-unregister-fetched-message (m) "Unregister a real message M as a fetched message. If M was never registered as a fetched message, then there is no effect." (save-current-buffer (set-buffer (vm-buffer-of m)) (let ((vm-folder-read-only nil)) (setq vm-fetched-messages (delq m vm-fetched-messages)) (vm-decrement vm-fetched-message-count) (vm-set-body-to-be-discarded-of m nil)))) (defun vm-discard-fetched-messages () "Discard the message bodies of all the fetched messages in the current folder." (while vm-fetched-messages (let ((m (car vm-fetched-messages)) (vm-folder-read-only nil)) (vm-discard-real-message-body m) (vm-set-body-to-be-discarded-of m nil)) (setq vm-fetched-messages (cdr vm-fetched-messages))) (setq vm-fetched-message-count 0)) (defun vm-register-message-garbage-files (files) "Add message garbage collection actions to delete all of FILES." (vm-register-folder-garbage-files files) (save-excursion (vm-select-folder-buffer) (while files (setq vm-message-garbage-alist (cons (cons (car files) 'delete-file) vm-message-garbage-alist) files (cdr files))))) (defun vm-register-message-garbage (action garbage) "Add a message garbage-collection action to carry out ACTION on argument GARBAGE." (vm-register-folder-garbage action garbage) (save-excursion (vm-select-folder-buffer) (setq vm-message-garbage-alist (cons (cons garbage action) vm-message-garbage-alist)))) (defun vm-garbage-collect-message () "Carry out all the folder garbage-collection actions." (save-excursion (while vm-message-garbage-alist (condition-case nil (funcall (cdr (car vm-message-garbage-alist)) (car (car vm-message-garbage-alist))) (error nil)) (setq vm-message-garbage-alist (cdr vm-message-garbage-alist))))) (vm-add-write-file-hook 'vm-write-file-hook) (vm-add-find-file-hook 'vm-handle-file-recovery) (vm-add-find-file-hook 'vm-handle-file-reversion) ;; after-revert-hook is new to FSF v19.23 (defvar after-revert-hook) (if (boundp 'after-revert-hook) (setq after-revert-hook (cons 'vm-after-revert-buffer-hook after-revert-hook)) (setq after-revert-hook (list 'vm-after-revert-buffer-hook))) (defun vm-message-can-be-external (m) "Check if the message M can be used in external (headers-only) mode." (and (eq (vm-message-access-method-of m) 'imap) (or (eq vm-enable-external-messages t) (memq 'imap vm-enable-external-messages)) )) ;;;###autoload (defun vm-load-message (&optional count) "Load the message by retrieving its body from its permanent location. Currently this facility is only available for IMAP folders. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are loaded. A negative argument means the current message and the previous |COUNT| - 1 messages are loaded. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are loaded, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are loaded." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (when (null count) (setq count 1)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Load")) (errors 0) (n 0) fetch-method m mm) (setq count 0) (unwind-protect (save-excursion (vm-inform 8 "Retrieving message body...") (while mlist (setq m (car mlist)) (setq mm (vm-real-message-of m)) (set-buffer (vm-buffer-of mm)) (if (vm-body-retrieved-of mm) (when (vm-body-to-be-discarded-of mm) (vm-unregister-fetched-message mm) (setq count (1+ count))) ;; else retrieve the body (setq n (1+ n)) (vm-inform 8 "Retrieving message body... %s" n) (vm-retrieve-real-message-body mm) (setq count (1+ count)) (when (> n 0) (vm-inform 8 "Retrieving message body... done"))) (setq mlist (cdr mlist))) (intern (buffer-name) vm-buffers-needing-display-update) ;; FIXME - is this needed? Is it correct? (vm-display nil nil '(vm-load-message vm-refresh-message) (list this-command)) (when (> count 0) (vm-mark-folder-modified-p)) (vm-update-summary-and-mode-line)) (if (= count 1) (vm-inform 5 "Message body loaded") (vm-inform 5 "%s message bodies loaded" (if (= count 0) "No" count)))) )) ;;;###autoload (defun vm-retrieve-operable-messages (&optional count mlist) "Retrieve the message from from its permanent location for temporary use. Currently this facility is only available for IMAP folders. If the optional argument MLIST is non-nil, then the messages in MLIST are retrieved. Otherwise, the following applies. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are retrieved. A negative argument means the current message and the previous |COUNT| - 1 messages are retrieved. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are retrieved, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are retrieved." (save-current-buffer (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (when (null count) (setq count 1)) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (vm-fetched-message-limit nil) (errors 0) (n 0) fetch-method m mm) ;; (if (not used-marks) ;; (setq mlist (list (car vm-message-pointer)))) (unless mlist (setq mlist (vm-select-operable-messages count (vm-interactive-p) "Retrieve"))) (save-excursion (while mlist (setq m (car mlist)) (setq mm (vm-real-message-of m)) (set-buffer (vm-buffer-of mm)) (when (vm-body-to-be-retrieved-of mm) (setq n (1+ n)) (vm-inform 8 "Retrieving message body... %s" n) (vm-retrieve-real-message-body mm :register t)) (setq mlist (cdr mlist))) (when (> n 0) (vm-inform 8 "Retrieving message body... done") (intern (buffer-name) vm-buffers-needing-display-update) (when (vm-interactive-p) (vm-update-summary-and-mode-line)))) ))) (defun* vm-retrieve-real-message-body (mm &key (fetch nil) (register nil)) "Retrieve the body of a real message MM from its external source and insert it into the Folder buffer. If the optional argument FETCH is t, then the retrieval is for a temporary message fetch. If the optional argument REGISTER is t, then register it as a fetched message. Gives an error if unable to retrieve message." (if (not (eq (vm-message-access-method-of mm) 'imap)) (message "External messages currently available only for imap folders.") (save-excursion (set-buffer (vm-buffer-of mm)) (vm-save-restriction (widen) (narrow-to-region (marker-position (vm-headers-of mm)) (marker-position (vm-text-end-of mm))) (let ((fetch-method (vm-message-access-method-of mm)) (vm-folder-read-only (and vm-folder-read-only (not fetch))) (inhibit-read-only t) ;; (buffer-read-only nil) ; seems redundant (buffer-undo-list t) ; why this? USR, 2010-06-11 (modified (buffer-modified-p)) (fetch-result nil) (testing 0)) (goto-char (vm-text-of mm)) ;; Check to see that we are at the right place (vm-assert (save-excursion (forward-line -1) (looking-at "\n"))) (vm-increment testing) (delete-region (point) (point-max)) ;; Remember that this does I/O and accept-process-output, ;; allowing concurrent threads to run!!! USR, 2010-07-11 (condition-case err (setq fetch-result (apply (intern (format "vm-fetch-%s-message" fetch-method)) mm nil)) (error (vm-warn 0 0 "Unable to load message; %s" (error-message-string err)))) (when fetch-result (vm-assert (eq (point) (marker-position (vm-text-of mm)))) (vm-increment testing) ;; delete the new headers (delete-region (vm-text-of mm) (or (re-search-forward "\n\n" (point-max) t) (point-max))) (vm-assert (eq (point) (marker-position (vm-text-of mm)))) (vm-increment testing) ;; fix markers now (set-marker (vm-text-end-of mm) (point-max)) (vm-assert (eq (point) (marker-position (vm-text-of mm)))) (vm-assert (save-excursion (forward-line -1) (looking-at "\n"))) (vm-increment testing) ;; now care for the layout of the message (vm-set-mime-layout-of mm (vm-mime-parse-entity-safe mm)) ;; update the message data (vm-set-body-to-be-retrieved-flag mm nil) (vm-set-body-to-be-discarded-flag mm nil) (vm-set-line-count-of mm nil) (vm-set-byte-count-of mm nil) ;; update the virtual messages (vm-update-virtual-messages mm :message-changing nil) (vm-restore-buffer-modified-p modified (vm-buffer-of mm)) (vm-assert (eq (point) (marker-position (vm-text-of mm)))) (vm-assert (save-excursion (forward-line -1) (looking-at "\n"))) (vm-increment testing) (when register (vm-register-fetched-message mm)))))))) ;;;###autoload (defun vm-refresh-message () "Reload the message body from its permanent location. Currently this facilty is only available for IMAP folders." (interactive) (vm-unload-message 1 t) (vm-load-message) (intern (buffer-name) vm-buffers-needing-display-update) (let ((vm-preview-lines nil)) (vm-present-current-message))) ;;;###autoload (defun vm-unload-message (&optional count physical) "Unload the message body, i.e., delete it from the folder buffer. It can be retrieved again in future from its permanent external location. Currently this facility is only available for IMAP folders. With a prefix argument COUNT, the current message and the next COUNT - 1 messages are unloaded. A negative argument means the current message and the previous |COUNT| - 1 messages are unloaded. When invoked on marked messages (via `vm-next-command-uses-marks'), only marked messages are unloaded, other messages are ignored. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are unloaded. If the optional argument PHYSICAL is non-nil, then the message is physically discarded. Otherwise, the discarding may be delayed until the folder is saved." (interactive "p") (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (when (null count) (setq count 1)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Unload")) (buffer-undo-list t) (errors 0) m mm) (save-excursion (setq count 0) (while mlist (setq m (car mlist)) (setq mm (vm-real-message-of m)) (set-buffer (vm-buffer-of mm)) (cond ((null (vm-message-can-be-external mm))) ((vm-body-to-be-retrieved-of mm)) ((vm-body-to-be-discarded-of mm) (when physical (vm-discard-real-message-body mm) (setq count (1+ count)))) (t (if physical (vm-discard-real-message-body mm) ;; Register the message as fetched instead of actually ;; discarding the message (vm-register-fetched-message mm)) (setq count (1+ count)))) (setq mlist (cdr mlist)))) (if (= count 1) (vm-inform 5 "Message body discarded") (vm-inform 5 "%s message bodies discarded" (if (= count 0) "No" count))) (vm-mark-folder-modified-p) (vm-update-summary-and-mode-line) )) (defun vm-discard-real-message-body (mm) "Discard the real message body of MM from its Folder buffer." (if (not (vm-message-can-be-external mm)) (vm-set-body-to-be-discarded-flag mm nil) (save-current-buffer (set-buffer (vm-buffer-of mm)) (vm-save-restriction (widen) (let ((inhibit-read-only t) ;; (buffer-read-only nil) ; seems redundant (modified (buffer-modified-p))) (goto-char (vm-text-of mm)) ;; Check to see that we are at the right place (if (or (bobp) (save-excursion (forward-line -1) (looking-at "\n"))) (progn (delete-region (point) (vm-text-end-of mm)) (vm-set-mime-layout-of mm nil) (vm-set-body-to-be-retrieved-flag mm t) (vm-set-body-to-be-discarded-flag mm nil) (vm-set-line-count-of mm nil) (vm-update-virtual-messages mm :message-changing nil) (vm-restore-buffer-modified-p modified (vm-buffer-of mm))) (if (y-or-n-p (concat "VM internal error: " "headers of a message have been corrupted. " "Continue? ")) (progn (vm-warn 1 5 (concat "The damaged message, with UID %s, " "is left in the folder") (vm-imap-uid-of mm)) (vm-set-body-to-be-discarded-flag mm nil)) (error "Aborted operation"))) ))))) ;;; vm-folder.el ends here vm-8.2.0b/lisp/autoloads.py0000755000175000017500000000636411676442160016116 0ustar srivastasrivasta#!/usr/bin/python # -*- python -*- import sys def identifier_start(string, startpos=0): #print string, startpos while (startpos < len(string) and ("() \t\r\n.,".find(string[startpos]) != -1)): startpos = startpos + 1 return startpos def identifier_end(string, startpos=0): #print string, startpos while (startpos < len(string) and ("() \t\r\n.,".find(string[startpos]) == -1)): startpos = startpos + 1 return startpos class Def: def __init__(self, filename, lineno, autoload, symbol): self.filename = filename self.lineno = lineno self.autoload = autoload self.symbol = symbol def __str__(self): return ("%s:%d %s %s" % (self.filename, self.lineno, self.symbol, self.autoload)) def find_defs(filename, pattern="(defun", pos=0): """Find definitions of pattern in the given file. Returns defined symbols.""" symbols = [] fd = open(filename) lineno = 0 autoload = False for l in fd: lineno = lineno + 1 if l.startswith(";;;###autoload"): autoload = True continue s = l.find(pattern) if s == -1 or s != pos: continue s = identifier_start(l, s + len(pattern)) while "() \t\r\n.,".find(l[s]) != -1: s = s + 1 e = identifier_end(l, s) if s == e: raise "Could not find identifier end in " + repr(l) continue #print s, e #print l[s : e] symbols.append(Def(filename, lineno, autoload, l[s : e])) autoload = False fd.close() return symbols preloaded = ["vm-version.el", "vm-misc.el", "vm-macro.el", "vm-folder.el", "vm-summary.el", "vm-minibuf.el", "vm-motion.el", "vm-page.el", "vm-mouse.el", "vm-window.el", "vm-menu.el", "vm-message.el", "vm-toolbar.el", "vm.el", "vm-undo.el", "vm-mime.el", "vm-vars.el"] def check_calls(filename, funs, missing): #print "-" * 50 #print filename fd = open(filename) required = [] for l in fd: s = l.find("(require") if s != -1: s = identifier_start(l, s + len("(require '" )) e = identifier_end(l, s) #print l[s:e], "*" * 50 required.append(l[s:e] + ".el") #print required continue # check for calls to external function without autoloads or require for c in l.split("("): s = identifier_start(c, 0) e = identifier_end(c, s) #print repr(c) s = identifier_start(c, 0) e = identifier_end(c, s) f = c[s:e] if f not in funs: continue d = funs[f] if ((d.filename != filename) and (not d.autoload) and (d.filename not in preloaded) and (d.filename not in required)): #print preloaded #print "'%s' : '%s' => '%s' %s" % (filename, f, d.filename, #d.filename in preloaded) #print preloaded if not missing.has_key(d.filename): missing[d.filename] = [] if f not in missing[d.filename]: missing[d.filename].append(f) fd.close() # emit cross references with missing autoloads if __name__ == '__main__': funs = {} for filename in sys.argv[3:]: for d in find_defs(filename): if funs.has_key(d.symbol): print "Duplicate %s <> %s" % (d, funs[d.symbol]) else: funs[d.symbol] = d missing = {} for filename in sys.argv[3:]: check_calls(filename, funs, missing) for f in missing.keys(): print f for m in missing[f]: print "\t", m vm-8.2.0b/lisp/vm-vcard.el0000755000175000017500000000602111676442160015600 0ustar srivastasrivasta;;; vm-vcard.el --- vcard parsing and formatting routines for VM ;; ;; This file is an add-on for VM ;; Copyright (C) 1997, 2000 Noah S. Friedman ;; Author: Noah Friedman ;; Maintainer: friedman@splode.com ;; Keywords: extensions ;; Created: 1997-10-03 ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, you can either send email to this ;; program's maintainer or write to: The Free Software Foundation, ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA. ;;; Commentary: ;;; Code: (provide 'vm-vcard) (require 'vcard) (eval-when-compile (require 'vm-mime)) (and (string-lessp vcard-api-version "2.0") (error "vm-vcard.el requires vcard API version 2.0 or later.")) ;;;###autoload (defvar vm-vcard-format-function nil "*Function to use for formatting vcards; if nil, use default.") ;;;###autoload (defvar vm-vcard-filter nil "*Filter function to use for formatting vcards; if nil, use default.") ;;;###autoload (defun vm-mime-display-internal-text/x-vcard (layout) (let ((inhibit-read-only t) (buffer-read-only nil)) (insert (vm-vcard-format-layout layout))) t) ;;;###autoload (defun vm-mime-display-internal-text/vcard (layout) (vm-mime-display-internal-text/x-vcard layout)) ;;;###autoload (defun vm-mime-display-internal-text/directory (layout) (vm-mime-display-internal-text/x-vcard layout)) (defun vm-vcard-format-layout (layout) (let* ((beg (vm-mm-layout-body-start layout)) (end (vm-mm-layout-body-end layout)) (buf (if (markerp beg) (marker-buffer beg) (current-buffer))) (raw (vm-vcard-decode (save-excursion (set-buffer buf) (save-restriction (widen) (buffer-substring beg end))) layout)) (vcard-pretty-print-function (or vm-vcard-format-function vcard-pretty-print-function))) (vcard-pretty-print (vcard-parse-string raw vm-vcard-filter)))) (defun vm-vcard-decode (string layout) (let ((buf (generate-new-buffer " *vcard decoding*"))) (save-excursion (set-buffer buf) (insert string) (vm-mime-transfer-decode-region layout (point-min) (point-max)) (setq string (buffer-substring (point-min) (point-max)))) (kill-buffer buf)) string) (defun vm-vcard-format-simple (vcard) (concat "\n\n--\n" (vcard-format-sample-string vcard) "\n\n")) ;;; vm-vcard.el ends here. vm-8.2.0b/lisp/vm-w3m.el0000755000175000017500000001371511676442160015217 0ustar srivastasrivasta;;; vm-w3m.el --- additional functions to make VM use emacs-w3m for HTML mails ;; ;; This file is part of VM ;; ;; Copyright (C) 2003, 2005, 2006 Katsumi Yamaoka, ;; Copyright (C) 2007 Robert Widhopf-Fenk ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; You need to have w3m and emacs-w3m installed for this module to ;; work. Visit for details. ;; You don't have to change VM at all. Simply load this module and ;; you will see HTML mails inlined by emacs-w3m in the VM presentation ;; buffer. ;;; Code: (provide 'vm-w3m) (eval-when-compile (require 'vm-mime) (require 'executable)) (eval-and-compile (vm-load-features '(w3m))) (declare-function w3m-region "ext:w3m" (start end &optional url charset)) (declare-function w3m-safe-toggle-inline-images "ext:w3m" (&optional force no-cache)) ;; Dummy vriable declarations to suppress warnings if w3m is not ;; loaded (defvar w3m-current-buffer) (defvar w3m-cid-retrieve-function-alist) (defvar w3m-minor-mode-map) (defvar url-working-buffer) (defvar url-current-mime-type) (defvar url-current-mime-headers) (defvar vm-w3m-mode-map nil "Keymap for w3m within VM.") (defgroup vm-w3m nil "w3m settings for VM." :group 'vm-presentation) (defcustom vm-w3m-display-inline-images t "Non-nil means VM will allow retrieving images in the HTML contents with the tags. See also the documentation for the variable `vm-w3m-safe-url-regexp'." :group 'vm-w3m :type 'boolean) (defcustom vm-w3m-safe-url-regexp "\\`cid:" "Regexp matching URLs which are considered to be safe. Some HTML mails might contain a nasty trick used by spammers, using the tag which is far more evil than the [Click Here!] button. It is most likely intended to check whether the ominous spam mail has reached your eyes or not, in which case the spammer knows for sure that your email address is valid. It is done by embedding an identifier string into a URL that you might automatically retrieve when displaying the image. The default value is \"\\\\`cid:\" which only matches parts embedded to the Multipart/Related type MIME contents and VM will never connect to the spammer's site arbitrarily. You may set this variable to nil if you consider all urls to be safe." :group 'vm-w3m :type '(choice (regexp :tag "Regexp") (const :tag "All URLs are safe" nil))) (defcustom vm-w3m-use-w3m-minor-mode-map t "Say whether to use emacs-w3m command keys in VM presentation buffers. Set this variable to nil if you don't want vm-w3m to override any VM commend keys. If it is non-nil, you will not be able to use some VM command keys, which are bound to emacs-w3m commands defined in the `w3m-minor-mode-command-alist' variable." :group 'vm-w3m :type 'boolean) (eval-and-compile (or (featurep 'xemacs) (>= emacs-major-version 21) (defvar vm-w3m-mode-map nil "Keymap for text/html parts inlined by emacs-w3m. This keymap will be bound only when Emacs 20 is running and overwritten by the value of `w3m-minor-mode-map'. In order to add some commands to this keymap, add them to `w3m-minor-mode-map' instead of this keymap."))) (defun vm-w3m-cid-retrieve (url &rest args) "Insert a content of URL." (let ((message (save-excursion (set-buffer w3m-current-buffer) (car vm-message-pointer))) part type) (setq part (vm-mime-cid-retrieve url message)) (when part (setq type (car (vm-mm-layout-type part))) (vm-mime-transfer-decode-region part (point-min) (point-max))) type)) (or (assq 'vm-presentation-mode w3m-cid-retrieve-function-alist) (setq w3m-cid-retrieve-function-alist (cons '(vm-presentation-mode . vm-w3m-cid-retrieve) w3m-cid-retrieve-function-alist))) (defun vm-w3m-local-map-property () (if (and (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) (if (or (featurep 'xemacs) (>= emacs-major-version 21)) (list 'keymap w3m-minor-mode-map) (list 'local-map (or vm-w3m-mode-map (progn (setq vm-w3m-mode-map (copy-keymap w3m-minor-mode-map)) (set-keymap-parent vm-w3m-mode-map vm-mode-map) vm-w3m-mode-map)))))) ;;;###autoload (defun vm-mime-display-internal-emacs-w3m-text/html (start end layout) "Use emacs-w3m to inline HTML mails in the VM presentation buffer." (let ((w3m-display-inline-images vm-w3m-display-inline-images) (w3m-safe-url-regexp vm-w3m-safe-url-regexp)) (w3m-region start (1- end)) (add-text-properties start end (nconc (if vm-w3m-use-w3m-minor-mode-map (if (equal major-mode 'vm-presentation-mode) (vm-w3m-local-map-property))) ;; Put the mark meaning that this part was ;; inlined by emacs-w3m. '(text-rendered-by-emacs-w3m t))))) (defun vm-w3m-safe-toggle-inline-images (&optional arg) "Toggle displaying of all images in the presentation buffer. If the prefix arg is given, all images are considered to be safe." (interactive "P") (let ((buffer (cond ((eq major-mode 'vm-summary-mode) (with-current-buffer vm-mail-buffer vm-presentation-buffer)) ((eq major-mode 'vm-presentation-mode) (current-buffer)) ((eq major-mode 'vm-mode) vm-presentation-buffer)))) (if (buffer-live-p buffer) (save-excursion (set-buffer buffer) (w3m-safe-toggle-inline-images arg))))) ;;; vm-w3m.el ends here vm-8.2.0b/lisp/Makefile.in0000755000175000017500000002016411676442160015610 0ustar srivastasrivasta@SET_MAKE@ ############################################################################## # no csh please SHELL = /bin/sh # the version of this package PACKAGE_VERSION = @PACKAGE_VERSION@ # the list of source files SOURCES = vm.el SOURCES += vm-autoload.el SOURCES += vm-avirtual.el SOURCES += vm-biff.el SOURCES += vm-crypto.el SOURCES += vm-delete.el SOURCES += vm-digest.el SOURCES += vm-edit.el SOURCES += vm-folder.el SOURCES += vm-grepmail.el SOURCES += vm-imap.el SOURCES += vm-license.el SOURCES += vm-macro.el SOURCES += vm-mark.el SOURCES += vm-menu.el SOURCES += vm-message.el SOURCES += vm-message-history.el SOURCES += vm-mime.el SOURCES += vm-minibuf.el SOURCES += vm-misc.el SOURCES += vm-motion.el SOURCES += vm-mouse.el SOURCES += vm-page.el SOURCES += vm-pcrisis.el SOURCES += vm-pgg.el SOURCES += vm-pine.el SOURCES += vm-pop.el SOURCES += vm-ps-print.el SOURCES += vm-reply.el SOURCES += vm-dired.el SOURCES += vm-rfaddons.el SOURCES += vm-save.el SOURCES += vm-search.el SOURCES += vm-serial.el SOURCES += vm-sort.el SOURCES += vm-startup.el SOURCES += vm-summary.el SOURCES += vm-summary-faces.el SOURCES += vm-thread.el SOURCES += vm-toolbar.el SOURCES += vm-undo.el SOURCES += vm-user.el SOURCES += vm-vars.el SOURCES += vm-vcard.el SOURCES += vm-version.el SOURCES += vm-virtual.el SOURCES += vm-window.el SOURCES += vm-w3m.el SOURCES += vm-w3.el SOURCES += vcard.el SOURCES += tapestry.el SOURCES += u-vm-color.el # to list of object files ifeq (@EMACS_FLAVOR@,emacs) OBJECTS = vm-autoloads.elc vm-cus-load.elc else OBJECTS = auto-autoloads.elc custom-load.elc endif OBJECTS += $(SOURCES:.el=.elc) AUX_FILES = version.txt INSTALL_FILES += $(OBJECTS:.elc=.el) $(OBJECTS) INSTALL_FILES += $(AUX_FILES) # for autoload generation AUTOLOAD_PACKAGE_NAME = (setq autoload-package-name \"vm\") AUTOLOAD_FILE = (setq generated-autoload-file \"./auto-autoloads.el\") ############################################################################## # location of required programms RM = @RM@ LS = @LS@ XARGS = @XARGS@ INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_DATA = @INSTALL_DATA@ prefix = @prefix@ top_srcdir = @top_srcdir@ srcdir = @srcdir@ datadir= @datadir@ datarootdir= @datarootdir@ lispdir = @lispdir@ pixmapdir= @pixmapdir@ EMACS_PROG = @EMACS_PROG@ EMACS_FLAVOR = @EMACS_FLAVOR@ FLAGS = @FLAGS@ EMACS_COMP = lispdir="$(lispdir)" srcdir="$(srcdir)" "$(EMACS_PROG)" $(FLAGS) export OTHERDIRS = @OTHERDIRS@ SYMLINKS = @SYMLINKS@ LINKPATH = @LINKPATH@ .el.elc: "$(EMACS_PROG)" $(FLAGS) -f batch-byte-compile $< ############################################################################## all: $(OBJECTS) install: install-el install-elc install-aux ############################################################################## vm-version.elc: vm-version.el version.txt version.txt: echo "\"$(PACKAGE_VERSION)\"" > $@ ############################################################################## # GNU Emacs's vm-autoload file # We use tr -d because Emacs under Cygwin apparently outputs CRLF # under Windows. We remove the CRs. # Solaris 8's tr -d '\r' removes r's so we use '\015' instead. # the echo command can also emit CRs. vm-autoloads.el: $(SOURCES:%=@srcdir@/%) -$(RM) -f $@ echo > $@ (build_dir="`pwd`"; cd "@srcdir@"; \ "$(EMACS_PROG)" $(FLAGS) -l autoload \ -f vm-built-autoloads "@abs_builddir@/$@" "`pwd`") echo "(custom-add-load 'vm 'vm-cus-load)" | tr -d '\015' >> $@ echo "(setq vm-configure-datadir \"${datadir}/vm\")" | tr -d '\015' >> $@ echo "(setq vm-configure-pixmapdir \"${pixmapdir}\")" | tr -d '\015' >> $@ echo "(setq vm-configure-docdir \"${docdir}\")" | tr -d '\015' >> $@ echo "(setq vm-configure-infodir \"${infodir}\")" | tr -d '\015' >> $@ echo "(require 'vm-vars)" | tr -d '\015' >> $@ echo "(provide 'vm-autoloads)" | tr -d '\015' >> $@ vm-cus-load.el: $(SOURCES:%=@srcdir@/%) "$(EMACS_PROG)" $(FLAGS) -f vm-custom-make-dependencies . ifeq (@EMACS_VERSION@,21) sed -e "s/provide 'cus-load/provide 'vm-cus-load/" cus-load.el > $@ $(RM) cus-load.el endif ############################################################################## # XEmacs#s auto-autoloads and custom-load file auto-autoloads.el: $(SOURCES:%=@srcdir@/%) -$(RM) -f $@ # (build_dir=`pwd`; cd "@srcdir@"; \ # $(EMACS_PROG) $(FLAGS) -l autoload \ # -f vm-built-autoloads "@abs_builddir@/$@" "`pwd`") "$(EMACS_PROG)" $(FLAGS) \ -eval "$(AUTOLOAD_PACKAGE_NAME)" \ -eval "$(AUTOLOAD_FILE)" \ -l autoload -f batch-update-autoloads $^ # avoid getting an error about an already loaded vm-autoloads mv $@ $@.tmp echo "(setq features (delete 'vm-autoloads features))" > $@ cat $@.tmp >> $@ echo "(setq features (delete 'vm-autoloads features))" >> $@ echo "(require 'vm-vars)" >> $@ echo "(setq vm-configure-datadir \"${datadir}\")" >> $@ echo "(setq vm-configure-pixmapdir \"${pixmapdir}\")" >> $@ $(RM) $@.tmp custom-load.el: $(SOURCES:%=@srcdir@/%) "$(EMACS_PROG)" $(FLAGS) -f vm-custom-make-dependencies . ############################################################################## install-pkg: all $(INSTALL_FILES) @if test "x$(SYMLINKS)" = "xno" ; then \ mkdir -p -m 0755 $(DESTDIR)$(PACKAGEDIR); \ for i in $(SOURCES:%=@srcdir@/%) $(INSTALL_FILES) ; do \ echo "Installing $$i in $(DESTDIR)$(PACKAGEDIR)" ; \ $(INSTALL_DATA) $$i $(DESTDIR)$(PACKAGEDIR) ; \ done ; \ else \ if test "x$(LINKPATH)" = "x" ; then \ $(LN_S) "`pwd`" $(DESTDIR)$(PACKAGEDIR) ; \ else \ $(LN_S) $(LINKPATH)/lisp $(DESTDIR)$(PACKAGEDIR) ; \ fi ; \ fi @echo VM ELISP files successfully installed\! # This entry will never install .el files if there are no .elc files. install-el: all $(INSTALL_FILES) $(INSTALL) -d -m 0755 "$(DESTDIR)$(lispdir)/" for elc in *.elc; do \ el=`basename $$elc c`; \ if test -f "$(srcdir)/$$el"; then \ echo "Install $$el in $(DESTDIR)$(lispdir)/"; \ $(INSTALL_DATA) "${srcdir}/$$el" "$(DESTDIR)$(lispdir)/"; \ fi; \ done; if $(LS) $(contrib)/*.elc > /dev/null 2>&1; then \ for elc in $(contribdir)/*.elc; do \ el=`basename $$elc c`; \ if test -f "${srcdir}/$(contribdir)/$$el"; then \ echo "Install $(contribdir)/$$el in $(DESTDIR)$(lispdir)/"; \ $(INSTALL_DATA) "${srcdir}/$(contribdir)/$$el" "$(DESTDIR)$(lispdir)/"; \ fi; \ done; \ fi; install-elc: all $(INSTALL_FILES) $(INSTALL) -d -m 0755 "$(DESTDIR)$(lispdir)/" for elc in *.elc; do \ echo "Install $$elc in $(DESTDIR)$(lispdir)/"; \ $(INSTALL_DATA) $$elc "$(DESTDIR)$(lispdir)/"; \ done; if $(LS) $(contribdir)/*.elc > /dev/null 2>&1; then \ for elc in $(contribdir)/*.elc; do \ echo "Install $$elc in $(DESTDIR)$(lispdir)"; \ $(INSTALL_DATA) $$elc "$(DESTDIR)$(lispdir)"; \ done; \ fi; install-aux: $(AUX_FILES) $(INSTALL) -d -m 0755 "$(DESTDIR)$(lispdir)/" for i in $(AUX_FILES); do \ echo "Install $$i in $(DESTDIR)$(lispdir)/"; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(lispdir)/"; \ done; ############################################################################## Makefile: @srcdir@/Makefile.in cd .. ; ./config.status ############################################################################## clean: -$(RM) -f version.txt *.elc vm-autoloads.el auto-autoloads.el custom-load.el distclean: clean -$(RM) -f Makefile vm-8.2.0b/lisp/tapestry.el0000755000175000017500000005164411676442161015750 0ustar srivastasrivasta;;; tapestry.el --- Tools to configure your GNU Emacs windows ;; ;; This file is part of VM ;; ;; Copyright (C) 1991, 1993, 1994, 1995, 1997 Kyle E. Jones ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'tapestry) (defvar tapestry-version "1.09") ;; Pass state information between the tapestry-set-window-map ;; and tapestry-set-buffer-map stages. UGH. The reason for this ;; is explained in tapestry-set-buffer-map. (defvar tapestry-windows-changed nil) ;;;###autoload (defun tapestry (&optional frame-list) "Returns a list containing complete information about the current configuration of Emacs frames, windows, buffers and cursor positions. Call the function set-tapestry with the list that this function returns to restore the configuration. Optional first arg FRAME-LIST should be a list of frames; only configuration information about these frames will be returned. The configuration information is returned in a form that can be saved and restored across multiple Emacs sessions." (let ((frames (or frame-list (tapestry-frame-list))) (frame-map (tapestry-frame-map)) (sf (tapestry-selected-frame)) (other-maps nil)) (unwind-protect (while frames (tapestry-select-frame (car frames)) (setq other-maps (cons (list (tapestry-window-map) (tapestry-buffer-map) (tapestry-position-map)) other-maps) frames (cdr frames))) (tapestry-select-frame sf)) (list frame-map other-maps))) ;;;###autoload (defun set-tapestry (map &optional n root-window-edges) "Restore the frame/window/buffer configuration described by MAP, which should be a list previously returned by a call to tapestry. Optional second arg N causes frame reconfiguration to be skipped and the windows of the current frame will configured according to the window map of the Nth frame in MAP. Optional third arg ROOT-WINDOW-EDGES non-nil should be a list containing the edges of a window in the current frame. This list should be in the same form as returned by the `window-edges' function. The window configuration from MAP will be restored in this window. If no window with these exact edges exists, a window that lies entirely within the edge coordinates will be expanded until the edge coordinates match or the window bounded by ROOT-WINDOW-EDGES is entirely contained within the expanded window. If no window entirely within the ROOT-WINDOW-EDGES edge coordinates can be found, the window with the greatest overlap of ROOT-WINDOW-EDGES will be used." (let ((sf (tapestry-selected-frame)) (tapestry-windows-changed nil) frame-list frame-map other-maps other-map) (setq frame-map (nth 0 map) other-maps (nth 1 map)) (if (and root-window-edges (null n)) (setq n 1)) (if n (let (first-window) (setq other-map (nth (1- n) other-maps)) (if (null other-map) (error "No such map, %d" n)) (setq first-window (tapestry-set-window-map (nth 0 other-map) root-window-edges)) (tapestry-set-buffer-map (nth 1 other-map) first-window) (tapestry-set-position-map (nth 2 other-map) first-window)) (tapestry-set-frame-map frame-map) ;; frame list is reversed relative to the map order because ;; created frames are added to the head of the list instead ;; of the tail. (setq frame-list (nreverse (tapestry-frame-list))) (unwind-protect (while other-maps (tapestry-select-frame (car frame-list)) (tapestry-set-window-map (nth 0 (car other-maps))) (tapestry-set-buffer-map (nth 1 (car other-maps))) (tapestry-set-position-map (nth 2 (car other-maps))) (setq other-maps (cdr other-maps) frame-list (cdr frame-list))) (and (tapestry-frame-live-p sf) (tapestry-select-frame sf)))))) (defun tapestry-frame-map () (let ((map (mapcar 'tapestry-frame-parameters (tapestry-frame-list))) list cell frame-list) (setq list map frame-list (tapestry-frame-list)) (while list (setq cell (assq 'minibuffer (car list))) (if (and cell (windowp (cdr cell))) (if (eq (tapestry-window-frame (cdr cell)) (car frame-list)) (setcdr cell t) (setcdr cell 'none))) (setq list (cdr list) frame-list (cdr frame-list))) map )) (defun tapestry-set-frame-map (map) ;; some parameters can only be set only at frame creation time. ;; so all existing frames must die. (let ((doomed-frames (tapestry-frame-list))) (while map (tapestry-make-frame (car map)) (setq map (cdr map))) (while doomed-frames (tapestry-delete-frame (car doomed-frames)) (setq doomed-frames (cdr doomed-frames))))) (defun tapestry-window-map () (let (maps map0 map1 map0-edges map1-edges x-unchanged y-unchanged) (setq maps (mapcar 'tapestry-window-edges (tapestry-window-list))) (while (cdr maps) (setq map0 maps) (while (cdr map0) (setq map1 (cdr map0) map0-edges (tapestry-find-window-map-edges (car map0)) map1-edges (tapestry-find-window-map-edges (car map1)) x-unchanged (and (= (car map0-edges) (car map1-edges)) (= (nth 2 map0-edges) (nth 2 map1-edges))) y-unchanged (and (= (nth 1 map0-edges) (nth 1 map1-edges)) (= (nth 3 map0-edges) (nth 3 map1-edges)))) (cond ((and (not x-unchanged) (not y-unchanged)) (setq map0 (cdr map0))) ((or (and x-unchanged (eq (car (car map0)) '-)) (and y-unchanged (eq (car (car map0)) '|))) (nconc (car map0) (list (car map1))) (setcdr map0 (cdr map1))) (t (setcar map0 (list (if x-unchanged '- '|) (car map0) (car map1))) (setcdr map0 (cdr map1)))))) (car maps))) (defun tapestry-set-window-map (map &optional root-window-edges) (let ((map-width (tapestry-compute-map-width map)) (map-height (tapestry-compute-map-height map)) (root-window nil)) (if root-window-edges (let (w-list w-edges w-area exact-w inside-w overlap-w max-overlap overlap) (while (null root-window) (setq exact-w nil inside-w nil overlap-w nil max-overlap -1 w-list (tapestry-window-list)) (while w-list (setq w-edges (tapestry-window-edges (car w-list)) w-area (tapestry-window-area w-edges)) (if (equal w-edges root-window-edges) (setq exact-w (car w-list) w-list nil) (setq overlap (tapestry-window-overlap w-edges root-window-edges) overlap (if overlap (tapestry-window-area overlap) 0) w-area (tapestry-window-area w-edges)) (if (< max-overlap overlap) (setq max-overlap overlap overlap-w (car w-list))) ;; set inside-w each time we find a window inside ;; the root window edges. FSF Emacs gives space ;; to the window above or to the left if there is ;; such a window. therefore we want to find the ;; inside window that is bottom-most or right-most so that ;; when we delete it, its space will be given to ;; what will be the root window. (if (= w-area overlap) (setq inside-w (car w-list))) (setq w-list (cdr w-list)))) (cond (exact-w (setq root-window exact-w)) (inside-w ;; how could a window be inside the root window ;; edges and there only be one window? a ;; multi-line minibuffer, that's how! (if (not (one-window-p t)) (delete-window inside-w))) (t (setq root-window overlap-w)))) (tapestry-apply-window-map map map-width map-height root-window) (setq tapestry-windows-changed t) root-window ) (if (tapestry-windows-match-map map map-width map-height) (tapestry-first-window) (delete-other-windows) (setq root-window (selected-window)) (tapestry-apply-window-map map map-width map-height root-window) (setq tapestry-windows-changed t) root-window )))) (defun tapestry-buffer-map () (let ((w-list (tapestry-window-list)) b list) (while w-list (setq b (window-buffer (car w-list)) list (cons (list (buffer-file-name b) (buffer-name b)) list) w-list (cdr w-list))) (nreverse list))) ;; This version of tapestry-set-buffer-map unconditionally set ;; the window buffer. This confused XEmacs 19.14's scroll-up ;; function when scrolling VM presentation buffers. ;; end-of-buffer was never signaled after a scroll. You can ;; duplicate this by creating a buffer that can be displayed ;; fully in the current window and then run ;; ;; (progn ;; (set-window-buffer (selected-window) (current-buffer)) ;; (scroll-up nil)) ;;;;;;;;;;; ;;(defun tapestry-set-buffer-map (buffer-map &optional first-window) ;; (let ((w-list (tapestry-window-list first-window)) wb) ;; (while (and w-list buffer-map) ;; (setq wb (car buffer-map)) ;; (set-window-buffer ;; (car w-list) ;; (if (car wb) ;; (or (get-file-buffer (car wb)) ;; (find-file-noselect (car wb))) ;; (get-buffer-create (nth 1 wb)))) ;; (setq w-list (cdr w-list) ;; buffer-map (cdr buffer-map))))) (defun tapestry-set-buffer-map (buffer-map &optional first-window) (let ((w-list (tapestry-window-list first-window)) current-wb proposed-wb cell) (while (and w-list buffer-map) (setq cell (car buffer-map) proposed-wb (if (car cell) (or (get-file-buffer (car cell)) (find-file-noselect (car cell))) (get-buffer-create (nth 1 cell))) current-wb (window-buffer (car w-list))) ;; Setting the window buffer to the same value it already ;; has seems to confuse XEmacs' scroll-up function. But ;; _not_ setting it after windows torn down seem to cause ;; window point to sometimes drift away from point at ;; redisplay time. The solution (hopefully!) is to track ;; when windows have been rearranged and unconditionally do ;; the set-window-buffer, otherwise do it only if the ;; window buffer and the proposed window buffer differ. (if (or tapestry-windows-changed (not (eq proposed-wb current-wb))) (set-window-buffer (car w-list) proposed-wb)) (setq w-list (cdr w-list) buffer-map (cdr buffer-map))))) (defun tapestry-position-map () (let ((sw (selected-window)) (w-list (tapestry-window-list)) list) (while w-list (setq list (cons (list (window-start (car w-list)) (window-point (car w-list)) (window-hscroll (car w-list)) (eq (car w-list) sw)) list) w-list (cdr w-list))) (nreverse list))) (defun tapestry-set-position-map (position-map &optional first-window) (let ((w-list (tapestry-window-list first-window)) (osw (selected-window)) sw p) (while (and w-list position-map) (setq p (car position-map)) (and (car p) (set-window-start (car w-list) (car p))) (and (nth 1 p) (set-window-point (car w-list) (nth 1 p))) (and (nth 2 p) (set-window-hscroll (car w-list) (nth 2 p))) (and (nth 3 p) (setq sw (car w-list))) ;; move this buffer up in the buffer-list (select-window (car w-list)) (setq w-list (cdr w-list) position-map (cdr position-map))) (select-window (or sw osw)))) (defun tapestry-apply-window-map (map map-width map-height current-window &optional root-window-width root-window-height) (let ((window-min-height 1) (window-min-width 1) horizontal) (if (null root-window-width) (setq root-window-height (window-height current-window) root-window-width (window-width current-window))) (while map (cond ((numberp (car map)) (setq map nil)) ((eq (car map) '-) (setq horizontal nil)) ((eq (car map) '|) (setq horizontal t)) (t (if (cdr map) (split-window current-window (if horizontal (/ (* (tapestry-compute-map-width (car map)) root-window-width) map-width) (/ (* (tapestry-compute-map-height (car map)) root-window-height) map-height)) horizontal)) (if (not (numberp (car (car map)))) (setq current-window (tapestry-apply-window-map (car map) map-width map-height current-window root-window-width root-window-height))) (and (cdr map) (setq current-window (next-window current-window 0))))) (setq map (cdr map))) current-window )) (defun tapestry-windows-match-map (map &optional map-width map-height window-map window-map-width window-map-height) (or map-width (setq map-width (tapestry-compute-map-width map) map-height (tapestry-compute-map-height map))) (or window-map (setq window-map (tapestry-window-map) window-map-height (tapestry-compute-map-height window-map) window-map-width (tapestry-compute-map-width window-map))) (let ((result t)) (cond ((numberp (car map)) (and (numberp (car window-map)) (= (/ (* (nth 0 map) window-map-width) map-width) (nth 0 window-map)) (= (/ (* (nth 1 map) window-map-height) map-height) (nth 1 window-map)) (= (/ (* (nth 2 map) window-map-width) map-width) (nth 2 window-map)) (= (/ (* (nth 3 map) window-map-height) map-height) (nth 3 window-map)))) ((eq (car map) '-) (if (not (eq (car window-map) '-)) nil (setq map (cdr map) window-map (cdr window-map)) (while (and result map window-map) (setq result (tapestry-windows-match-map (car map) map-width map-height (car window-map) window-map-width window-map-height) map (cdr map) window-map (cdr window-map))) (and result (null map) (null window-map)))) ((eq (car map) '|) (if (not (eq (car window-map) '|)) nil (setq map (cdr map) window-map (cdr window-map)) (while (and result map window-map) (setq result (tapestry-windows-match-map (car map) map-width map-height (car window-map) window-map-width window-map-height) map (cdr map) window-map (cdr window-map))) (and result (null map) (null window-map))))))) (defun tapestry-find-window-map-edges (map) (let (nw-edges se-edges) (setq nw-edges map) (while (and (consp nw-edges) (not (numberp (car nw-edges)))) (setq nw-edges (car (cdr nw-edges)))) (setq se-edges map) (while (and (consp se-edges) (not (numberp (car se-edges)))) (while (cdr se-edges) (setq se-edges (cdr se-edges))) (setq se-edges (car se-edges))) (if (eq nw-edges se-edges) nw-edges (setq nw-edges (copy-sequence nw-edges)) (setcdr (nthcdr 1 nw-edges) (nthcdr 2 se-edges)) nw-edges ))) (defun tapestry-compute-map-width (map) (let ((edges (tapestry-find-window-map-edges map))) (- (nth 2 edges) (car edges)))) (defun tapestry-compute-map-height (map) (let ((edges (tapestry-find-window-map-edges map))) (- (nth 3 edges) (nth 1 edges)))) ;; delq is to memq as delassq is to assq (defun tapestry-delassq (elt list) (let ((prev nil) (curr list)) (while curr (if (eq elt (car (car curr))) (if (null prev) (setq list (cdr list) curr list) (setcdr prev (cdr curr)) (setq curr (cdr curr))) (setq prev curr curr (cdr curr)))) list )) ;;;###autoload (defun tapestry-remove-frame-parameters (map params) (let (frame-map) (while params (setq frame-map (nth 0 map)) (while frame-map (setcar frame-map (tapestry-delassq (car params) (car frame-map))) (setq frame-map (cdr frame-map))) (setq params (cdr params))))) ;;;###autoload (defun tapestry-nullify-tapestry-elements (map &optional buf-file-name buf-name window-start window-point window-hscroll selected-window) (let (p) (setq map (nth 1 map)) (while map (setq p (nth 1 (car map))) (while p (and buf-file-name (setcar (car p) nil)) (and buf-name (setcar (cdr (car p)) nil)) (setq p (cdr p))) (setq p (nth 2 (car map))) (while p (and window-start (setcar (car p) nil)) (and window-point (setcar (cdr (car p)) nil)) (and window-hscroll (setcar (nthcdr 2 (car p)) nil)) (and selected-window (setcar (nthcdr 3 (car p)) nil)) (setq p (cdr p))) (setq map (cdr map))))) ;;;###autoload (defun tapestry-replace-tapestry-element (map what function) (let (mapi mapj p old new) (cond ((eq what 'buffer-file-name) (setq mapi 1 mapj 0)) ((eq what 'buffer-name) (setq mapi 1 mapj 1)) ((eq what 'window-start) (setq mapi 2 mapj 0)) ((eq what 'window-point) (setq mapi 2 mapj 1)) ((eq what 'window-hscroll) (setq mapi 2 mapj 2)) ((eq what 'selected-window) (setq mapi 2 mapj 3))) (setq map (nth 1 map)) (while map (setq p (nth mapi (car map))) (while p (setq old (nth mapj (car p)) new (funcall function old)) (if (not (equal old new)) (setcar (nthcdr mapj (car p)) new)) (setq p (cdr p))) (setq map (cdr map))))) (defun tapestry-window-list (&optional first-window) (let* ((first-window (or first-window (tapestry-first-window))) (windows (cons first-window nil)) (current-cons windows) (w (next-window first-window 'nomini))) (while (not (eq w first-window)) (setq current-cons (setcdr current-cons (cons w nil))) (setq w (next-window w 'nomini))) windows )) (defun tapestry-first-window () (if (eq (tapestry-selected-frame) (tapestry-window-frame (minibuffer-window))) (next-window (minibuffer-window)) (let ((w (selected-window)) (top (or (cdr (assq 'menu-bar-lines (tapestry-frame-parameters))) 0)) edges) (while (or (not (= 0 (car (setq edges (tapestry-window-edges w))))) ;; >= instead of = because in FSF Emacs 19.2x ;; (whenever the Lucid menubar code was added) the ;; menu-bar-lines frame parameter == 1 when the ;; Lucid menubar is enabled even though the ;; menubar doesn't steal the first line from the ;; window. (not (>= top (nth 1 edges)))) (setq w (next-window w 'nomini))) w ))) (defun tapestry-window-area (edges) (* (- (nth 3 edges) (nth 1 edges)) (- (nth 2 edges) (nth 0 edges)))) (defun tapestry-window-overlap (e0 e1) (let (top left bottom right) (cond ((and (<= (nth 0 e0) (nth 0 e1)) (< (nth 0 e1) (nth 2 e0))) (setq left (nth 0 e1))) ((and (<= (nth 0 e1) (nth 0 e0)) (< (nth 0 e0) (nth 2 e1))) (setq left (nth 0 e0)))) (cond ((and (< (nth 0 e0) (nth 2 e1)) (<= (nth 2 e1) (nth 2 e0))) (setq right (nth 2 e1))) ((and (< (nth 0 e1) (nth 2 e0)) (<= (nth 2 e0) (nth 2 e1))) (setq right (nth 2 e0)))) (cond ((and (<= (nth 1 e0) (nth 1 e1)) (< (nth 1 e1) (nth 3 e0))) (setq top (nth 1 e1))) ((and (<= (nth 1 e1) (nth 1 e0)) (< (nth 1 e0) (nth 3 e1))) (setq top (nth 1 e0)))) (cond ((and (< (nth 1 e0) (nth 3 e1)) (<= (nth 3 e1) (nth 3 e0))) (setq bottom (nth 3 e1))) ((and (< (nth 1 e1) (nth 3 e0)) (<= (nth 3 e0) (nth 3 e1))) (setq bottom (nth 3 e0)))) (and left top right bottom (list left top right bottom)))) (defun tapestry-window-edges (&optional window) (if (and (fboundp 'window-pixel-edges) (fboundp 'face-width) (fboundp 'face-height)) (let ((edges (window-pixel-edges window)) tmp) (setq tmp edges) (setcar tmp (/ (car tmp) (face-width 'default))) (setq tmp (cdr tmp)) (setcar tmp (/ (car tmp) (face-height 'default))) (setq tmp (cdr tmp)) (setcar tmp (/ (car tmp) (face-width 'default))) (setq tmp (cdr tmp)) (setcar tmp (/ (car tmp) (face-height 'default))) edges ) (window-edges window))) ;; We call these functions instead of calling the Emacs 19 frame ;; functions directly to let this package work with v18 Emacs. (defun tapestry-frame-list () (if (fboundp 'frame-list) (frame-list) (list nil))) (defun tapestry-frame-parameters (&optional f) (if (fboundp 'frame-parameters) (frame-parameters f) nil )) (defun tapestry-window-frame (w) (if (fboundp 'window-frame) (window-frame w) nil )) (defun tapestry-modify-frame-parameters (f alist) (if (fboundp 'modify-frame-parameters) (modify-frame-parameters f alist) nil )) (defun tapestry-select-frame (f) (if (fboundp 'select-frame) (select-frame f) nil )) (defun tapestry-selected-frame () (if (fboundp 'selected-frame) (selected-frame) nil )) (defun tapestry-next-frame (&optional f all) (if (fboundp 'next-frame) (next-frame f all) nil )) (defun tapestry-make-frame (&optional alist) (if (fboundp 'make-frame) (make-frame alist) nil )) (defun tapestry-delete-frame (&optional f) (if (fboundp 'delete-frame) (delete-frame f) nil )) (defun tapestry-frame-live-p (f) (if (fboundp 'frame-live-p) (frame-live-p f) t )) ;;; tapestry.el ends here vm-8.2.0b/lisp/vm-ps-print.el0000755000175000017500000004107211676442160016262 0ustar srivastasrivasta;;; vm-ps-print.el --- PS-printing functions for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1999 Robert Fenk ;; ;; Author: Robert Fenk ;; Status: Tested with XEmacs 21.4.15 & VM 7.18 ;; Keywords: extensions, vm, ps-print ;; X-URL: http://www.robf.de/Hacking/elisp ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; ;; There are three new user functions for generating postscript output: ;; vm-ps-print-message ;; vm-ps-print-each-message ;; vm-ps-print-message-preview ;; The first one prints like vm-ps-print, but multiple messages are ;; concatenated to one printout. In contrast to this the second ;; function creates one print job for each message. Finally the the ;; third one prints the current message as displayed in the ;; presentation buffer -- the other two functions do their own MIME ;; decoding therefore messages are always display in their default ;; appearance. ;; ;; To use these functions you should put this file into your load-path ;; and add the following lines to your .vm file: ;; ;; (require 'vm-ps-print) ;; ;; To redefine the default VM settings for the tool bar and menu add ;; the following line. The default is to use `vm-ps-print-message', ;; but if you use an optional non nil argument you will get ;; `vm-ps-print-each-message' as print function. ;; ;; (vm-ps-print-message-infect-vm) ;; ;; This will refine the default VM settings and from now on you should ;; be able to print to your postscript printer by using the usual VM ;; commands. ;; Of course you still have to set `lpr-command' and `lpr-switches' or ;; `ps-lpr-command' and `ps-lpr-switches' to reasonable values! ;; ;;; Code: (provide 'vm-ps-print) (eval-when-compile (require 'ps-print) (require 'vm-save) (require 'vm-folder) (require 'vm-summary) (require 'vm-mime)) (declare-function vm-marked-messages "vm-mark" ()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; group already defined in vm-vars.el ;; (defgroup vm nil ;; "VM" ;; :group 'mail) ;; (defgroup vm-psprint nil ;; "The VM ps-print lib" ;; :group 'vm) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defcustom vm-ps-print-message-function 'ps-print-buffer-with-faces "*This should point to the function which is used for ps-printing. The function should accept one optional argument which is a filename." :group 'vm-print :type 'function) ;;;###autoload (defcustom vm-ps-print-message-separater "\n" "*The separator between messages when printing multiple messages." :group 'vm-print :type 'string) ;;;###autoload (defcustom vm-ps-print-message-font-size 10 "*The font size for the PS-output of the message text." :group 'vm-print :type 'integer) ;;---------------------------------------------------------------------------- ;;;###autoload (defcustom vm-ps-print-message-header-lines 2 "*See `ps-header-lines'." :group 'vm-print :type 'integer) ;;;###autoload (defcustom vm-ps-print-message-left-header '(list (format "(Folder `%s')" folder-name) (format "(%d message%s printed)" mcount (if (= mcount 1) "" "s"))) "*This variable should contain a command returning a valid `ps-left-header'." :group 'vm-print :type 'sexp) ;;;###autoload (defcustom vm-ps-print-message-right-header '(list"/pagenumberstring load" 'dd-mon-yyyy) "*This variable should contain a command returning a valid `ps-right-header'. The defaults to the number of pages and the date of the printout." :group 'vm-print :type 'sexp) ;;;###autoload (defcustom vm-ps-print-message-summary-format (concat "******************************************************************************\n" (if (boundp 'vm-summary-format) vm-summary-format "%n %*%a %-17.17F %-3.3m %2d %4l/%-5c %I\"%s\"\n") "******************************************************************************\n") "*The summary line before a message. See `vm-summary-format' for a description of the conversion specifiers." :group 'vm-print :type 'string) ;;---------------------------------------------------------------------------- ;;;###autoload (defcustom vm-ps-print-each-message-header-lines 2 "*See `ps-header-lines'." :group 'vm-print :type 'integer) ;;;###autoload (defcustom vm-ps-print-each-message-left-header '(list (format "(Folder `%s')" folder-name) (format "(%s)" (vm-ps-print-tokenized-summary msg (vm-summary-sprintf vm-ps-print-each-message-summary-format msg t)))) "*This command should return a valid `ps-left-header'. The default is to have the folder name and a summary according to the variable `vm-ps-print-each-message-summary-format' in the left header." :group 'vm-print :type 'sexp) ;;;###autoload (defcustom vm-ps-print-each-message-right-header '(list "/pagenumberstring load" 'dd-mon-yyyy) "*This variable should contain a command returning a valid `ps-right-header'. The defaults to the number of pages and the date of the printout." :group 'vm-print :type 'sexp) ;;;###autoload (defcustom vm-ps-print-each-message-summary-format "Message# %n, Lines %l, Characters %c" "*The summary line for the postscript header. See `vm-summary-format' for a description of the conversion specifiers." :group 'vm-print :type 'string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-ps-print-message-internal (filename each folder-name mcount msg) "This function does the actual call to the ps-printing function. This is not a function to call interactively! If the customization of headers is insufficient, then you may want to modify this function. If FILENAME is a string, then the output is written to that file. If EACH is t then create a new johb for each message. FOLDER-NAME specifies the folder name which is displayed in the header line and MCOUNT is the number of messages to print, while MSG is a VM message pointer. See: `vm-ps-print-message-function'" (let* ((dd-mon-yyyy (format-time-string "%d %b %Y %T" (current-time))) (ps-left-header (if each (eval vm-ps-print-each-message-left-header) (eval vm-ps-print-message-left-header))) (ps-right-header (if each (eval vm-ps-print-each-message-right-header) (eval vm-ps-print-message-right-header))) (ps-header-lines (if each vm-ps-print-each-message-header-lines vm-ps-print-each-message-header-lines)) (ps-print-header-frame t) (ps-font-size vm-ps-print-message-font-size)) ; (setq filename (expand-file-name "~/mail.ps")) (funcall vm-ps-print-message-function filename) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-ps-print-tokenized-summary (message tokens) "Return the summary string for MESSAGE according to the format in TOKENS. Like `vm-tokenized-summary-insert'." (if (stringp tokens) tokens (let (token summary) (while tokens (setq token (car tokens)) (cond ((stringp token) (if vm-display-using-mime (setq summary (concat summary (vm-decode-mime-encoded-words-in-string token))) (setq summary (concat summary token)))) ((eq token 'number) (setq summary (concat summary (vm-padded-number-of message)))) ((eq token 'mark) (setq summary (concat summary (vm-su-mark message)))) ((eq token 'thread-indent) (if (and vm-summary-show-threads (natnump vm-summary-thread-indent-level)) (setq summary (concat summary ?\ (* vm-summary-thread-indent-level (vm-thread-indentation message))))))) (setq tokens (cdr tokens))) summary))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-ps-print-message-folder-name () "Return a nice folder name, without complete path." (let* ((folder-name (or (buffer-file-name) (buffer-name))) (folder-name (if (and vm-folder-directory (string-match (concat (regexp-quote (expand-file-name vm-folder-directory)) "/?\\(.+\\)") folder-name)) (substring folder-name (match-beginning 1) (match-end 2)) folder-name))) folder-name)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-ps-print-message (&optional count filename each) "PS-Print the current message. A positive COUNT arg N means print the current message and the next N-1 messages and a negative one print the current message and the previous N-1 messages. If FILENAME is specified then write PS into that file. When printing a single message it acts like `vm-ps-print-each-message'. When printing multiple messages it will insert a summary line according to the variable `vm-ps-print-message-summary-format' and a separator according to the variable `vm-ps-print-message-separater' between messages. You might force the printing of one job per message, by giving a t EACH argument. See: `vm-ps-print-message-function' `vm-ps-print-message-font-size' `vm-ps-print-message-summary-format' `vm-ps-print-message-separater' `vm-ps-print-message-left-header' `vm-ps-print-message-right-header' for customization of the output." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (or count (setq count 1)) (let* ((vm-summary-enable-faces nil) (folder-name (vm-ps-print-message-folder-name)) (mstart nil) (m nil) (mlist (vm-select-operable-messages count (vm-interactive-p) "Print")) (mcount (length mlist)) (tmpbuf (get-buffer-create "*vm-ps-print*"))) (vm-retrieve-operable-messages count mlist) (set-buffer tmpbuf) (setq major-mode 'vm-mode) (erase-buffer) (if (= mcount 1) (setq each 1)) (while mlist (setq m (vm-real-message-of (car mlist))) (if (not each) (vm-tokenized-summary-insert m (vm-summary-sprintf vm-ps-print-message-summary-format m t))) (setq mstart (point-max)) (vm-insert-region-from-buffer (vm-buffer-of m) (vm-vheaders-of m) (vm-end-of m)) (vm-reorder-message-headers nil :keep-list vm-visible-headers :discard-regexp vm-invisible-header-regexp) (vm-decode-mime-encoded-words) (goto-char mstart) (re-search-forward "\n\n") ;; skip headers (if (not (vm-mime-plain-message-p m)) (progn (vm-decode-mime-layout (vm-mm-layout m)) (delete-region (point) (point-max)))) (narrow-to-region mstart (point-max)) (vm-energize-urls) (vm-highlight-headers) (widen) (goto-char (point-max)) (if each (progn (save-excursion (vm-ps-print-message-internal filename t folder-name mcount m)) (set-buffer tmpbuf) (erase-buffer)) (if (> (length mlist) 1) (insert vm-ps-print-message-separater))) (setq mlist (cdr mlist))) (if (not each) (vm-ps-print-message-internal filename nil folder-name mcount nil)) (kill-buffer tmpbuf) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-ps-print-each-message (&optional count filename) "PS-Print the current message. A positive COUNT arg N means print the current message and the next N-1 messages and a negative one print the current message and the previous N-1 messages. If FILENAME is specified then write PS into that file. This function acts like `vm-ps-print-message', but it will generate a separate print job for each message and it does not generate the summary lines between messages. See: `vm-ps-print-message-function' `vm-ps-print-message-font-size' `vm-ps-print-each-message-separater' `vm-ps-print-each-message-left-header' `vm-ps-print-each-message-right-header' `vm-ps-print-each-message-summary-format' for customization of the output." (interactive "p") (vm-ps-print-message count filename t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-ps-print-message-presentation (&optional filename) "PS-Print the currently presented message. When called with a numeric prefix argument, prompts the user for the name of a file to save the PostScript image in, instead of sending it to the printer. More specifically, the FILENAME argument is treated as follows: if it is nil, send the image to the printer. If FILENAME is a string, save the PostScript image in a file with that name. If FILENAME is a number, prompt the user for the name of the file to save in. See: `vm-ps-print-message-function' `vm-ps-print-message-font-size' `vm-ps-print-each-message-separater' `vm-ps-print-each-message-left-header' `vm-ps-print-each-message-right-header' `vm-ps-print-each-message-summary-format' for customization of the output." (interactive (list (ps-print-preprint current-prefix-arg))) (save-excursion (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((folder-name (vm-ps-print-message-folder-name)) (mcount 1) (msg (car vm-message-pointer))) (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) (set-buffer (symbol-value 'vm-mail-buffer))) (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) (vm-ps-print-message-internal filename t folder-name mcount msg) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-ps-print-message-fix-menu (menu each) "Fix VM-menu MENU. If EACH it t, then replace `vm-print-message' by 'vm-ps-print-each-message', otherwise by `vm-ps-print-message'." (let ((tmpbuf (get-buffer-create "*vm-ps-print*"))) (save-excursion (set-buffer tmpbuf) (erase-buffer) (insert (format "(setq %s '%S)" (symbol-name menu) (symbol-value menu))) (if (re-search-backward "vm-\\(ps-\\)?print-\\(each-\\)?message" (point-min) t) (if each (replace-match "vm-print-each-message") (replace-match "vm-ps-print-message"))) (eval-buffer) (kill-buffer tmpbuf) ))) ;;;###autoload (defun vm-ps-print-message-infect-vm (&optional each) "Call this function to hook the ps-printing functions into VM. Arranges that the usual VM printing commands in menus and the toolbar use `vm-ps-print-message' or `vm-ps-print-each-message' (when EACH is t) instead of `vm-print-message'." (interactive) (if each (fset 'vm-toolbar-print-command 'vm-ps-print-each-message) (fset 'vm-toolbar-print-command 'vm-ps-print-message)) (require 'vm-version) (require 'vm-menu) (vm-ps-print-message-fix-menu 'vm-menu-dispose-menu each) (vm-ps-print-message-fix-menu 'vm-menu-vm-menu each) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From: "Jeffrey J. Kosowsky" ;;;###autoload (defun vm-ps-print-marked (&optional filename seperate nup color) "Postscript print all marked emails in mail Summary. If no messages marked, print just the current message. Optionally write postscript output to FILENAME (default is to spool to printer). Optionally force SEPERATE printing of each message by setting to 't'. Optionally also print NUP pages per sheet. Optionally also print in COLOR by setting to non-nil. Note when run interactively setting a positive prefix number prints NUP pages per sheet to the printer, while negative number prints NUP pages per sheet to queried FILENAME. No prefix prints 1 page per sheet to printer while prefix without numerical argument simply queries for filename and formats 1 page per sheet. (JJK)" (interactive (if (and (integerp current-prefix-arg) (plusp current-prefix-arg)) nil (list (ps-print-preprint current-prefix-arg)))) (let ((last-command) (ps-print-color-p color) (ps-n-up-printing (cond (nup nup) ((integerp current-prefix-arg) (abs current-prefix-arg)) (t 1))) ; default 1 page per sheet ) (and (vm-marked-messages) (setq last-command 'vm-next-command-uses-marks)) (vm-ps-print-message nil filename seperate))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; vm-ps-print.el ends here vm-8.2.0b/lisp/vm-page.el0000755000175000017500000012637211676442160015431 0ustar srivastasrivasta;;; vm-page.el --- Commands to move around within a VM message ;; ;; This file is part of VM ; ;; Copyright (C) 1989-1997 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-page) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-folder) (require 'vm-summary) (require 'vm-thread) (require 'vm-window) (require 'vm-motion) (require 'vm-menu) (require 'vm-mouse) (require 'vm-mime) (require 'vm-undo) ) (declare-function vm-make-virtual-copy "vm-virtual" (message)) (declare-function vm-make-presentation-copy "vm-mime" (message)) (declare-function vm-decode-mime-message "vm-mime" (&optional state)) (declare-function vm-mime-plain-message-p "vm-mime" (message)) ;; (declare-funciton vm-mm-layout "vm-mime" (message)) (declare-function map-extents "vm-xemacs" (function &optional object from to maparg flags property value)) (declare-function find-face "vm-xemacs" (face-or-name)) (declare-function make-glyph "vm-xemacs" (&optional spec-list type)) (declare-function set-glyph-face "vm-xemacs" (glyph face)) (declare-function glyphp "vm-xemacs" (object)) (declare-function set-extent-begin-glyph "vm-xemacs" (extent begin-glyph &optional layout)) (declare-function highlight-headers "vm-xemacs" (start end hack-sig)) ;;;###autoload (defun vm-scroll-forward (&optional arg) "Scrolls forward a screenful of text. If the current message is being previewed, the message body is revealed. If at the end of the current message, moves to the next message iff the value of vm-auto-next-message is non-nil. Prefix argument N means scroll forward N lines." (interactive "P") (let (mp-changed needs-decoding (was-invisible nil)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (setq mp-changed (or (null vm-presentation-buffer) (not (equal (vm-number-of (car vm-message-pointer)) (with-current-buffer vm-presentation-buffer (vm-number-of (car vm-message-pointer))))))) ;; the following vodoo was added by USR for fixing the jumping ;; cursor problem in the summary window, reported on May 4, 2008 ;; in gnu.emacs.vm.info, title "Re: synchronization of vm buffers" ;; (if mp-changed (sit-for 0)) (when mp-changed (vm-present-current-message) (sit-for 0)) (setq needs-decoding (and vm-display-using-mime (not vm-mime-decoded) (not (vm-mime-plain-message-p (car vm-message-pointer))) vm-auto-decode-mime-messages (eq vm-system-state 'previewing))) (when vm-presentation-buffer (set-buffer vm-presentation-buffer)) ;; We are either in the Presentation buffer or the Folder buffer (let ((point (point)) (w (vm-get-visible-buffer-window (current-buffer)))) (unless (and w (vm-frame-totally-visible-p (vm-window-frame w))) (vm-display (current-buffer) t '(vm-scroll-forward vm-scroll-backward) (list this-command 'reading-message)) ;; window start sticks to end of clip region when clip ;; region moves back past it in the buffer. fix it. (setq w (vm-get-visible-buffer-window (current-buffer))) (if (= (window-start w) (point-max)) (set-window-start w (point-min))) (setq was-invisible t))) (if (or mp-changed was-invisible needs-decoding (and (eq vm-system-state 'previewing) (pos-visible-in-window-p (point-max) (vm-get-visible-buffer-window (current-buffer))))) (progn (unless was-invisible (let ((w (vm-get-visible-buffer-window (current-buffer))) old-w-start) (setq old-w-start (window-start w)) ;; save-excursion to avoid possible buffer change (save-excursion (vm-select-frame (window-frame w))) (vm-raise-frame (window-frame w)) (vm-display nil nil '(vm-scroll-forward vm-scroll-backward) (list this-command 'reading-message)) (setq w (vm-get-visible-buffer-window (current-buffer))) (and w (set-window-start w old-w-start)))) (cond ((eq vm-system-state 'previewing) (vm-show-current-message) ;; The window start marker sometimes drifts forward ;; because of something that vm-show-current-message ;; does. In Emacs 20, replacing ASCII chars with ;; multibyte chars seems to cause it, but I _think_ ;; the drift can happen in Emacs 19 and even ;; XEmacs for different reasons. So we reset the ;; start marker here, since it is an easy fix. (let ((w (vm-get-visible-buffer-window (current-buffer)))) (set-window-start w (point-min))))) (vm-howl-if-eom)) (let ((vmp vm-message-pointer) (msg-buf (current-buffer)) (h-diff 0) w old-w old-w-height old-w-start result) (when (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading) (setq old-w (vm-get-visible-buffer-window msg-buf) old-w-height (window-height old-w) old-w-start (window-start old-w)) (setq w (vm-get-visible-buffer-window msg-buf)) (vm-select-frame (window-frame w)) (vm-raise-frame (window-frame w)) (vm-display nil nil '(vm-scroll-forward vm-scroll-backward) (list this-command 'reading-message)) (setq w (vm-get-visible-buffer-window msg-buf)) (if (null w) (error "current window configuration hides the message buffer.") (setq h-diff (- (window-height w) old-w-height))) ;; must restore this since it gets clobbered by window ;; teardown and rebuild done by the window config stuff. (set-window-start w old-w-start) (setq old-w (selected-window)) (unwind-protect (progn (select-window w) (let ((next-screen-context-lines (+ next-screen-context-lines h-diff))) (while (eq (setq result (vm-scroll-forward-internal arg)) 'tryagain)) (cond ((and (not (eq result 'next-message)) vm-honor-page-delimiters) (vm-narrow-to-page) (goto-char (max (window-start w) (vm-text-of (car vmp)))) ;; This is needed because in some cases ;; the scroll-up call in vm-howl-if-emo ;; does not signal end-of-buffer when ;; it should unless we do this. This ;; sit-for most likely removes the need ;; for the (scroll-up 0) below, but ;; since the voodoo has worked this ;; long, it's probably best to let it ;; be. (sit-for 0) ;; This voodoo is required! For some ;; reason the 18.52 emacs display ;; doesn't immediately reflect the ;; clip region change that occurs ;; above without this mantra. (scroll-up 0))))) (select-window old-w)) (set-buffer msg-buf) (cond ((eq result 'next-message) (vm-next-message)) ((eq result 'end-of-message) (let ((vm-message-pointer vmp)) (vm-emit-eom-blurb))) (t (and (> (prefix-numeric-value arg) 0) (vm-howl-if-eom))))))) (unless vm-startup-message-displayed (vm-display-startup-message))) (defun vm-scroll-forward-internal (arg) (let ((direction (prefix-numeric-value arg)) (w (selected-window))) (condition-case error-data (progn (scroll-up arg) nil) ;; this looks like it should work, but doesn't because the ;; redisplay code is schizophrenic when it comes to updates. A ;; window position may no longer be visible but ;; pos-visible-in-window-p will still say it is because it was ;; visible before some window size change happened. ;; (progn ;; (if (and (> direction 0) ;; (pos-visible-in-window-p ;; (vm-text-end-of (car vm-message-pointer)))) ;; (signal 'end-of-buffer nil) ;; (scroll-up arg)) ;; nil ) (error (if (or (and (< direction 0) (> (point-min) (vm-text-of (car vm-message-pointer)))) (and (>= direction 0) (/= (point-max) (vm-text-end-of (car vm-message-pointer))))) (progn (vm-widen-page) (if (>= direction 0) (progn (forward-page 1) (set-window-start w (point)) nil ) (if (or (bolp) (not (save-excursion (beginning-of-line) (looking-at page-delimiter)))) (forward-page -1)) (beginning-of-line) (set-window-start w (point)) 'tryagain)) (if (eq (car error-data) 'end-of-buffer) (if vm-auto-next-message 'next-message (set-window-point w (point)) 'end-of-message))))))) ;; exploratory scrolling, what a concept. ;; ;; we do this because pos-visible-in-window-p checks the current ;; window configuration, while this exploratory scrolling forces ;; Emacs to recompute the display, giving us an up to the moment ;; answer about where the end of the message is going to be ;; visible when redisplay finally does occur. (defun vm-howl-if-eom () (let ((w (get-buffer-window (current-buffer)))) (and w (save-excursion (save-window-excursion (condition-case () (let ((next-screen-context-lines 0)) (select-window w) (save-excursion (save-window-excursion ;; scroll-fix.el replaces scroll-up and ;; doesn't behave properly when it hits ;; end of buffer. It does this! ;; (ding) ;; (message (get 'beginning-of-buffer 'error-message)) (let ((scroll-in-place-replace-original nil)) (scroll-up nil)))) nil) (error t)))) (= (vm-text-end-of (car vm-message-pointer)) (point-max)) (vm-emit-eom-blurb)))) (defun vm-emit-eom-blurb () "Prints a minibuffer message when the end of message is reached, but it is suppressed if the variable `vm-auto-next-message' is nil." (interactive) (if vm-auto-next-message (let ((vm-summary-uninteresting-senders-arrow "") (case-fold-search nil)) (vm-inform 6 (if (and (stringp vm-summary-uninteresting-senders) (string-match vm-summary-uninteresting-senders (vm-su-from (car vm-message-pointer)))) "End of message %s to %.50s..." "End of message %s from %.50s...") (vm-number-of (car vm-message-pointer)) (vm-summary-sprintf "%F" (car vm-message-pointer)))))) (defun vm-emit-mime-decoding-message (&rest args) (interactive) (when vm-emit-messages-for-mime-decoding (apply 'message args))) ;;;###autoload (defun vm-scroll-backward (&optional arg) "Scroll backward a screenful of text. Prefix N scrolls backward N lines." (interactive "P") (vm-scroll-forward (cond ((null arg) '-) ((consp arg) (list (- (car arg)))) ((numberp arg) (- arg)) ((symbolp arg) nil) (t arg)))) ;;;###autoload (defun vm-scroll-forward-one-line (&optional count) "Scroll forward one line. Prefix arg N means scroll forward N lines. Negative arg means scroll backward." (interactive "p") (vm-scroll-forward count)) ;;;###autoload (defun vm-scroll-backward-one-line (&optional count) "Scroll backward one line. Prefix arg N means scroll backward N lines. Negative arg means scroll forward." (interactive "p") (vm-scroll-forward (- count))) (defun vm-highlight-headers () (cond ((and vm-xemacs-p vm-use-lucid-highlighting) (require 'highlight-headers) ;; disable the url marking stuff, since VM has its own interface. (let ((highlight-headers-mark-urls nil) (highlight-headers-regexp (or vm-highlighted-header-regexp highlight-headers-regexp))) (highlight-headers (point-min) (point-max) t))) (vm-xemacs-p (let (e) (map-extents (function (lambda (e ignore) (when (vm-extent-property e 'vm-highlight) (vm-delete-extent e)) nil)) (current-buffer) (point-min) (point-max)) (goto-char (point-min)) (while (vm-match-header) (cond ((vm-match-header vm-highlighted-header-regexp) (setq e (vm-make-extent (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (vm-set-extent-property e 'face vm-highlighted-header-face) (vm-set-extent-property e 'vm-highlight t))) (goto-char (vm-matched-header-end))))) (vm-fsfemacs-p (let (o-lists p) (setq o-lists (overlay-lists) p (car o-lists)) (while p (when (overlay-get (car p) 'vm-highlight) (vm-delete-extent (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (when (overlay-get (car p) 'vm-highlight) (vm-delete-extent (car p))) (setq p (cdr p))) (goto-char (point-min)) (while (vm-match-header) (cond ((vm-match-header vm-highlighted-header-regexp) (setq p (make-overlay (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (overlay-put p 'face vm-highlighted-header-face) (overlay-put p 'vm-highlight t))) (goto-char (vm-matched-header-end))))))) ;;;###autoload (defun vm-energize-urls (&optional clean-only) (interactive "P") ;; Don't search too long in large regions. If the region is ;; large, search just the head and the tail of the region since ;; they tend to contain the interesting text. (let ((search-limit vm-url-search-limit) search-pairs n) (if (and search-limit (> (- (point-max) (point-min)) search-limit)) (setq search-pairs (list (cons (point-min) (+ (point-min) (/ search-limit 2))) (cons (- (point-max) (/ search-limit 2)) (point-max)))) (setq search-pairs (list (cons (point-min) (point-max))))) (cond (vm-xemacs-p (let (e) (map-extents (function (lambda (e ignore) (when (vm-extent-property e 'vm-url) (vm-delete-extent e)) nil)) (current-buffer) (point-min) (point-max)) (if clean-only (vm-inform 1 "Energy from urls removed!") (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) (setq n 1) (while (null (match-beginning n)) (vm-increment n)) (setq e (vm-make-extent (match-beginning n) (match-end n))) (vm-set-extent-property e 'vm-url t) (if vm-highlight-url-face (vm-set-extent-property e 'face vm-highlight-url-face)) (if vm-url-browser (let ((keymap (make-sparse-keymap)) (popup-function (if (save-excursion (goto-char (match-beginning n)) (looking-at "mailto:")) 'vm-menu-popup-mailto-url-browser-menu 'vm-menu-popup-url-browser-menu))) (define-key keymap 'button2 'vm-mouse-send-url-at-event) (if vm-popup-menu-on-mouse-3 (define-key keymap 'button3 popup-function)) (define-key keymap "\r" (function (lambda () (interactive) (vm-mouse-send-url-at-position (point))))) (vm-set-extent-property e 'vm-button t) (vm-set-extent-property e 'keymap keymap) (vm-set-extent-property e 'balloon-help 'vm-url-help) (vm-set-extent-property e 'highlight t) ;; for vm-continue-postponed-message (vm-set-extent-property e 'duplicable t) ))) (setq search-pairs (cdr search-pairs)))))) ((and vm-fsfemacs-p (fboundp 'overlay-put)) (let (o-lists o p) (setq o-lists (overlay-lists) p (car o-lists)) (while p (when (overlay-get (car p) 'vm-url) (vm-delete-extent (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (when (overlay-get (car p) 'vm-url) (vm-delete-extent (car p))) (setq p (cdr p))) (while search-pairs (goto-char (car (car search-pairs))) (while (re-search-forward vm-url-regexp (cdr (car search-pairs)) t) (setq n 1) (while (null (match-beginning n)) (vm-increment n)) (setq o (make-overlay (match-beginning n) (match-end n))) (overlay-put o 'vm-url t) (if (facep vm-highlight-url-face) (overlay-put o 'face vm-highlight-url-face)) (if vm-url-browser (let ((keymap (make-sparse-keymap)) (popup-function (if (save-excursion (goto-char (match-beginning n)) (looking-at "mailto:")) 'vm-menu-popup-mailto-url-browser-menu 'vm-menu-popup-url-browser-menu))) (overlay-put o 'vm-button t) (overlay-put o 'mouse-face 'highlight) (setq keymap (nconc keymap (current-local-map))) (if vm-popup-menu-on-mouse-3 (define-key keymap [mouse-3] popup-function)) (define-key keymap "\r" (function (lambda () (interactive) (vm-mouse-send-url-at-position (point))))) (overlay-put o 'local-map keymap)))) (setq search-pairs (cdr search-pairs)))))))) (defun vm-energize-headers () (cond (vm-xemacs-p (let ((search-tuples '(("^From:" vm-menu-author-menu) ("^Subject:" vm-menu-subject-menu))) regexp menu keymap e) (map-extents (function (lambda (e ignore) (when (vm-extent-property e 'vm-header) (vm-delete-extent e)) nil)) (current-buffer) (point-min) (point-max)) (while search-tuples (goto-char (point-min)) (setq regexp (nth 0 (car search-tuples)) menu (symbol-value (nth 1 (car search-tuples)))) (while (re-search-forward regexp nil t) (save-excursion (goto-char (match-beginning 0)) (vm-match-header)) (setq e (vm-make-extent (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (vm-set-extent-property e 'vm-header t) (setq keymap (make-sparse-keymap)) ;; Might as well make button2 do what button3 does in ;; this case, since there is no default 'select' ;; action. (define-key keymap 'button2 (list 'lambda () '(interactive) (list 'popup-menu (list 'quote menu)))) (if vm-popup-menu-on-mouse-3 (define-key keymap 'button3 (list 'lambda () '(interactive) (list 'popup-menu (list 'quote menu))))) (vm-set-extent-property e 'keymap keymap) (vm-set-extent-property e 'balloon-help 'vm-mouse-3-help) (vm-set-extent-property e 'highlight t)) (setq search-tuples (cdr search-tuples))))) ((and vm-fsfemacs-p (fboundp 'overlay-put)) (let ((search-tuples '(("^From:" vm-menu-fsfemacs-author-menu) ("^Subject:" vm-menu-fsfemacs-subject-menu))) regexp menu o-lists o p) (setq o-lists (overlay-lists) p (car o-lists)) (while p (when (overlay-get (car p) 'vm-header) (vm-delete-extent (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (when (overlay-get (car p) 'vm-header) (vm-delete-extent (car p))) (setq p (cdr p))) (while search-tuples (goto-char (point-min)) (setq regexp (nth 0 (car search-tuples)) menu (symbol-value (nth 1 (car search-tuples)))) (while (re-search-forward regexp nil t) (goto-char (match-end 0)) (save-excursion (goto-char (match-beginning 0)) (vm-match-header)) (setq o (make-overlay (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (overlay-put o 'vm-header menu) (overlay-put o 'mouse-face 'highlight)) (setq search-tuples (cdr search-tuples))))))) (defun vm-display-xface () (cond (vm-xemacs-p (vm-display-xface-xemacs)) ((and vm-fsfemacs-p (and (stringp vm-uncompface-program) (fboundp 'create-image))) (vm-display-xface-fsfemacs)))) (defun vm-display-xface-xemacs () (let ((case-fold-search t) e g h) (if (map-extents (function (lambda (e ignore) (if (vm-extent-property e 'vm-xface) t nil))) (current-buffer) (point-min) (point-max)) nil (goto-char (point-min)) (if (find-face 'vm-xface) nil (make-face 'vm-xface) (set-face-background 'vm-xface "white") (set-face-foreground 'vm-xface "black")) (if (re-search-forward "^X-Face:" nil t) (progn (goto-char (match-beginning 0)) (vm-match-header) (setq h (concat "X-Face: " (vm-matched-header-contents))) (setq g (intern h vm-xface-cache)) (if (boundp g) (setq g (symbol-value g)) (set g (make-glyph (list (list 'global (cons '(tty) [nothing])) (list 'global (cons '(win) (vector 'xface ':data h)))))) (setq g (symbol-value g)) ;; XXX broken. Gives extra pixel lines at the ;; bottom of the glyph in 19.12 ;;(set-glyph-baseline g 100) (set-glyph-face g 'vm-xface)) (setq e (vm-make-extent (vm-vheaders-of (car vm-message-pointer)) (vm-vheaders-of (car vm-message-pointer)))) (vm-set-extent-property e 'vm-xface t) (set-extent-begin-glyph e g)))))) (defun vm-display-xface-fsfemacs () (catch 'done (let ((case-fold-search t) i g h ooo) (setq ooo (overlays-in (point-min) (point-max))) (while ooo (when (overlay-get (car ooo) 'vm-xface) (vm-delete-extent (car ooo))) (setq ooo (cdr ooo))) (goto-char (point-min)) (if (re-search-forward "^X-Face:" nil t) (progn (goto-char (match-beginning 0)) (vm-match-header) (setq h (vm-matched-header-contents)) (setq g (intern h vm-xface-cache)) (if (boundp g) (setq g (symbol-value g)) (setq i (vm-convert-xface-to-fsfemacs-image-instantiator h)) (cond (i (set g i) (setq g (symbol-value g))) (t (throw 'done nil)))) (let ((pos (vm-vheaders-of (car vm-message-pointer))) o ) ;; An image must replace the normal display of at ;; least one character. Since we want to put the ;; image at the beginning of the visible headers ;; section, it will obscure the first character of ;; that section. To display that character we add ;; an after-string that contains the character. ;; Kludge city, but it works. (setq o (make-overlay (+ 0 pos) (+ 1 pos))) (overlay-put o 'vm-xface t) (overlay-put o 'evaporate t) (overlay-put o 'after-string (char-to-string (char-after pos))) (overlay-put o 'display g))))))) (defun vm-convert-xface-to-fsfemacs-image-instantiator (data) (let ((work-buffer nil) retval) (catch 'done (unwind-protect (save-excursion (if (not (stringp vm-uncompface-program)) (throw 'done nil)) (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert data) (setq retval (apply 'call-process-region (point-min) (point-max) vm-uncompface-program t t nil (if vm-uncompface-accepts-dash-x '("-X") nil))) (if (not (eq retval 0)) (throw 'done nil)) (if vm-uncompface-accepts-dash-x (throw 'done (list 'image ':type 'xbm ':ascent 80 ':foreground "black" ':background "white" ':data (buffer-string)))) (if (not (stringp vm-icontopbm-program)) (throw 'done nil)) (goto-char (point-min)) (insert "/* Width=48, Height=48 */\n"); (setq retval (call-process-region (point-min) (point-max) vm-icontopbm-program t t nil)) (if (not (eq retval 0)) nil (list 'image ':type 'pbm ':ascent 80 ':foreground "black" ':background "white" ':data (buffer-string)))) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-url-help (object) (format "Use mouse button 2 to send the URL to %s. Use mouse button 3 to choose a Web browser for the URL." (cond ((stringp vm-url-browser) vm-url-browser) ((eq vm-url-browser 'w3-fetch) "Emacs W3") ((eq vm-url-browser 'w3-fetch-other-frame) "Emacs W3") ((eq vm-url-browser 'vm-mouse-send-url-to-mosaic) "Mosaic") ((eq vm-url-browser 'vm-mouse-send-url-to-netscape) "Netscape") (t (symbol-name vm-url-browser))))) ;;;###autoload (defun vm-energize-urls-in-message-region (&optional start end) (interactive "r") (save-excursion (or start (setq start (vm-headers-of (car vm-message-pointer)))) (or end (setq end (vm-text-end-of (car vm-message-pointer)))) ;; energize the URLs (if (or (facep vm-highlight-url-face) vm-url-browser) (save-restriction (widen) (narrow-to-region start end) (vm-energize-urls))))) (defun vm-highlight-headers-maybe () ;; highlight the headers (if (or vm-highlighted-header-regexp (and vm-xemacs-p vm-use-lucid-highlighting)) (save-restriction (widen) (narrow-to-region (vm-headers-of (car vm-message-pointer)) (vm-text-end-of (car vm-message-pointer))) (vm-highlight-headers)))) (defun vm-energize-headers-and-xfaces () ;; energize certain headers (if (and vm-use-menus (vm-menu-support-possible-p)) (save-restriction (widen) (narrow-to-region (vm-headers-of (car vm-message-pointer)) (vm-text-of (car vm-message-pointer))) (vm-energize-headers))) ;; display xfaces, if we can (if (and vm-display-xfaces (or (and vm-xemacs-p (featurep 'xface)) (and vm-fsfemacs-p (fboundp 'create-image) (stringp vm-uncompface-program)))) (save-restriction (widen) (narrow-to-region (vm-headers-of (car vm-message-pointer)) (vm-text-of (car vm-message-pointer))) (vm-display-xface)))) (defun vm-narrow-for-preview (&optional just-passing-through) "Hide as much of the message body as vm-preview-lines specifies. Optional argument JUST-PASSING-THROUGH says that no real preview is necessary." (widen) (narrow-to-region (vm-vheaders-of (car vm-message-pointer)) (cond ((not (eq vm-preview-lines t)) (min (vm-text-end-of (car vm-message-pointer)) (save-excursion (goto-char (vm-text-of (car vm-message-pointer))) (forward-line (if (natnump vm-preview-lines) vm-preview-lines 0)) ;; KLUDGE CITY: Under XEmacs, an extent's begin-glyph ;; will be displayed even if the extent is at the end ;; of a narrowed region. Thus a message containing ;; only an image will have the image displayed at ;; preview time even if vm-preview-lines is 0 provided ;; vm-mime-decode-for-preview is non-nil. We kludge ;; a fix for this by moving everything on the preview ;; cutoff line one character forward, but only if ;; we're doing MIME decode for preview. (if (and (not just-passing-through) vm-xemacs-p vm-mail-buffer ; in presentation buffer vm-auto-decode-mime-messages vm-mime-decode-for-preview ;; can't do the kludge unless we know that ;; when the message is exposed it will be ;; decoded and thereby remove the kludge. (not (vm-mime-plain-message-p (car vm-message-pointer)))) (let ((buffer-read-only nil)) (insert " ") (forward-char -1))) (point)))) (t (vm-text-end-of (car vm-message-pointer)))))) ;; This function was originally famous as `vm-preview-current-buffer', ;; but it was a misnomer because it does both previewing and showing. ;;;###autoload (defun vm-present-current-message () "Display the current message in the Presentation Buffer. A copy of the message is made in the Presentation Buffer and MIME decoding is done if necessary. The displayed content might be a preview or the full message, governed by the the variables `vm-preview-lines' and `vm-preview-read-messages'. USR,2010-01-14" ;; Set need-preview if the user needs to see the ;; message in the previewed state. Save some time later by not ;; doing preview action that the user will never see anyway. (let ((need-preview (and vm-preview-lines (or (vm-new-flag (car vm-message-pointer)) (vm-unread-flag (car vm-message-pointer)) vm-preview-read-messages)))) ;; (when vm-enable-external-messages ;; (when (not need-preview) ;; (vm-inform 1 "External messages cannot be previewed") ;; (setq need-preview nil))) (vm-save-buffer-excursion (setq vm-system-state 'previewing) (setq vm-mime-decoded nil) ;; 1. make sure that the message body is present (when (vm-body-to-be-retrieved-of (car vm-message-pointer)) (let ((mm (vm-real-message-of (car vm-message-pointer)))) (vm-retrieve-real-message-body mm :fetch t :register t))) (when vm-real-buffers (vm-make-virtual-copy (car vm-message-pointer))) ;; 2. run the message select hooks. (save-excursion (vm-select-folder-buffer) (when (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer))) (vm-run-hook-on-message 'vm-select-new-message-hook (car vm-message-pointer))) (when (and vm-select-unread-message-hook (vm-unread-flag (car vm-message-pointer))) (vm-run-hook-on-message 'vm-select-unread-message-hook (car vm-message-pointer)))) ;; 3. prepare the Presentation buffer (vm-narrow-for-preview (not need-preview)) (if (or vm-always-use-presentation vm-mime-display-function vm-fill-paragraphs-containing-long-lines (and vm-display-using-mime (not (vm-mime-plain-message-p (car vm-message-pointer))))) (let ((layout (vm-mm-layout (car vm-message-pointer)))) ;; This check is for Bug Report 740755. USR, 2011-12-24 (let ((new-layout (vm-mime-parse-entity-safe (car vm-message-pointer)))) (unless (vm-mime-layouts-equal layout new-layout) (when vm-debug (debug 'vm-present-message "Corruption of cached MIME layout (Bug 740755)?")))) (vm-make-presentation-copy (car vm-message-pointer)) (vm-save-buffer-excursion (vm-replace-buffer-in-windows (current-buffer) vm-presentation-buffer)) (set-buffer vm-presentation-buffer) (setq vm-system-state 'previewing) (vm-narrow-for-preview)) ;; never used because vm-always-use-presentation is t. ;; USR 2010-05-07 (setq vm-presentation-buffer nil) (and vm-presentation-buffer-handle (vm-replace-buffer-in-windows vm-presentation-buffer-handle (current-buffer)))) ;; at this point the current buffer is the presentation buffer ;; if we're using one for this message. (vm-unbury-buffer (current-buffer)) ;; (let ((real-m (car vm-message-pointer))) ;; (if (= (1+ (marker-position (vm-text-of real-m))) ;; (marker-position (vm-text-end-of real-m))) ;; (vm-inform 1 "must fetch the body of %s ..." (vm-imap-uid-of real-m)) ;; (vm-inform 1 "must NOT fetch the body of %s ..." (vm-imap-uid-of real-m)) ;; (let ((vm-message-pointer nil)) ;; (vm-discard-cached-data))) ;; )) ;; 4. decode MIME (if (and vm-display-using-mime vm-auto-decode-mime-messages vm-mime-decode-for-preview need-preview (if vm-mail-buffer (not (with-current-buffer vm-mail-buffer vm-mime-decoded)) (not vm-mime-decoded)) (not (vm-mime-plain-message-p (car vm-message-pointer)))) (if (eq vm-preview-lines 0) (progn (vm-decode-mime-message-headers (car vm-message-pointer)) (vm-energize-urls) (vm-highlight-headers-maybe) (vm-energize-headers-and-xfaces)) ;; restrict the things that are auto-displayed, since ;; decode-for-preview is meant to allow a numeric ;; vm-preview-lines to be useful in the face of multipart ;; messages. ;; But why restrict the external viewers? USR, 2011-02-08 (let ((vm-mime-auto-displayed-content-type-exceptions (cons "message/external-body" vm-mime-auto-displayed-content-type-exceptions)) ;; (vm-mime-external-content-types-alist nil) ) (condition-case data (progn (vm-decode-mime-message) ;; reset vm-mime-decoded so that when the user ;; opens the message completely, the full MIME ;; display will happen. ;; As an experiment, we turn off the double ;; decoding and see what happens. USR, 2010-02-01 (if (and vm-mime-decode-for-show vm-mail-buffer (vm-body-retrieved-of (car vm-message-pointer))) (with-current-buffer vm-mail-buffer (setq vm-mime-decoded nil))) ) (vm-mime-error (vm-set-mm-layout-display-error (vm-mime-layout-of (car vm-message-pointer)) (car (cdr data))) (vm-warn 0 2 "%s" (car (cdr data))))) (vm-narrow-for-preview))) ;; if no MIME decoding is needed (vm-energize-urls-in-message-region) (vm-highlight-headers-maybe) (vm-energize-headers-and-xfaces)) ;; 6. Go to the text of message (if (and vm-honor-page-delimiters need-preview) (vm-narrow-to-page)) (goto-char (vm-text-of (car vm-message-pointer))) ;; 7. If we have a window, set window start appropriately. (let ((w (vm-get-visible-buffer-window (current-buffer)))) (when w (set-window-start w (point-min)) (set-window-point w (vm-text-of (car vm-message-pointer))))) ;; 8. Show the full message if necessary (if need-preview (vm-update-summary-and-mode-line) (vm-show-current-message)))) (vm-run-hook-on-message 'vm-select-message-hook (car vm-message-pointer))) (defalias 'vm-preview-current-message 'vm-present-current-message) (defun vm-show-current-message () "Show the current message in the Presentation Buffer. MIME decoding is done if necessary. (USR, 2010-01-14)" ;; It looks like this function can be invoked in both the folder ;; buffer as well the presentation buffer, but we need to arrange ;; things so that it is always called in a presentation buffer. ;; (USR, 2010-05-04) (if (and vm-display-using-mime vm-auto-decode-mime-messages (not (vm-folder-buffer-value 'vm-mime-decoded)) (not (vm-mime-plain-message-p (car vm-message-pointer)))) (condition-case data (vm-decode-mime-message) (vm-mime-error (vm-set-mm-layout-display-error (vm-mime-layout-of (car vm-message-pointer)) (car (cdr data))) (vm-warn 0 2 "%s" (car (cdr data)))))) ;; FIXME this probably cause folder corruption by filling the folder instead ;; of the presentation copy ..., RWF, 2008-07 ;; Well, so, we will check if we are in a presentation buffer! ;; USR, 2010-01-07 (when (and (or vm-word-wrap-paragraphs vm-fill-paragraphs-containing-long-lines) (vm-mime-plain-message-p (car vm-message-pointer))) (if (null vm-mail-buffer) ; this can't be presentation then (if vm-always-use-presentation (progn (vm-make-presentation-copy (car vm-message-pointer)) (set-buffer vm-presentation-buffer)) ;; FIXME at this point, the folder buffer is being used for ;; display. Filling will corrupt the folder. (debug "VM internal error #2010. Please report it"))) (vm-save-restriction (widen) (vm-fill-paragraphs-containing-long-lines vm-fill-paragraphs-containing-long-lines (vm-text-of (car vm-message-pointer)) (vm-text-end-of (car vm-message-pointer))))) (vm-save-buffer-excursion (save-excursion (save-excursion (goto-char (point-min)) (widen) (narrow-to-region (point) (vm-text-end-of (car vm-message-pointer)))) (if vm-honor-page-delimiters (progn (if (looking-at page-delimiter) (forward-page 1)) (vm-narrow-to-page)))) ;; don't mark the message as read if the user can't see it! (if (vm-get-visible-buffer-window (current-buffer)) (progn (save-excursion (setq vm-system-state 'showing) (if vm-mail-buffer (with-current-buffer vm-mail-buffer (setq vm-system-state 'showing))) ;; We could be in the presentation buffer here. Since ;; the presentation buffer's message pointer and sole ;; message are a mockup, they will cause trouble if ;; passed into the undo/update system. So we switch ;; into the real message buffer to do attribute ;; updates. (vm-select-folder-buffer) (vm-run-hook-on-message 'vm-showing-message-hook (car vm-message-pointer)) (vm-set-new-flag (car vm-message-pointer) nil) (vm-set-unread-flag (car vm-message-pointer) nil)) (vm-update-summary-and-mode-line) (vm-howl-if-eom)) (vm-update-summary-and-mode-line))) ;; (if vm-summary-enable-thread-folding ;; (vm-toggle-thread 1)) ) ;;;###autoload (defun vm-expose-hidden-headers () "Toggle exposing and hiding message headers that are normally not visible." (interactive) (vm-follow-summary-cursor) (save-excursion (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-display nil nil '(vm-expose-hidden-headers) '(vm-expose-hidden-headers)) (vm-save-buffer-excursion (vm-replace-buffer-in-windows (current-buffer) vm-presentation-buffer)) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (let* ((exposed (= (point-min) (vm-start-of (car vm-message-pointer))))) (vm-widen-page) (goto-char (point-max)) (widen) (if exposed (narrow-to-region (point) (vm-vheaders-of (car vm-message-pointer))) (narrow-to-region (point) (vm-start-of (car vm-message-pointer)))) (goto-char (point-min)) (let (w) (setq w (vm-get-visible-buffer-window (current-buffer))) (and w (set-window-point w (point-min))) (and w (= (window-start w) (vm-vheaders-of (car vm-message-pointer))) (not exposed) (set-window-start w (vm-start-of (car vm-message-pointer))))) (if vm-honor-page-delimiters (vm-narrow-to-page)))) ) (defun vm-widen-page () (if (or (> (point-min) (vm-text-of (car vm-message-pointer))) (/= (point-max) (vm-text-end-of (car vm-message-pointer)))) (narrow-to-region (vm-vheaders-of (car vm-message-pointer)) (if (or (vm-new-flag (car vm-message-pointer)) (vm-unread-flag (car vm-message-pointer))) (vm-text-of (car vm-message-pointer)) (vm-text-end-of (car vm-message-pointer)))))) (defun vm-narrow-to-page () (cond (vm-fsfemacs-p (if (not (and vm-page-end-overlay (overlay-buffer vm-page-end-overlay))) (let ((g vm-page-continuation-glyph)) (setq vm-page-end-overlay (make-overlay (point) (point))) (vm-set-extent-property vm-page-end-overlay 'vm-glyph g) (vm-set-extent-property vm-page-end-overlay 'before-string g) (overlay-put vm-page-end-overlay 'evaporate nil)))) (vm-xemacs-p (if (not (and vm-page-end-overlay (vm-extent-end-position vm-page-end-overlay))) (let ((g vm-page-continuation-glyph)) (cond ((not (glyphp g)) (setq g (make-glyph g)) (set-glyph-face g 'italic))) (setq vm-page-end-overlay (vm-make-extent (point) (point))) (vm-set-extent-property vm-page-end-overlay 'vm-glyph g) (vm-set-extent-property vm-page-end-overlay 'begin-glyph g) (vm-set-extent-property vm-page-end-overlay 'detachable nil))))) (save-excursion (let (min max (e vm-page-end-overlay)) (if (or (bolp) (not (save-excursion (beginning-of-line) (looking-at page-delimiter)))) (forward-page -1)) (setq min (point)) (forward-page 1) (if (not (eobp)) (beginning-of-line)) (cond ((/= (point) (vm-text-end-of (car vm-message-pointer))) (vm-set-extent-property e vm-begin-glyph-property (vm-extent-property e 'vm-glyph)) (vm-set-extent-endpoints e (point) (point))) (t (vm-set-extent-property e vm-begin-glyph-property nil))) (setq max (point)) (narrow-to-region min max)))) ;;;###autoload (defun vm-beginning-of-message () "Moves to the beginning of the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (vm-widen-page) (push-mark) (vm-display (current-buffer) t '(vm-beginning-of-message) '(vm-beginning-of-message reading-message)) (vm-save-buffer-excursion (let ((osw (selected-window))) (unwind-protect (progn (select-window (vm-get-visible-buffer-window (current-buffer))) (goto-char (point-min))) (if (not (eq osw (selected-window))) (select-window osw))))) (if vm-honor-page-delimiters (vm-narrow-to-page))) ;;;###autoload (defun vm-end-of-message () "Moves to the end of the current message, exposing and flagging it read as necessary." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading) (vm-widen-page) (push-mark) (vm-display (current-buffer) t '(vm-end-of-message) '(vm-end-of-message reading-message)) (vm-save-buffer-excursion (let ((osw (selected-window))) (unwind-protect (progn (select-window (vm-get-visible-buffer-window (current-buffer))) (goto-char (point-max))) (if (not (eq osw (selected-window))) (select-window osw))))) (if vm-honor-page-delimiters (vm-narrow-to-page))) ;;;###autoload (defun vm-next-button (count) "Moves to the next button in the current message. Prefix argument N means move to the Nth next button. Negative N means move to the Nth previous button. If there is no next button, an error is signaled and point is not moved. A button is a highlighted region of text where pressing RETURN will produce an action. If the message is being previewed, it is exposed and marked as read." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading) (vm-widen-page) (vm-display (current-buffer) t '(vm-move-to-next-button) '(vm-move-to-next-button reading-message)) (select-window (vm-get-visible-buffer-window (current-buffer))) (unwind-protect (vm-move-to-xxxx-button (vm-abs count) (>= count 0)) (if vm-honor-page-delimiters (vm-narrow-to-page)))) (defalias 'vm-move-to-next-button 'vm-next-button) ;;;###autoload (defun vm-previous-button (count) "Moves to the previous button in the current message. Prefix argument N means move to the Nth previous button. Negative N means move to the Nth next button. If there is no previous button, an error is signaled and point is not moved. A button is a highlighted region of text where pressing RETURN will produce an action. If the message is being previewed, it is exposed and marked as read." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (setq vm-system-state 'reading) (vm-widen-page) (vm-display (current-buffer) t '(vm-move-to-previous-button) '(vm-move-to-previous-button reading-message)) (select-window (vm-get-visible-buffer-window (current-buffer))) (unwind-protect (vm-move-to-xxxx-button (vm-abs count) (< count 0)) (if vm-honor-page-delimiters (vm-narrow-to-page)))) (defalias 'vm-move-to-previous-button 'vm-previous-button) (defun vm-move-to-xxxx-button (count next) (let ((old-point (point)) (endp (if next 'eobp 'bobp)) (extent-end-position (if vm-xemacs-p (if next 'extent-end-position 'extent-start-position) (if next 'overlay-end 'overlay-start))) (next-extent-change (if vm-xemacs-p (if next 'next-extent-change 'previous-extent-change) (if next 'next-overlay-change 'previous-overlay-change))) e) (while (and (> count 0) (not (funcall endp))) (goto-char (funcall next-extent-change (+ (point) (if next 0 -1)))) (setq e (vm-extent-at (point))) (if e (progn (if (vm-extent-property e 'vm-button) (vm-decrement count)) (goto-char (funcall extent-end-position e))))) (if e (goto-char (vm-extent-start-position e)) (goto-char old-point) (error "No more buttons")))) ;;; vm-page.el ends here vm-8.2.0b/lisp/vcard.el0000755000175000017500000006666111676442161015201 0ustar srivastasrivasta;;; vcard.el --- vcard parsing and display routines ;; ;; This file is not part of VM; it is a utility used there. ;; ;; Copyright (C) 1997, 1999, 2000 Noah S. Friedman ;; Author: Noah Friedman ;; Maintainer: friedman@splode.com ;; Keywords: vcard, mail, news ;; Created: 1997-09-27 ;; $Id: vcard.el,v 1.11 2000/06/29 17:07:55 friedman Exp $ ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; Unformatted vcards are just plain ugly. But if you live in the MIME ;; world, they are a better way of exchanging contact information than ;; freeform signatures since the former can be automatically parsed and ;; stored in a searchable index. ;; ;; This library of routines provides the back end necessary for parsing ;; vcards so that they can eventually go into an address book like BBDB ;; (although this library does not implement that itself). Also included ;; is a sample pretty-printer which MUAs can use which do not provide their ;; own vcard formatters. ;; This library does not interface directly with any mail user agents. For ;; an example of bindings for the VM MUA, see vm-vcard.el available from ;; ;; http://www.splode.com/~friedman/software/emacs-lisp/index.html#mail ;; ;; Updates to vcard.el should be available there too. ;; The main entry point to this package is `vcard-pretty-print' although ;; any documented variable or function is considered part of the API for ;; operating on vcard data. ;; The vcard 2.1 format is defined by the versit consortium. ;; See http://www.imc.org/pdi/vcard-21.ps ;; ;; RFC 2426 defines the vcard 3.0 format. ;; See ftp://ftp.rfc-editor.org/in-notes/rfc2426.txt ;; A parsed vcard is a list of attributes of the form ;; ;; (proplist value1 value2 ...) ;; ;; Where proplist is a list of property names and parameters, e.g. ;; ;; (property1 (property2 . parameter2) ...) ;; ;; Each property has an associated implicit or explicit parameter value ;; (not to be confused with attribute values; in general this API uses ;; `parameter' to refer to property values and `value' to refer to attribute ;; values to avoid confusion). If a property has no explicit parameter value, ;; the parameter value is considered to be `t'. Any property which does not ;; exist for an attribute is considered to have a nil parameter. ;; TODO: ;; * Finish supporting the 3.0 extensions. ;; Currently, only the 2.1 standard is supported. ;; * Handle nested vcards and grouped attributes? ;; (I've never actually seen one of these in use.) ;; * Handle multibyte charsets. ;; * Inverse of vcard-parse-string: write .VCF files from alist ;; * Implement a vcard address book? Or is using BBDB preferable? ;; * Improve the sample formatter. ;;; Code: (defgroup vcard nil "Support for the vCard electronic business card format." :group 'vcard :group 'mail :group 'news) ;;;###autoload (defcustom vcard-pretty-print-function 'vcard-format-sample-box "*Formatting function used by `vcard-pretty-print'." :type 'function :group 'vcard) ;;;###autoload (defcustom vcard-standard-filters '(vcard-filter-html vcard-filter-adr-newlines vcard-filter-tel-normalize vcard-filter-textprop-cr) "*Standard list of filters to apply to parsed vcard data. These filters are applied sequentially to vcard attributes when the function `vcard-standard-filter' is supplied as the second argument to `vcard-parse'." :type 'hook :group 'vcard) ;;; No user-settable options below. ;; XEmacs 21 ints and chars are disjoint types. ;; For all else, treat them as the same. (defalias 'vcard-char-to-int (if (fboundp 'char-to-int) 'char-to-int 'identity)) ;; This is just the version number for this package; it does not refer to ;; the vcard format specification. Currently, this package does not yet ;; support the full vcard 3.0 specification. ;; ;; Whenever any part of the API defined in this package change in a way ;; that is not backward-compatible, the major version number here should be ;; incremented. Backward-compatible additions to the API should be ;; indicated by increasing the minor version number. (defconst vcard-api-version "2.0") ;; The vcard standards allow specifying the encoding for an attribute using ;; these values as immediate property names, rather than parameters of the ;; `encoding' property. If these are encountered while parsing, associate ;; them as parameters of the `encoding' property in the returned structure. (defvar vcard-encoding-tags '("quoted-printable" "base64" "8bit" "7bit")) ;; The vcard parser will auto-decode these encodings when they are ;; encountered. These methods are invoked via vcard-parse-region-value. (defvar vcard-region-decoder-methods '(("quoted-printable" . vcard-region-decode-quoted-printable) ("base64" . vcard-region-decode-base64))) ;; This is used by vcard-region-decode-base64 (defvar vcard-region-decode-base64-table (let* ((a "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") (len (length a)) (tbl (make-vector 123 nil)) (i 0)) (while (< i len) (aset tbl (vcard-char-to-int (aref a i)) i) (setq i (1+ i))) tbl)) ;;; This function can be used generically by applications to obtain ;;; a printable representation of a vcard. ;;;###autoload (defun vcard-pretty-print (vcard) "Format VCARD into a string suitable for display to user. VCARD can be an unparsed string containing raw VCF vcard data or a parsed vcard alist as returned by `vcard-parse-string'. The result is a string with formatted vcard information suitable for insertion into a mime presentation buffer. The function specified by the variable `vcard-pretty-print-function' actually performs the formatting. That function will always receive a parsed vcard alist." (and (stringp vcard) (setq vcard (vcard-parse-string vcard))) (funcall vcard-pretty-print-function vcard)) ;;; Parsing routines ;;;###autoload (defun vcard-parse-string (raw &optional filter) "Parse RAW vcard data as a string, and return an alist representing data. If the optional function FILTER is specified, apply that filter to each attribute. If no filter is specified, `vcard-standard-filter' is used. Filters should accept two arguments: the property list and the value list. Modifying in place the property or value list will affect the resulting attribute in the vcard alist. Vcard data is normally in the form begin: vcard prop1a: value1a prop2a;prop2b;prop2c=param2c: value2a prop3a;prop3b: value3a;value3b;value3c end: vcard \(Whitespace around the `:' separating properties and values is optional.\) If supplied to this function an alist of the form \(\(\(\"prop1a\"\) \"value1a\"\) \(\(\"prop2a\" \"prop2b\" \(\"prop2c\" . \"param2c\"\)\) \"value2a\"\) \(\(\"prop3a\" \"prop3b\"\) \"value3a\" \"value3b\" \"value3c\"\)\) would be returned." (let ((vcard nil) (buf (generate-new-buffer " *vcard parser work*"))) (unwind-protect (save-excursion (set-buffer buf) ;; Make sure last line is newline-terminated. ;; An extra trailing newline is harmless. (insert raw "\n") (setq vcard (vcard-parse-region (point-min) (point-max) filter))) (kill-buffer buf)) vcard)) ;;;###autoload (defun vcard-parse-region (beg end &optional filter) "Parse the raw vcard data in region, and return an alist representing data. This function is just like `vcard-parse-string' except that it operates on a region of the current buffer rather than taking a string as an argument. Note: this function modifies the buffer!" (or filter (setq filter 'vcard-standard-filter)) (let ((case-fold-search t) (vcard-data nil) (pos (make-marker)) (newpos (make-marker)) properties value) (save-restriction (narrow-to-region beg end) (save-match-data ;; Unfold folded lines and delete naked carriage returns (goto-char (point-min)) (while (re-search-forward "\r$\\|\n[ \t]" nil t) (goto-char (match-beginning 0)) (delete-char 1)) (goto-char (point-min)) (re-search-forward "^begin:[ \t]*vcard[ \t]*\n") (set-marker pos (point)) (while (and (not (looking-at "^end[ \t]*:[ \t]*vcard[ \t]*$")) (re-search-forward ":[ \t]*" nil t)) (set-marker newpos (match-end 0)) (setq properties (vcard-parse-region-properties pos (match-beginning 0))) (set-marker pos (marker-position newpos)) (re-search-forward "[ \t]*\n") (set-marker newpos (match-end 0)) (setq value (vcard-parse-region-value properties pos (match-beginning 0))) (set-marker pos (marker-position newpos)) (goto-char pos) (funcall filter properties value) (setq vcard-data (cons (cons properties value) vcard-data))))) (nreverse vcard-data))) (defun vcard-parse-region-properties (beg end) (downcase-region beg end) (let* ((proplist (vcard-split-string (buffer-substring beg end) ";")) (props proplist) split) (save-match-data (while props (cond ((string-match "=" (car props)) (setq split (vcard-split-string (car props) "=" 2)) (setcar props (cons (car split) (car (cdr split))))) ((member (car props) vcard-encoding-tags) (setcar props (cons "encoding" (car props))))) (setq props (cdr props)))) proplist)) (defun vcard-parse-region-value (proplist beg end) (let* ((encoding (vcard-get-property proplist "encoding")) (decoder (cdr (assoc encoding vcard-region-decoder-methods))) result pos match-beg match-end) (save-restriction (narrow-to-region beg end) (cond (decoder ;; Each `;'-separated field needs to be decoded and saved ;; separately; if the entire region were decoded at once, we ;; would not be able to distinguish between the original `;' ;; chars and those which were encoded in order to quote them ;; against being treated as field separators. (goto-char beg) (setq pos (set-marker (make-marker) (point))) (setq match-beg (make-marker)) (setq match-end (make-marker)) (save-match-data (while (< pos (point-max)) (cond ((search-forward ";" nil t) (set-marker match-beg (match-beginning 0)) (set-marker match-end (match-end 0))) (t (set-marker match-beg (point-max)) (set-marker match-end (point-max)))) (funcall decoder pos match-beg) (setq result (cons (buffer-substring pos match-beg) result)) (if (= match-beg match-end) (setq pos (point-max)) (set-marker pos (marker-position match-end))))) (setq result (nreverse result)) (vcard-set-property proplist "encoding" nil)) (t (setq result (vcard-split-string (buffer-string) ";"))))) (goto-char (point-max)) result)) ;;; Functions for retrieving property or value information from parsed ;;; vcard attributes. (defun vcard-values (vcard have-props &optional non-props limit) "Return the values in VCARD. This function is like `vcard-ref' and takes the same arguments, but return only the values, not the associated property lists." (mapcar 'cdr (vcard-ref vcard have-props non-props limit))) (defun vcard-ref (vcard have-props &optional non-props limit) "Return the attributes in VCARD with HAVE-PROPS properties. Optional arg NON-PROPS is a list of properties which candidate attributes must not have. Optional arg LIMIT means return no more than that many attributes. The attributes in VCARD which have all properties specified by HAVE-PROPS but not having any specified by NON-PROPS are returned. The first element of each attribute is the actual property list; the remaining elements are the values. If a specific property has an associated parameter \(e.g. an encoding\), use the syntax \(\"property\" . \"parameter\"\) to specify it. If property parameter is not important or it has no specific parameter, just specify the property name as a string." (let ((attrs vcard) (result nil) (count 0)) (while (and attrs (or (null limit) (< count limit))) (and (vcard-proplist-all-properties (car (car attrs)) have-props) (not (vcard-proplist-any-properties (car (car attrs)) non-props)) (setq result (cons (car attrs) result) count (1+ count))) (setq attrs (cdr attrs))) (nreverse result))) (defun vcard-proplist-all-properties (proplist props) "Returns nil unless PROPLIST contains all properties specified in PROPS." (let ((result t)) (while (and result props) (or (vcard-get-property proplist (car props)) (setq result nil)) (setq props (cdr props))) result)) (defun vcard-proplist-any-properties (proplist props) "Returns `t' if PROPLIST contains any of the properties specified in PROPS." (let ((result nil)) (while (and (not result) props) (and (vcard-get-property proplist (car props)) (setq result t)) (setq props (cdr props))) result)) (defun vcard-get-property (proplist property) "Return the value from PROPLIST of PROPERTY. PROPLIST is a vcard attribute property list, which is normally the first element of each attribute entry in a vcard." (or (and (member property proplist) t) (cdr (assoc property proplist)))) (defun vcard-set-property (proplist property value) "In PROPLIST, set PROPERTY to VALUE. PROPLIST is a vcard attribute property list. If VALUE is nil, PROPERTY is deleted." (let (elt) (cond ((null value) (vcard-delete-property proplist property)) ((setq elt (member property proplist)) (and value (not (eq value t)) (setcar elt (cons property value)))) ((setq elt (assoc property proplist)) (cond ((eq value t) (setq elt (memq elt proplist)) (setcar elt property)) (t (setcdr elt value)))) ((eq value t) (nconc proplist (cons property nil))) (t (nconc proplist (cons (cons property value) nil)))))) (defun vcard-delete-property (proplist property) "Delete from PROPLIST the specified property PROPERTY. This will not succeed in deleting the first member of the proplist, but that element should never be deleted since it is the primary key." (let (elt) (cond ((setq elt (member property proplist)) (delq (car elt) proplist)) ((setq elt (assoc property proplist)) (delq (car (memq elt proplist)) proplist))))) ;;; Vcard data filters. ;; ;;; Filters receive both the property list and value list and may modify ;;; either in-place. The return value from the filters are ignored. ;; ;;; These filters can be used for purposes such as removing HTML tags or ;;; normalizing phone numbers into a standard form. (defun vcard-standard-filter (proplist values) "Apply filters in `vcard-standard-filters' to attributes." (vcard-filter-apply-filter-list vcard-standard-filters proplist values)) ;; This function could be used to dispatch other filter lists. (defun vcard-filter-apply-filter-list (filter-list proplist values) (while filter-list (funcall (car filter-list) proplist values) (setq filter-list (cdr filter-list)))) ;; Some lusers put HTML (or even javascript!) in their vcards under the ;; misguided notion that it's a standard feature of vcards just because ;; Netscape supports this feature. That is wrong; the vcard specification ;; does not define any html content semantics and most MUAs cannot do ;; anything with html text except display them unparsed, which is ugly. ;; ;; Thank Netscape for abusing the standard and damned near rendering it ;; useless for interoperability between MUAs. ;; ;; This filter does a very rudimentary job. (defun vcard-filter-html (proplist values) "Remove HTML tags from attribute values." (save-match-data (while values (while (string-match "<[^<>\n]+>" (car values)) (setcar values (replace-match "" t t (car values)))) (setq values (cdr values))))) (defun vcard-filter-adr-newlines (proplist values) "Replace newlines with \"; \" in `adr' values." (and (vcard-get-property proplist "adr") (save-match-data (while values (while (string-match "[\r\n]+" (car values)) (setcar values (replace-match "; " t t (car values)))) (setq values (cdr values)))))) (defun vcard-filter-tel-normalize (proplist values) "Normalize telephone numbers in `tel' values. Spaces and hyphens are replaced with `.'. US domestic telephone numbers are replaced with international format." (and (vcard-get-property proplist "tel") (save-match-data (while values (while (string-match "[\t._-]+" (car values)) (setcar values (replace-match " " t t (car values)))) (and (string-match "^(?\\(\\S-\\S-\\S-\\))? ?\ \\(\\S-\\S-\\S- \\S-\\S-\\S-\\S-\\)" (car values)) (setcar values (replace-match "+1 \\1 \\2" t nil (car values)))) (setq values (cdr values)))))) (defun vcard-filter-textprop-cr (proplist values) "Strip carriage returns from text values." (and (vcard-proplist-any-properties proplist '("adr" "email" "fn" "label" "n" "org" "tel" "title" "url")) (save-match-data (while values (while (string-match "\r+" (car values)) (setcar values (replace-match "" t t (car values)))) (setq values (cdr values)))))) ;;; Decoding methods. (defmacro vcard-hexstring-to-ascii (s) (if (string-lessp emacs-version "20") `(format "%c" (car (read-from-string (format "?\\x%s" ,s)))) `(format "%c" (string-to-number ,s 16)))) (defun vcard-region-decode-quoted-printable (&optional beg end) (save-excursion (save-restriction (save-match-data (narrow-to-region (or beg (point-min)) (or end (point-max))) (goto-char (point-min)) (while (re-search-forward "=\n" nil t) (delete-region (match-beginning 0) (match-end 0))) (goto-char (point-min)) (while (re-search-forward "=[0-9A-Za-z][0-9A-Za-z]" nil t) (let ((s (buffer-substring (1+ (match-beginning 0)) (match-end 0)))) (replace-match (vcard-hexstring-to-ascii s) t t))))))) (defun vcard-region-decode-base64 (&optional beg end) (save-restriction (narrow-to-region (or beg (point-min)) (or end (point-max))) (save-match-data (goto-char (point-min)) (while (re-search-forward "[ \t\r\n]+" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) (let ((count 0) (n 0) (c nil)) (while (not (eobp)) (setq c (char-after (point))) (delete-char 1) (cond ((char-equal c ?=) (if (= count 2) (insert (lsh n -10)) ;; count must be 3 (insert (lsh n -16) (logand 255 (lsh n -8)))) (delete-region (point) (point-max))) (t (setq n (+ n (aref vcard-region-decode-base64-table (vcard-char-to-int c)))) (setq count (1+ count)) (cond ((= count 4) (insert (logand 255 (lsh n -16)) (logand 255 (lsh n -8)) (logand 255 n)) (setq n 0 count 0)) (t (setq n (lsh n 6)))))))))) (defun vcard-split-string (string &optional separator limit) "Split STRING at occurences of SEPARATOR. Return a list of substrings. Optional argument SEPARATOR can be any regexp, but anything matching the separator will never appear in any of the returned substrings. If not specified, SEPARATOR defaults to \"[ \\f\\t\\n\\r\\v]+\". If optional arg LIMIT is specified, split into no more than that many fields \(though it may split into fewer\)." (or separator (setq separator "[ \f\t\n\r\v]+")) (let ((string-list nil) (len (length string)) (pos 0) (splits 0) str) (save-match-data (while (<= pos len) (setq splits (1+ splits)) (cond ((and limit (>= splits limit)) (setq str (substring string pos)) (setq pos (1+ len))) ((string-match separator string pos) (setq str (substring string pos (match-beginning 0))) (setq pos (match-end 0))) (t (setq str (substring string pos)) (setq pos (1+ len)))) (setq string-list (cons str string-list)))) (nreverse string-list))) (defun vcard-copy-tree (tree) "Make a deep copy of nested conses." (cond ((consp tree) (cons (vcard-copy-tree (car tree)) (vcard-copy-tree (cdr tree)))) (t tree))) (defun vcard-flatten (l) (if (consp l) (apply 'nconc (mapcar 'vcard-flatten l)) (list l))) ;;; Sample formatting routines. (defun vcard-format-sample-box (vcard) "Like `vcard-format-sample-string', but put an ascii box around text." (let* ((lines (vcard-format-sample-lines vcard)) (len (vcard-format-sample-max-length lines)) (edge (concat "\n+" (make-string (+ len 2) ?-) "+\n")) (line-fmt (format "| %%-%ds |" len)) (formatted-lines (mapconcat (function (lambda (s) (format line-fmt s))) lines "\n"))) (if (string= formatted-lines "") formatted-lines (concat edge formatted-lines edge)))) (defun vcard-format-sample-string (vcard) "Format VCARD into a string suitable for display to user. VCARD should be a parsed vcard alist. The result is a string with formatted vcard information which can be inserted into a mime presentation buffer." (mapconcat 'identity (vcard-format-sample-lines vcard) "\n")) (defun vcard-format-sample-lines (vcard) (let* ((name (vcard-format-sample-get-name vcard)) (title (vcard-format-sample-values-concat vcard '("title") 1 "; ")) (org (vcard-format-sample-values-concat vcard '("org") 1 "; ")) (addr (vcard-format-sample-get-address vcard)) (tel (vcard-format-sample-get-telephone vcard)) (lines (delete nil (vcard-flatten (list name title org addr)))) (col-template (format "%%-%ds%%s" (vcard-format-sample-offset lines tel))) (l lines)) (while tel (setcar l (format col-template (car l) (car tel))) ;; If we stripped away too many nil slots from l, add empty strings ;; back in so setcar above will work on next iteration. (and (cdr tel) (null (cdr l)) (setcdr l (cons "" nil))) (setq l (cdr l)) (setq tel (cdr tel))) lines)) (defun vcard-format-sample-get-name (vcard) (let ((name (car (car (vcard-values vcard '("fn") nil 1)))) (email (car (vcard-format-sample-values vcard '((("email" "pref")) (("email" "internet")) (("email"))) 1)))) (cond ((and name email) (format "%s <%s>" name email)) (email) (name) ("")))) (defun vcard-format-sample-get-telephone (vcard) (let ((fields '(("Work: " (("tel" "work" "pref") . ("fax" "pager" "cell")) (("tel" "work" "voice") . ("fax" "pager" "cell")) (("tel" "work") . ("fax" "pager" "cell"))) ("Home: " (("tel" "home" "pref") . ("fax" "pager" "cell")) (("tel" "home" "voice") . ("fax" "pager" "cell")) (("tel" "home") . ("fax" "pager" "cell")) (("tel") . ("fax" "pager" "cell" "work"))) ("Cell: " (("tel" "cell" "pref")) (("tel" "cell"))) ("Fax: " (("tel" "pref" "fax")) (("tel" "work" "fax")) (("tel" "home" "fax")) (("tel" "fax"))))) (phones nil) result) (while fields (setq result (vcard-format-sample-values vcard (cdr (car fields)))) (while result (setq phones (cons (concat (car (car fields)) (car (car result))) phones)) (setq result (cdr result))) (setq fields (cdr fields))) (nreverse phones))) (defun vcard-format-sample-get-address (vcard) (let* ((addr (vcard-format-sample-values vcard '((("adr" "pref" "work")) (("adr" "pref")) (("adr" "work")) (("adr"))) 1)) (street (delete "" (list (nth 0 addr) (nth 1 addr) (nth 2 addr)))) (city-list (delete "" (nthcdr 3 addr))) (city (cond ((null (car city-list)) nil) ((cdr city-list) (format "%s, %s" (car city-list) (mapconcat 'identity (cdr city-list) " "))) (t (car city-list))))) (delete nil (if city (append street (list city)) street)))) (defun vcard-format-sample-values-concat (vcard have-props limit sep) (let ((l (car (vcard-values vcard have-props nil limit)))) (and l (mapconcat 'identity (delete "" (vcard-copy-tree l)) sep)))) (defun vcard-format-sample-values (vcard proplists &optional limit) (let ((result (vcard-format-sample-ref vcard proplists limit))) (if (equal limit 1) (cdr result) (mapcar 'cdr result)))) (defun vcard-format-sample-ref (vcard proplists &optional limit) (let ((result nil)) (while (and (null result) proplists) (setq result (vcard-ref vcard (car (car proplists)) (cdr (car proplists)) limit)) (setq proplists (cdr proplists))) (if (equal limit 1) (vcard-copy-tree (car result)) (vcard-copy-tree result)))) (defun vcard-format-sample-offset (row1 row2 &optional maxwidth) (or maxwidth (setq maxwidth (frame-width))) (let ((max1 (vcard-format-sample-max-length row1)) (max2 (vcard-format-sample-max-length row2))) (if (zerop max1) 0 (+ max1 (min 5 (max 1 (- maxwidth (+ max1 max2)))))))) (defun vcard-format-sample-max-length (strings) (let ((maxlen 0)) (while strings (setq maxlen (max maxlen (length (car strings)))) (setq strings (cdr strings))) maxlen)) (provide 'vcard) ;;; vcard.el ends here. vm-8.2.0b/lisp/vm-dired.el0000755000175000017500000001066011676442160015574 0ustar srivastasrivasta;;; vm-reply.el --- Mailing, forwarding, and replying commands ;; ;; This file is part of VM ;; ;; Copyright (C) 2011 Uday S. Reddy ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; This file provides functions that can be used in a Dired buffer to ;; send files to VM. ;;; Interface: ;; Interactive commands: ;; ;; vm-dired-attach-file: (buffer) -> unit ;; vm-dired-do-attach-files: (buffer) -> unit ;; ;;; Code: (provide 'vm-dired) (require 'dired) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-mime) (require 'vm-digest) (require 'vm-undo) ) (eval-and-compile (require 'dired)) (declare-function vm-dired-file-name-at-point "vm-dired.el" ()) (cond ((fboundp 'dired-file-name-at-point) ; Emacs 23 dired (fset 'vm-dired-file-name-at-point 'dired-file-name-at-point)) ((fboundp 'dired-filename-at-point) ; Emacs 22 dired-x (fset 'vm-dired-file-name-at-point 'dired-filename-at-point)) (t (error "vm-dired not supported in Emacs version %s" emacs-version))) ;;;###autoload (defun vm-dired-attach-file (composition) "Attach the file at point in the dired buffer to a VM composition buffer as a mime attachment. The file is not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. A visible tag indicating the existence of the object is placed in the composition buffer. You can move the object around or remove it entirely with normal text editing commands. If you remove the object tag, the object will not be sent. First argument COMPOSITION is the buffer into which the object will be inserted. When this function is called interactively COMPOSITION's name will be read from the minibuffer." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command)) (list (read-buffer "Attach file to buffer: " (vm-find-composition-buffer) t)))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (let ((file (vm-dired-file-name-at-point)) type) (when (and file (file-regular-p file)) (setq type (or (vm-mime-default-type-from-filename file) "application/octet-stream")) (with-current-buffer composition (vm-attach-file file type))))) ;;;###autoload (defun vm-dired-do-attach-files (composition) "Attach all marked files in the dired buffer to a VM composition buffer as mime attachments. The files are not inserted into the buffer and MIME encoded until you execute `vm-mail-send' or `vm-mail-send-and-exit'. For each file, a visible tag indicating the existence of the object is placed in the composition buffer. You can move the objects around or remove them entirely with normal text editing commands. If you remove an object tag, the object will not be sent. First argument COMPOSITION is the buffer into which the objects will be inserted. When this function is called interactively COMPOSITION's name will be read from the minibuffer." (interactive ;; protect value of last-command and this-command (let ((last-command last-command) (this-command this-command)) (list (read-buffer "Attach object to buffer: " (vm-find-composition-buffer) t)))) (unless vm-send-using-mime (error (concat "MIME attachments disabled, " "set vm-send-using-mime non-nil to enable."))) (dired-map-over-marks (let ((file (dired-get-filename)) type) (setq type (or (vm-mime-default-type-from-filename file) "application/octet-stream")) (with-current-buffer composition (vm-attach-file file type))) nil)) ;;; vm-dired.el ends here vm-8.2.0b/lisp/vm-minibuf.el0000755000175000017500000003420011676442160016132 0ustar srivastasrivasta;;; vm-minibuf.el --- Minibuffer read functions for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1993, 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-minibuf) (eval-when-compile (require 'vm-misc) (require 'vm-mouse) ) (declare-function button-press-event-p "vm-xemacs" (object)) (declare-function button-release-event-p "vm-xemacs" (object)) (declare-function menu-event-p "vm-xemacs" (object)) (declare-function vm-folder-buffers "vm" (&optional non-virtual)) (defun vm-minibuffer-complete-word (&optional exiting) (interactive) (let ((opoint (point)) ;; In Emacs 21, during a minibuffer read the minibuffer ;; contains the prompt as buffer text and that text is ;; read only. So we can no longer assume that (point-min) ;; is where the user-entered text starts and we must avoid ;; modifying that prompt text. The value we want instead ;; of (point-min) is (minibuffer-prompt-end). (point-min (if (fboundp 'minibuffer-prompt-end) (minibuffer-prompt-end) (point-min))) (case-fold-search completion-ignore-case) trimmed-c-list c-list beg end diff word word-prefix-regexp completion) ;; find the beginning and end of the word we're trying to complete (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ ))) (progn (skip-chars-backward " \t\n") (and (not (eobp)) (forward-char)) (setq end (point))) (skip-chars-forward "^ \t\n") (setq end (point))) ;; if there can't be multiple words in the input the beginning ;; of the word must be at point-min. (if (not vm-completion-auto-space) (setq beg point-min) (skip-chars-backward "^ \t\n") (setq beg (point))) (goto-char opoint) ;; copy the word into a string (setq word (buffer-substring beg end)) ;; trim the completion list down to just likely candidates ;; then convert it to an alist. (setq word-prefix-regexp (concat "^" (regexp-quote word)) trimmed-c-list (vm-delete-non-matching-strings word-prefix-regexp vm-minibuffer-completion-table) trimmed-c-list (sort trimmed-c-list (function string-lessp)) trimmed-c-list (mapcar 'list trimmed-c-list) c-list (mapcar 'list vm-minibuffer-completion-table)) ;; Try the word against the completion list. (and trimmed-c-list (setq completion (try-completion word trimmed-c-list))) ;; If completion is nil, figure out what prefix of the word would prefix ;; something in the completion list... but only if the user is interested. (if (and (null completion) vm-completion-auto-correct c-list) (let ((i -1)) (while (null (setq completion (try-completion (substring word 0 i) c-list))) (vm-decrement i)) (setq completion (substring word 0 i)))) ;; If completion is t, we had a perfect match already. (if (eq completion t) (cond (vm-completion-auto-space (goto-char end) (insert " ")) (t (and (not exiting) (vm-minibuffer-completion-message "[Sole completion]")))) ;; Compute the difference in length between the completion and the ;; word. A negative difference means no match and the magnitude ;; indicates the number of chars that need to be shaved off the end ;; before a match will occur. A positive difference means a match ;; occurred and the magnitude specifies the number of new chars that ;; can be appended to the word as a completion. ;; ;; `completion' can be nil here, but the code works anyway because ;; (length nil) still equals 0! (setq diff (- (length completion) (length word))) (cond ;; We have some completion chars. Insert them. ((or (> diff 0) (and completion (zerop diff) (not (string-equal completion word)))) (goto-char end) (delete-char (- (length word))) (insert completion) (if (and vm-completion-auto-space (null (cdr trimmed-c-list))) (insert " "))) ((null completion) (vm-minibuffer-completion-message "[No completion available]")) ;; The word prefixed more than one string, but we can't complete ;; any further. Either give help or say "Ambiguous". ((zerop diff) (and (not exiting) (cond ((> (length (car (car trimmed-c-list))) (length word)) (if (null completion-auto-help) (vm-minibuffer-completion-message "[Ambiguous]") (vm-minibuffer-show-completions (sort (mapcar 'car trimmed-c-list) 'string-lessp)))) ((not (eq last-command 'vm-minibuffer-complete-word)) (vm-minibuffer-completion-message "[Complete, but not unique]")) (vm-completion-auto-space (insert " "))))) ;; The word didn't prefix anything... if vm-completion-auto-correct is ;; non-nil strip the offending characters and try again. (vm-completion-auto-correct (goto-char end) (delete-char diff) (vm-minibuffer-complete-word exiting)) ;; if we're not auto-correcting and we're doing ;; multi-word, just let the user insert a space. (vm-completion-auto-space (insert " ")) ;; completion utterly failed, tell the user so. (t (and (not exiting) (vm-minibuffer-completion-message "[No match]"))))))) (defun vm-minibuffer-complete-word-and-exit () (interactive) (vm-minibuffer-complete-word t) (exit-minibuffer)) (defun vm-minibuffer-completion-message (string &optional seconds) "Briefly display STRING to the right of the current minibuffer input. Optional second arg SECONDS specifies how long to keep the message visible; the default is 2 seconds. A keypress causes the immediate erasure of the STRING, and return of control to the calling program." (let (omax (inhibit-quit t)) (save-excursion (goto-char (point-max)) (setq omax (point)) (insert " " string)) (sit-for (or seconds 2)) (delete-region omax (point-max)))) (defun vm-minibuffer-replace-word (word) (goto-char (point-max)) (skip-chars-backward "^ \t\n") (delete-region (point) (point-max)) (insert word)) (defun vm-minibuffer-show-completions (list) "Display LIST in a multi-column listing in the \" *Completions*\" buffer. LIST should be a list of strings." (save-excursion (set-buffer (get-buffer-create " *Completions*")) (setq buffer-read-only nil) (use-local-map (make-sparse-keymap)) ;; ignore vm-mutable-* here. the user shouldn't mind ;; because when they exit the minibuffer the windows will be ;; set right again. (display-buffer (current-buffer)) (erase-buffer) (insert "Possible completions are:\n") (setq buffer-read-only t) (vm-show-list list 'vm-minibuffer-replace-word (list (current-local-map) minibuffer-local-map)) (goto-char (point-min)))) (defun vm-show-list (list &optional function keymaps) "Display LIST in a multi-column listing in the current buffer at point. The current buffer must be displayed in some window at the time this function is called. LIST should be a list of strings. Optional second argument FUNCTION will be called if the mouse is clicked on one of the strings in the current buffer. The string clicked upon will be passed to FUNCTION as its sole argument. Optional third argument KEYMAPS specifies a lists of keymaps where the FUNCTION should be bound to the mouse clicks. By default the local keymap of the current buffer is used." (or keymaps (setq keymaps (and (current-local-map) (list (current-local-map))))) (save-excursion (let ((buffer-read-only nil) (separation 3) tabs longest positions columns list-length q i w start command keymap) (cond ((and function keymaps (vm-mouse-support-possible-p)) (setq command (list 'lambda '(e) '(interactive "e") (list 'let '((string (vm-mouse-get-mouse-track-string e))) (list 'and 'string (list function 'string))))) (while keymaps (setq keymap (car keymaps)) (cond ((vm-mouse-xemacs-mouse-p) (define-key keymap 'button1 command) (define-key keymap 'button2 command)) ((vm-mouse-fsfemacs-mouse-p) (define-key keymap [down-mouse-1] 'ignore) (define-key keymap [drag-mouse-1] 'ignore) (define-key keymap [mouse-1] command) (define-key keymap [drag-mouse-2] 'ignore) (define-key keymap [down-mouse-2] 'ignore) (define-key keymap [mouse-2] command))) (setq keymaps (cdr keymaps))))) (setq list (sort (copy-sequence list) (function string-lessp)) w (vm-get-buffer-window (current-buffer)) q list list-length 0 longest 0 positions (1- (window-width w))) (while q (setq longest (max longest (length (car q))) list-length (1+ list-length) q (cdr q))) (setq columns (if (< positions (+ longest separation)) 1 (/ positions (+ longest separation)))) (setq tabs (/ list-length columns) tabs (+ tabs (if (zerop (% list-length columns)) 0 1))) (setq i 0) (while (< i tabs) (setq q (nthcdr i list)) (while q (setq start (point)) (insert (car q)) (when function (vm-mouse-set-mouse-track-highlight start (point))) (insert-char ? (+ separation (- longest (length (car q))))) (setq q (nthcdr tabs q))) (setq i (1+ i)) (insert "\n"))))) (defun vm-minibuffer-completion-help () (interactive) (let ((opoint (point)) c-list beg end word word-prefix-regexp) ;; find the beginning and end of the word we're trying to complete (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ ))) (progn (skip-chars-backward " \t\n") (and (not (eobp)) (forward-char)) (setq end (point))) (skip-chars-forward "^ \t\n") (setq end (point))) (skip-chars-backward "^ \t\n") (setq beg (point)) (goto-char opoint) ;; copy the word into a string (setq word (buffer-substring beg end)) ;; trim the completion list down to just likely candidates ;; then convert it to an alist. (setq word-prefix-regexp (concat "^" (regexp-quote word)) c-list (vm-delete-non-matching-strings word-prefix-regexp vm-minibuffer-completion-table) c-list (sort c-list (function string-lessp))) (if c-list (vm-minibuffer-show-completions c-list) (vm-minibuffer-completion-message " [No match]")))) (defun vm-keyboard-read-string (prompt completion-list &optional multi-word) (let ((minibuffer-local-map (copy-keymap minibuffer-local-map)) (vm-completion-auto-space multi-word) (vm-minibuffer-completion-table completion-list)) (define-key minibuffer-local-map "\t" 'vm-minibuffer-complete-word) (define-key minibuffer-local-map " " 'vm-minibuffer-complete-word) (define-key minibuffer-local-map "?" 'vm-minibuffer-completion-help) (if (not multi-word) (define-key minibuffer-local-map "\r" 'vm-minibuffer-complete-word-and-exit)) ;; evade the XEmacs dialog box, yeccch. (let ((use-dialog-box nil)) (read-string prompt)))) (defvar last-nonmenu-event) (defun vm-read-string (prompt completion-list &optional multi-word) ;; handle alist (if (consp (car completion-list)) (setq completion-list (nreverse (mapcar 'car completion-list)))) (if (and completion-list (vm-mouse-support-possible-here-p)) (cond ((and (vm-mouse-xemacs-mouse-p) (or (button-press-event-p last-command-event) (button-release-event-p last-command-event) (menu-event-p last-command-event))) (vm-mouse-read-string prompt completion-list multi-word)) ((and (vm-mouse-fsfemacs-mouse-p) (listp last-nonmenu-event)) (vm-mouse-read-string prompt completion-list multi-word)) (t (vm-keyboard-read-string prompt completion-list multi-word))) (vm-keyboard-read-string prompt completion-list multi-word))) (defun vm-read-number (prompt) (let (result) (while (null (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt))))) (string-to-number result))) (defun vm-keyboard-read-file-name (prompt &optional dir default must-match initial history) "Like `read-file-name', except HISTORY's value is unaltered." (let ((oldvalue (symbol-value history)) ;; evade the XEmacs dialog box, yeccch. (use-dialog-box nil)) (unwind-protect (condition-case nil (read-file-name prompt dir default must-match initial history) ((wrong-number-of-arguments void-function) (if history (let ((file-name-history (symbol-value history)) file) (setq file (read-file-name prompt dir default must-match initial)) file ) (read-file-name prompt dir default must-match initial)))) (and history (set history oldvalue))))) (defun vm-read-file-name (prompt &optional dir default must-match initial history) "Like `read-file-name', except a mouse interface is used if a mouse click mouse triggered the current command." (if (vm-mouse-support-possible-here-p) (cond ((and (vm-mouse-xemacs-mouse-p) (or (button-press-event-p last-command-event) (button-release-event-p last-command-event) (menu-event-p last-command-event))) (vm-mouse-read-file-name prompt dir default must-match initial history)) ((and (vm-mouse-fsfemacs-mouse-p) (listp last-nonmenu-event)) (vm-mouse-read-file-name prompt dir default must-match initial history)) (t (vm-keyboard-read-file-name prompt dir default must-match initial history))) (vm-keyboard-read-file-name prompt dir default must-match initial history))) (defun vm-read-folder-name () (completing-read "VM Folder: " (mapcar (lambda (f) (list f)) (vm-folder-buffers)) nil t nil nil)) ;;; vm-minibuf.el ends here vm-8.2.0b/lisp/vm-edit.el0000755000175000017500000003136411676442160015436 0ustar srivastasrivasta;;; vm-edit.el --- Editing VM messages ;; ;; This file is part of VM ;; ;; Copyright (C) 1990, 1991, 1993, 1994, 1997, 2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-edit) (eval-when-compile (require 'vm-misc) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) (require 'vm-page) (require 'vm-thread) (require 'vm-sort) (require 'vm-motion) ) ;;;###autoload (defun vm-edit-message (&optional prefix-argument) "Edit the current message. Prefix arg means mark as unedited instead. If editing, the current message is copied into a temporary buffer, and this buffer is selected for editing. The major mode of this buffer is controlled by the variable vm-edit-message-mode. The hooks specified in vm-edit-message-hook are run just prior to returning control to the user for editing. Use C-c ESC when you have finished editing the message. The message will be inserted into its folder replacing the old version of the message. If you don't want your edited version of the message to replace the original, use C-c C-] and the edit will be aborted." (interactive "P") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (if (and (vm-virtual-message-p (car vm-message-pointer)) (null (vm-virtual-messages-of (car vm-message-pointer)))) (error "Can't edit unmirrored virtual messages.")) (if prefix-argument (when (vm-edited-flag (car vm-message-pointer)) (vm-set-edited-flag-of (car vm-message-pointer) nil) (vm-update-summary-and-mode-line)) (let ((mp vm-message-pointer) (offset (save-excursion (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) (- (point) (vm-headers-of (car vm-message-pointer))))) (edit-buf (vm-edit-buffer-of (car vm-message-pointer))) (folder-buffer (current-buffer))) ;; (vm-load-message) (vm-retrieve-operable-messages 1 (list (car vm-message-pointer))) (if (and edit-buf (buffer-name edit-buf)) (set-buffer edit-buf) (vm-save-restriction (widen) (setq edit-buf (generate-new-buffer (format "edit of %s's note re: %s" (vm-su-full-name (car vm-message-pointer)) (vm-su-subject (car vm-message-pointer))))) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for new buffer (vm-set-edit-buffer-of (car mp) edit-buf) (copy-to-buffer edit-buf (vm-headers-of (car mp)) (vm-text-end-of (car mp)))) (set-buffer edit-buf) (set-buffer-modified-p nil) ; edit-buf (goto-char (point-min)) (if (< offset 0) (search-forward "\n\n" nil t) (forward-char offset)) (funcall (or vm-edit-message-mode 'text-mode)) (set-keymap-parent vm-edit-message-map (current-local-map)) (use-local-map vm-edit-message-map) ;; (list (car mp)) because a different message may ;; later be stuffed into a cons linked that is linked ;; into the folder's message list. (setq vm-message-pointer (list (car mp)) vm-mail-buffer folder-buffer vm-system-state 'editing buffer-offer-save t) (run-hooks 'vm-edit-message-hook) (vm-inform 5 (substitute-command-keys "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change.")) ) (when (and vm-mutable-frame-configuration vm-frame-per-edit (vm-multiple-frames-possible-p)) (let ((w (vm-get-buffer-window edit-buf))) (if (null w) (progn (vm-goto-new-frame 'edit) (vm-set-hooks-for-frame-deletion)) (save-excursion (select-window w) (and vm-warp-mouse-to-new-frame (vm-warp-mouse-to-frame-maybe (vm-window-frame w))))))) (vm-display edit-buf t '(vm-edit-message vm-edit-message-other-frame) (list this-command 'editing-message))))) ;;;###autoload (defun vm-edit-message-other-frame (&optional prefix) "Like vm-edit-message, but run in a newly created frame." (interactive "P") (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'edit)) (let ((vm-search-other-frames nil) (vm-frame-per-edit nil)) (vm-edit-message prefix)) (if (vm-multiple-frames-possible-p) (vm-set-hooks-for-frame-deletion))) ;;;###autoload (defun vm-discard-cached-data (&optional count) "Discard cached information about the current message. When VM gathers information from the headers of a message, it stores it internally for future reference. This command causes VM to forget this information, and VM will be forced to search the headers of the message again for these data. VM will also have to decide again which headers should be displayed and which should not. Therefore this command is useful if you change the value of vm-visible-headers or vm-invisible-header-regexp in the midst of a VM session. Numeric prefix argument N means to discard data from the current message plus the next N-1 messages. A negative N means discard data from the current message and the previous N-1 messages. When invoked on marked messages (via `vm-next-command-uses-marks'), data is discarded only from the marked messages in the current folder. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread have their cached data discarded." (interactive "p") (or count (setq count 1)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((mlist (vm-select-operable-messages count (vm-interactive-p) "Discard data of"))) (vm-discard-cached-data-internal mlist (vm-interactive-p) )) (vm-display nil nil '(vm-discard-cached-data) '(vm-discard-cached-data)) (vm-update-summary-and-mode-line)) (defun vm-discard-cached-data-internal (mlist &optional interactive-p) (let ((buffers-needing-thread-sort (make-vector 29 0)) m) (while mlist (setq m (vm-real-message-of (car mlist))) (with-current-buffer (vm-buffer-of m) (vm-garbage-collect-message) (if (vectorp vm-thread-obarray) (vm-unthread-message-and-mirrors m :message-changing t)) ;; It was a mistake to store the POP & IMAP UID data here but ;; it's too late to change it now. So keep the data from ;; getting wiped. (let ((uid (vm-imap-uid-of m)) (uid-validity (vm-imap-uid-validity-of m)) (headers-flag (vm-headers-to-be-retrieved-of m)) (body-flag (vm-body-to-be-retrieved-of m)) (body-discard-flag (vm-body-to-be-discarded-of m))) (fillarray (vm-cached-data-of m) nil) (vm-set-imap-uid-of m uid) (vm-set-imap-uid-validity-of m uid-validity) (vm-set-headers-to-be-retrieved-of m headers-flag) (vm-set-body-to-be-retrieved-of m body-flag) (vm-set-body-to-be-discarded-of m body-discard-flag)) (vm-set-vheaders-of m nil) (vm-set-vheaders-regexp-of m nil) (vm-set-text-of m nil) (vm-set-mime-layout-of m nil) (vm-set-mime-encoded-header-flag-of m nil) (if (vectorp vm-thread-obarray) (vm-build-threads (list m))) (if vm-thread-debug (vm-check-thread-integrity)) (if vm-summary-show-threads (intern (buffer-name) buffers-needing-thread-sort)) (dolist (v-m (vm-virtual-messages-of m)) (when (buffer-name (vm-buffer-of v-m)) (with-current-buffer (vm-buffer-of v-m) (vm-set-mime-layout-of v-m nil) (vm-set-mime-encoded-header-flag-of v-m nil) (if (vectorp vm-thread-obarray) (vm-build-threads (list v-m))) (if vm-summary-show-threads (intern (buffer-name) buffers-needing-thread-sort)) (if (and vm-presentation-buffer (eq (car vm-message-pointer) v-m)) (save-excursion (vm-present-current-message)))))) (vm-mark-for-summary-update m) (vm-set-stuff-flag-of m t) (if (and interactive-p vm-presentation-buffer (eq (car vm-message-pointer) m)) (save-excursion (vm-present-current-message))) (setq mlist (cdr mlist)))) (save-excursion (mapatoms (function (lambda (s) (set-buffer (get-buffer (symbol-name s))) (vm-sort-messages (or vm-ml-sort-keys "activity")))) buffers-needing-thread-sort)))) ;;;###autoload (defun vm-edit-message-end () "End the edit of a message and copy the result to its folder." (interactive) (if (null vm-message-pointer) (error "This is not a VM message edit buffer.")) (if (null (buffer-name (vm-buffer-of (car vm-message-pointer)))) (error "The folder buffer for this message has been killed.")) (let ((pos-offset (- (point) (point-min)))) ;; make sure the message ends with a newline (goto-char (point-max)) (and (/= (preceding-char) ?\n) (insert ?\n)) ;; munge message separators found in the edited message to ;; prevent message from being split into several messages. (vm-munge-message-separators (vm-message-type-of (car vm-message-pointer)) (point-min) (point-max)) ;; for From_-with-Content-Length recompute the Content-Length header (if (eq (vm-message-type-of (car vm-message-pointer)) 'From_-with-Content-Length) (let ((buffer-read-only nil) length) (goto-char (point-min)) ;; first delete all copies of Content-Length (while (and (re-search-forward vm-content-length-search-regexp nil t) (null (match-beginning 1)) (progn (goto-char (match-beginning 0)) (vm-match-header vm-content-length-header))) (delete-region (vm-matched-header-start) (vm-matched-header-end))) ;; now compute the message body length (goto-char (point-min)) (search-forward "\n\n" nil 0) (setq length (- (point-max) (point))) ;; insert the header (goto-char (point-min)) (insert vm-content-length-header " " (int-to-string length) "\n"))) (let ((edit-buf (current-buffer)) (mp vm-message-pointer)) (if (not (buffer-modified-p)) (vm-inform 5 "No change.") (widen) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) (if (not (memq (vm-real-message-of (car mp)) vm-message-list)) (error "The original copy of this message has been expunged.")) (vm-save-restriction (widen) (goto-char (vm-headers-of (vm-real-message-of (car mp)))) (let ((vm-message-pointer mp) opoint (buffer-read-only nil)) (setq opoint (point)) (insert-buffer-substring edit-buf) (delete-region (point) (vm-text-end-of (vm-real-message-of (car mp)))) (vm-discard-cached-data-internal (list (car mp)))) (vm-set-edited-flag-of (car mp) t) (vm-set-edit-buffer-of (car mp) nil)) (set-buffer (vm-buffer-of (car mp))) (if (eq (vm-real-message-of (car mp)) (vm-real-message-of (car vm-message-pointer))) (progn (vm-present-current-message) ;; Try to position the cursor in the message ;; window close to where it was in the edit ;; window. This works well for non MIME ;; messages, but the cursor drifts badly for ;; MIME and for refilled messages. (vm-save-buffer-excursion (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (vm-save-restriction (vm-save-buffer-excursion (widen) (let ((osw (selected-window)) (new-win (vm-get-visible-buffer-window (current-buffer)))) (unwind-protect (if new-win (progn (select-window new-win) (goto-char (vm-headers-of (car vm-message-pointer))) (condition-case nil (forward-char pos-offset) (error nil)))) (if (not (eq osw (selected-window))) (select-window osw)))))))) (vm-update-summary-and-mode-line)))) (vm-display edit-buf nil '(vm-edit-message-end) '(vm-edit-message-end reading-message startup)) (set-buffer-modified-p nil) ; edit-buf (kill-buffer edit-buf)))) (defun vm-edit-message-abort () "Abort the edit of a message, forgetting changes to the message." (interactive) (unless vm-message-pointer (error "This is not a VM message edit buffer.")) (unless (buffer-name (vm-buffer-of (vm-real-message-of (car vm-message-pointer)))) (error "The folder buffer for this message has been killed.")) (vm-set-edit-buffer-of (car vm-message-pointer) nil) (vm-display (current-buffer) nil '(vm-edit-message-abort) '(vm-edit-message-abort reading-message startup)) (set-buffer-modified-p nil) ; edit-buffer (kill-buffer (current-buffer)) (vm-inform 5 "Aborted, no change.")) ;;; vm-edit.el ends here vm-8.2.0b/lisp/vm-pgg.el0000755000175000017500000013506511676442160015271 0ustar srivastasrivasta;;; vm-pgg.el --- PGP/MIME support for VM by pgg.el ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 2006 Robert Widhopf-Fenk ;; ;; Author: Robert Widhopf-Fenk, Jens Gustedt ;; Status: Tested with XEmacs 21.4.19 & VM 7.19 ;; Keywords: VM helpers ;; X-URL: http://www.robf.de/Hacking/elisp ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: ;; ;; This is a replacement for mailcrypt adding PGP/MIME support to VM. ;; ;; It requires PGG which is a standard package for XEmacs and is a part ;; of Gnus for GNU Emacs. On Debian "apt-get install gnus" should do the ;; trick. ;; ;; It is still in BETA state thus you must explicitly load it by ;; ;; (and (locate-library "vm-pgg") (require 'vm-pgg)) ;; ;; If you set `vm-mime-auto-displayed-content-types' and/or ;; `vm-mime-internal-content-types' make sure that they contain ;; "application/pgp-keys" or set them before loading vm-pgg. ;; Otherwise public keys are not detected automatically . ;; ;; To customize vm-pgg use: M-x customize-group RET vm-pgg RET ;; ;; Displaying of messages in the PGP(/MIME) format will automatically trigger: ;; * decrypted of encrypted MIME parts ;; * verification of signed MIME parts ;; * snarfing of public keys ;; ;; The status of the current message will also be displayed in the modeline. ;; ;; To create messages according to PGP/MIME you should use: ;; * M-x vm-pgg-encrypt for encrypting ;; * M-x vm-pgg-sign for signing ;; * C-u M-x vm-pgg-encrypt for encrypting + signing ;; ;; All these commands are also available in the menu PGP/MIME which is ;; activated by the minor mode `vm-pgg-compose-mode'. There are also ;; commands for the old style clear text format as MC had them. ;; ;; If you get annoyed by answering password prompts you might want to set the ;; variable `pgg-cache-passphrase' to t and `pgg-passphrase-cache-expiry' to a ;; higher value or nil! ;; ;;; References: ;; ;; Code partially stems from the sources: ;; * mml2015.el (Gnus) ;; * mc-toplev.el (Mailcrypt) ;; ;; For PGP/MIME see: ;; * http://www.faqs.org/rfcs/rfc2015.html ;; * http://www.faqs.org/rfcs/rfc2440.html ;; * http://www.faqs.org/rfcs/rfc3156.html ;; ;;; TODO: ;; ;; * add annotation see to signed/encrypted regions. XEmacs has annotations ;; and GNU Emacs? Maybe I simply use overlays at the line start without eys ;; candy. ;; * allow attaching of other keys from key-ring ;; ;;; Code: ;; handle missing pgg.el gracefully (eval-and-compile (if (and (boundp 'byte-compile-current-file) byte-compile-current-file) (condition-case nil (require 'pgg) (error (message "WARNING: Cannot load pgg.el, related functions may not work!"))) (require 'pgg)) (require 'easymenu) (require 'vm-misc) (require 'vm-folder) (require 'vm-window) (require 'vm-page) (require 'vm-mime) (require 'vm-reply) (require 'vm-motion) (require 'advice)) (declare-function rfc822-addresses "ext:rfc822" (header-text)) (eval-when-compile (require 'cl) ;; avoid warnings (defvar vm-mode-line-format) (defvar vm-message-pointer) (defvar vm-presentation-buffer) (defvar vm-summary-buffer) ;; avoid bytecompile warnings (defvar vm-pgg-cleartext-state nil "For interfunction communication.") ) ; group already defined in vm-vars.el ;(defgroup vm nil ; "VM" ; :group 'mail) (defgroup vm-pgg nil "PGP and PGP/MIME support for VM by PGG." :group 'vm-ext) (defface vm-pgg-bad-signature '((((type tty) (class color)) (:foreground "red" :bold t)) (((type tty)) (:bold t)) (((background light)) (:foreground "red" :bold t)) (((background dark)) (:foreground "red" :bold t))) "The face used to highlight bad signature messages." :group 'vm-pgg :group 'faces) (defface vm-pgg-good-signature '((((type tty) (class color)) (:foreground "green" :bold t)) (((type tty)) (:bold t)) (((background light)) (:foreground "green4")) (((background dark)) (:foreground "green"))) "The face used to highlight good signature messages." :group 'vm-pgg :group 'faces) (defface vm-pgg-unknown-signature-type '((((type tty) (class color)) (:bold t)) (((type tty)) (:bold t))) "The face used to highlight unknown signature types." :group 'vm-pgg :group 'faces) (defface vm-pgg-error '((((type tty) (class color)) (:foreground "red" :bold t)) (((type tty)) (:bold t)) (((background light)) (:foreground "red" :bold t)) (((background dark)) (:foreground "red" :bold t))) "The face used to highlight error messages." :group 'vm-pgg :group 'faces) (defface vm-pgg-bad-signature-modeline '((((type tty) (class color)) (:inherit modeline :foreground "red" :bold t)) (((type tty)) (:inherit modeline :bold t)) (((background light)) (:inherit modeline :foreground "red" :bold t)) (((background dark)) (:inherit modeline :foreground "red" :bold t))) "The face used to highlight bad signature messages." :group 'vm-pgg :group 'faces) (defface vm-pgg-good-signature-modeline '((((type tty) (class color)) (:inherit modeline :foreground "green" :bold t)) (((type tty)) (:inherit modeline :bold t)) (((background light)) (:inherit modeline :foreground "green4")) (((background dark)) (:inherit modeline :foreground "green"))) "The face used to highlight good signature messages." :group 'vm-pgg :group 'faces) (defface vm-pgg-unknown-signature-type-modeline '((((type tty) (class color)) (:inherit modeline :bold t)) (((type tty)) (:inherit modeline :bold t))) "The face used to highlight unknown signature types." :group 'vm-pgg :group 'faces) (defface vm-pgg-error-modeline '((((type tty) (class color)) (:inherit modeline :foreground "red" :bold t)) (((type tty)) (:inherit modeline :bold t)) (((background light)) (:inherit modeline :foreground "red")) (((background dark)) (:inherit modeline :foreground "red"))) "The face used to highlight error messages." :group 'vm-pgg :group 'faces) ;; hack to work around the missing support for :inherit in XEmacs (when (featurep 'xemacs) (let ((faces '(vm-pgg-bad-signature-modeline vm-pgg-good-signature-modeline vm-pgg-unknown-signature-type-modeline vm-pgg-error-modeline)) (faces-list (face-list)) f) (while faces (setq f (car faces)) (set-face-parent f 'modeline) (face-display-set f (custom-face-get-spec f) nil '(custom)) (setq faces (cdr faces))))) (defcustom vm-pgg-fetch-missing-keys t "*If t, PGP will try to fetch missing keys from `pgg-default-keyserver-address'." :group 'vm-pgg :type 'boolean) (defcustom vm-pgg-auto-snarf t "*If t, snarfing of keys will happen automatically." :group 'vm-pgg :type 'boolean) (defcustom vm-pgg-auto-decrypt t "*If t, decrypting will happen automatically." :group 'vm-pgg :type 'boolean) (defcustom vm-pgg-get-author-headers '("From:" "Sender:") "*The list of headers to get the author of a mail that is to be send. If nil, `pgg-default-user-id' is used as a fallback." :group 'vm-pgg :type '(repeat string)) (defcustom vm-pgg-sign-text-transfer-encoding 'quoted-printable "*The encoding used for signed MIME parts of type text. See `vm-pgg-sign' for details." :group 'vm-pgg :type '(choice (const quoted-printable) (const base64))) (defvar vm-pgg-compose-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c#s" 'vm-pgg-sign) (define-key map "\C-c#e" 'vm-pgg-encrypt) (define-key map "\C-c#E" 'vm-pgg-sign-and-encrypt) (define-key map "\C-c#a" 'vm-pgg-ask-hook) (define-key map "\C-c#k" 'vm-pgg-attach-public-key) map)) (defvar vm-pgg-compose-mode-menu nil "The composition menu of vm-pgg.") (easy-menu-define vm-pgg-compose-mode-menu (if (featurep 'xemacs) nil (list vm-pgg-compose-mode-map)) "PGP/MIME compose mode menu." '("PGP/MIME" ["Sign" vm-pgg-sign t] ["Encrypt" vm-pgg-encrypt t] ["Sign+Encrypt" vm-pgg-sign-and-encrypt t] ["Ask For An Action" vm-pgg-ask-hook t] "----" ["Attach Public Key" vm-pgg-attach-public-key t] ["Insert Public Key" pgg-insert-key t])) (defvar vm-pgg-compose-mode nil "None-nil means PGP/MIME composition mode key bindings and menu are available.") (make-variable-buffer-local 'vm-pgg-compose-mode) (defun vm-pgg-compose-mode (&optional arg) "\nMinor mode for interfacing with cryptographic functions. Switch mode on/off according to ARG. \\" (interactive) (setq vm-pgg-compose-mode (if (null arg) (not vm-pgg-compose-mode) (> (prefix-numeric-value arg) 0))) (if vm-pgg-compose-mode (easy-menu-add vm-pgg-compose-mode-menu) (easy-menu-remove vm-pgg-compose-mode-menu))) (defvar vm-pgg-compose-mode-string " vm-pgg" "*String to put in mode line when function `vm-pgg-compose-mode' is active.") (defcustom vm-pgg-ask-function 'vm-pgg-prompt-for-action "*The function to use in `vm-pgg-ask-hook'." :group 'vm-pgg :type '(choice (const :tag "do nothing" :doc "Disable `vm-pgg-ask-hook'" nil) (const :tag "sign" :doc "Ask whether to sign the message before sending" sign) (const :tag "encrypt" :doc "Ask whether to encryt the message before sending" encrypt) (const :tag "encrypt and sign" :doc "Ask whether to encrypt and sign the message before sending" encrypt-and-sign) (function :tag "ask for the action" :doc "Will prompt for an action by calling `vm-pgg-prompt-for-action'" vm-pgg-prompt-for-action) (function :tag "your own function" :doc "It should returning one of the other const values."))) (if (not (assq 'vm-pgg-compose-mode minor-mode-map-alist)) (setq minor-mode-map-alist (cons (cons 'vm-pgg-compose-mode vm-pgg-compose-mode-map) minor-mode-map-alist))) (if (not (assq 'vm-pgg-compose-mode minor-mode-alist)) (setq minor-mode-alist (cons '(vm-pgg-compose-mode vm-pgg-compose-mode-string) minor-mode-alist))) (defun vm-pgg-compose-mode-activate () "Activate function `vm-pgg-compose-mode'." (vm-pgg-compose-mode 1)) (add-hook 'vm-mail-mode-hook 'vm-pgg-compose-mode-activate t) (defun vm-pgg-get-emails (headers) "Return email addresses found in the given HEADERS." (let (content recipients) (while headers (setq content (vm-mail-mode-get-header-contents (car headers))) (when content (setq recipients (append (rfc822-addresses content) recipients))) (setq headers (cdr headers))) recipients)) (defvar vm-pgg-get-recipients-headers '("To:" "CC:" "BCC:") "The list of headers to get recipients from.") (defun vm-pgg-get-recipients () "Return a list of recipients." (vm-pgg-get-emails vm-pgg-get-recipients-headers)) (defun vm-pgg-get-author () "Return the author of the message." (car (vm-pgg-get-emails vm-pgg-get-author-headers))) (defun vm-pgp-goto-body-start () "Goto the start of the body and return point." (goto-char (point-min)) (search-forward (concat "\n" mail-header-separator "\n")) (goto-char (match-end 0)) (point)) (defun vm-pgp-prepare-composition () "Prepare the composition for encrypting or signing." ;; encode message (unless (vm-mail-mode-get-header-contents "MIME-Version:") (if vm-do-fcc-before-mime-encode (vm-do-fcc-before-mime-encode)) (vm-mime-encode-composition)) (vm-mail-mode-show-headers) ;; ensure newline at the end (goto-char (point-max)) (skip-chars-backward " \t\r\n\f") (delete-region (point) (point-max)) (insert "\n") ;; skip headers (vm-pgp-goto-body-start) ;; guess the author (make-local-variable 'pgg-default-user-id) (setq pgg-default-user-id (or (and vm-pgg-get-author-headers (vm-pgg-get-author)) pgg-default-user-id))) ;;; ###autoload (defun vm-pgg-cleartext-encrypt (sign) "*Encrypt the composition as cleartext and with a prefix also SIGN it." (interactive "P") (save-excursion (vm-pgp-prepare-composition) (let ((start (point)) (end (point-max))) (unless (pgg-encrypt-region start end (vm-pgg-get-recipients) sign) (pop-to-buffer pgg-errors-buffer) (error "Encrypt error")) (delete-region start end) (insert-buffer-substring pgg-output-buffer)))) (defun vm-pgg-make-presentation-copy () "Make a presentation copy also for cleartext PGP messages." (let* ((m (car vm-message-pointer)) (layout (vm-mm-layout m))) ;; make a presentation copy (vm-make-presentation-copy m) (vm-save-buffer-excursion (vm-replace-buffer-in-windows (current-buffer) vm-presentation-buffer)) (set-buffer vm-presentation-buffer) ;; remove From line (goto-char (point-min)) (forward-line 1) (let ((buffer-read-only nil)) (delete-region (point-min) (point)) (vm-reorder-message-headers nil :keep-list vm-visible-headers :discard-regexp vm-invisible-header-regexp) (vm-decode-mime-message-headers m) (when (vectorp layout) ;; skip headers otherwise they get removed (goto-char (point-min)) (search-forward "\n\n") (vm-decode-mime-layout layout) (delete-region (point) (point-max))) (vm-energize-urls-in-message-region) (vm-highlight-headers-maybe) (vm-energize-headers-and-xfaces)))) (defvar vm-pgg-state nil "State of the currently viewed message.") (make-variable-buffer-local 'vm-pgg-state) (defvar vm-pgg-state-message nil "The message for `vm-pgg-state'.") (make-variable-buffer-local 'vm-pgg-state-message) (defvar vm-pgg-mode-line-items (let ((items '((error " ERROR" vm-pgg-error-modeline) (unknown " unknown" vm-pgg-unknown-signature-type-modeline) (verified " verified" vm-pgg-good-signature-modeline))) mode-line-items x i s f) (while (and (featurep 'xemacs) items) (setq x (car items) i (car x) s (cadr x) f (caddr x) x (vm-make-extent 0 (length s) s)) (vm-set-extent-property x 'face f) (setq items (cdr items)) (setq mode-line-items (append mode-line-items (list (list i x s))))) mode-line-items) "An alist mapping states to modeline strings.") (if (not (member 'vm-pgg-state vm-mode-line-format)) (setq vm-mode-line-format (append '("" vm-pgg-state) vm-mode-line-format))) (defun vm-pgg-state-set (&rest states) "Set the message state displayed in the modeline acording to STATES. If STATES is nil, clear it." ;; clear state for a new message (save-excursion (vm-select-folder-buffer-if-possible) (when (not (equal (car vm-message-pointer) vm-pgg-state-message)) (setq vm-pgg-state-message (car vm-message-pointer)) (setq vm-pgg-state nil) (when vm-presentation-buffer (save-excursion (set-buffer vm-presentation-buffer) (setq vm-pgg-state nil))) (when vm-summary-buffer (save-excursion (set-buffer vm-summary-buffer) (setq vm-pgg-state nil)))) ;; add prefix (if (and states (not vm-pgg-state)) (setq vm-pgg-state '("PGP:"))) ;; add new states (let (s) (while states (setq s (car states) vm-pgg-state (append vm-pgg-state (list (or (cdr (assoc s vm-pgg-mode-line-items)) (format " %s" s)))) states (cdr states)))) ;; propagate state (setq states vm-pgg-state) (when vm-presentation-buffer (save-excursion (set-buffer vm-presentation-buffer) (setq vm-pgg-state states))) (when vm-summary-buffer (save-excursion (set-buffer vm-summary-buffer) (setq vm-pgg-state states))))) (defvar vm-pgg-cleartext-begin-regexp "^-----BEGIN PGP \\(\\(SIGNED \\)?MESSAGE\\|PUBLIC KEY BLOCK\\)-----$" "Regexp used to match PGP armor.") (defvar vm-pgg-cleartext-end-regexp "^-----END PGP %s-----$" "Regexp used to match PGP armor.") (defcustom vm-pgg-cleartext-search-limit 4096 "Number of bytes to peek into the message for a PGP clear text armor." :group 'vm-pgg :group 'faces) (defun vm-pgg-cleartext-automode-button (label action) "Cleartext thing by a button with text LABEL and associate ACTION with it. When the button is pressed ACTION is called." (save-excursion (unless (eq major-mode 'vm-presentation-mode) (vm-pgg-make-presentation-copy)) (goto-char (match-beginning 0)) (let ((buffer-read-only nil) (start (point)) o) (if (re-search-forward (format vm-pgg-cleartext-end-regexp (match-string 0)) (point-max) t) (delete-region start (match-end 0))) (insert label) (setq o (make-overlay start (point))) (overlay-put o 'vm-pgg t) (overlay-put o 'face vm-mime-button-face) (overlay-put o 'vm-button t) (overlay-put o 'mouse-face 'vm-mime-button-mouse-face) (let ((keymap (make-sparse-keymap))) (define-key keymap [mouse-2] action) (define-key keymap "\r" action) (overlay-put o 'local-map keymap))))) (defvar vm-pgg-cleartext-decoded nil "State of the cleartext message.") (make-variable-buffer-local 'vm-pgg-cleartext-decoded) (defun vm-pgg-set-cleartext-decoded () (save-excursion (vm-select-folder-buffer) (setq vm-pgg-cleartext-decoded (car vm-message-pointer)))) (defun vm-pgg-cleartext-automode () "Check for PGP ASCII armor and triggers automatic verification/decryption." (save-excursion (vm-select-folder-buffer-if-possible) (if (equal vm-pgg-cleartext-decoded (car vm-message-pointer)) (setq vm-pgg-cleartext-decoded nil) (setq vm-pgg-cleartext-decoded nil) (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) (goto-char (point-min)) (when (and (vm-mime-plain-message-p (car vm-message-pointer)) (re-search-forward vm-pgg-cleartext-begin-regexp (+ (point) vm-pgg-cleartext-search-limit) t)) (cond ((string= (match-string 1) "SIGNED MESSAGE") (vm-pgg-set-cleartext-decoded) (vm-pgg-cleartext-verify)) ((string= (match-string 1) "MESSAGE") (vm-pgg-set-cleartext-decoded) (if vm-pgg-auto-decrypt (vm-pgg-cleartext-decrypt) (vm-pgg-cleartext-automode-button "Decrypt PGP message\n" (lambda () (interactive) (let ((vm-pgg-auto-decrypt t)) (vm-pgg-cleartext-decrypt)))))) ((string= (match-string 1) "PUBLIC KEY BLOCK") (vm-pgg-set-cleartext-decoded) (if vm-pgg-auto-snarf (vm-pgg-snarf-keys) (vm-pgg-cleartext-automode-button "Snarf PGP key\n" (lambda () (interactive) (let ((vm-pgg-auto-snarf t)) (vm-pgg-snarf-keys)))))) (t (error "This should never happen!"))))))) (defadvice vm-present-current-message (after vm-pgg-cleartext-automode activate) "Decode or check signature on clear text messages." (vm-pgg-state-set) (when (and vm-pgg-cleartext-decoded (not (equal vm-pgg-cleartext-decoded (car vm-message-pointer)))) (setq vm-pgg-cleartext-decoded nil)) (when (and (not (eq vm-system-state 'previewing)) (not vm-mime-decoded)) (vm-pgg-cleartext-automode))) (defadvice vm-scroll-forward (around vm-pgg-cleartext-automode activate) "Decode or check signature on clear text messages." (let ((vm-system-state-was (save-excursion (vm-select-folder-buffer-if-possible) vm-system-state))) ad-do-it (vm-pgg-state-set) (when (and (eq vm-system-state-was 'previewing) (not vm-mime-decoded)) (vm-pgg-cleartext-automode)))) ;;; ###autoload (defun vm-pgg-cleartext-sign () "*Sign the message." (interactive) (save-excursion (vm-pgp-prepare-composition) (let ((start (point)) (end (point-max))) (unless (pgg-sign-region start end t) (pop-to-buffer pgg-errors-buffer) (error "Signing error")) (delete-region start end) (insert-buffer-substring pgg-output-buffer)))) (defun vm-pgg-cleartext-cleanup (status) "Removed ASCII armor and insert PGG output depending on STATUS." (let (start end) (setq start (and (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----$") (match-beginning 0)) end (and (search-forward "\n\n") (match-end 0))) (delete-region start end) (setq start (and (re-search-forward "^-----BEGIN PGP SIGNATURE-----$") (match-beginning 0)) end (and (re-search-forward "^-----END PGP SIGNATURE-----$") (match-end 0))) (delete-region start end) ;; add output from PGP (insert "\n") (let ((start (point)) end) (if (eq status 'error) (insert-buffer-substring pgg-errors-buffer) (insert-buffer-substring pgg-output-buffer) (vm-pgg-crlf-cleanup start (point))) (setq end (point)) (put-text-property start end 'face (if (eq status 'error) 'vm-pgg-bad-signature 'vm-pgg-good-signature))))) (defadvice vm-mime-transfer-decode-region (around vm-pgg-cleartext-automode activate) "Decode or check signature on clear text messages parts." (let ((vm-pgg-part-start (point))) ad-do-it ;; BUGME should we use marks here? (when (and (vm-mime-text-type-layout-p (ad-get-arg 0)) (< vm-pgg-part-start (point))) (save-excursion (save-restriction (narrow-to-region vm-pgg-part-start (point)) (vm-pgg-cleartext-automode) (widen) ; (set-window-start (selected-window) 0) ;(scroll-down 1000) ))))) (defadvice vm-mime-display-internal-text/plain (around vm-pgg-cleartext-automode activate) "Decode or check signature on clear text messages parts. We use the advice here in order to avoid overwriting VMs internal text display function. Faces will get lost if a charset conversion happens thus we do the cleanup here after verification and decoding took place." (let ((vm-pgg-cleartext-state nil) (start (point)) end) ad-do-it (when vm-pgg-cleartext-state (setq end (point)) (save-restriction (narrow-to-region start end) (goto-char (point-min)) (vm-pgg-cleartext-cleanup vm-pgg-cleartext-state) (widen))))) ;;; ###autoload (defun vm-pgg-cleartext-verify () "*Verify the signature in the current message." (interactive) (message "Verifying PGP cleartext message...") (when (vm-interactive-p) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p))) ;; make a presentation copy (unless (eq major-mode 'vm-presentation-mode) (vm-pgg-make-presentation-copy)) ;; verify (save-excursion (goto-char (point-min)) (let ((buffer-read-only nil) (status (pgg-verify-region (point) (point-max) nil vm-pgg-fetch-missing-keys))) (vm-pgg-state-set 'signed) (setq status (if (not status) 'error 'verified)) (vm-pgg-state-set status) (if (boundp 'vm-pgg-cleartext-state) (setq vm-pgg-cleartext-state status) (vm-pgg-cleartext-cleanup status))))) ;;; ###autoload (defun vm-pgg-cleartext-decrypt () "*Decrypt the contents of the current message." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) ;; make a presentation copy (unless (eq major-mode 'vm-presentation-mode) (vm-pgg-make-presentation-copy)) (goto-char (point-min)) ;; decrypt (let (state start end) (setq start (and (re-search-forward "^-----BEGIN PGP MESSAGE-----$") (match-beginning 0)) end (and (re-search-forward "^-----END PGP MESSAGE-----$") (match-end 0)) state (condition-case nil (pgg-decrypt-region start end) (error nil))) (vm-pgg-state-set 'encrypted) (if (not state) ;; insert the error message (let ((buffer-read-only nil)) (vm-pgg-state-set 'error) (goto-char start) (insert-buffer-substring pgg-errors-buffer) (put-text-property start (point) 'face 'vm-pgg-error)) ;; replace it with decrypted message (let ((buffer-read-only nil)) (delete-region start end) (insert-buffer-substring pgg-output-buffer)) ;; if it signed then also verify it (goto-char start) (if (looking-at "^-----BEGIN PGP \\(SIGNED \\)?MESSAGE-----$") (vm-pgg-cleartext-verify))))) (defun vm-pgg-crlf-cleanup (start end) "Convert CRLF to LF in region from START to END." (save-excursion (goto-char start) (while (search-forward "\r\n" end t) (replace-match "\n" t t)))) (defun vm-pgg-make-crlf (start end) "Convert CRLF to LF in region from START to END." (save-excursion (goto-char end) (while (search-backward "\n" start t) (replace-match "\r\n" t t) (backward-char)))) (defvar vm-pgg-mime-decoded nil "Saves decoded state for later use, i.e. decoding to buttons.") (make-variable-buffer-local 'vm-pgg-mime-decoded) (defun vm-pgg-get-mime-decoded () "Return `vm-pgg-mime-decoded'." (save-excursion (vm-select-folder-buffer) vm-pgg-mime-decoded)) (defvar vm-pgg-recursion nil "Detect recursive calles.") (defadvice vm-decode-mime-message (around vm-pgg-clear-state activate) "Clear the modeline state before decoding." (vm-select-folder-buffer) (when (not vm-pgg-recursion) (setq vm-pgg-mime-decoded vm-mime-decoded)) (setq vm-pgg-state-message nil) (setq vm-pgg-state nil) (if (vm-mime-plain-message-p (car vm-message-pointer)) (if vm-pgg-cleartext-decoded (vm-present-current-message)) (let ((vm-pgg-recursion t)) ad-do-it))) (defun vm-pgg-mime-decrypt (button) "Replace the BUTTON with the output from `pgg-snarf-keys'." (let ((vm-pgg-auto-decrypt t) (layout (copy-sequence (vm-extent-property button 'vm-mime-layout)))) (vm-set-extent-property button 'vm-mime-disposable t) (vm-set-extent-property button 'vm-mime-layout layout) (goto-char (vm-extent-start-position button)) (let ((buffer-read-only nil)) (vm-decode-mime-layout button t)))) ;;; ###autoload (defun vm-mime-display-internal-multipart/encrypted (layout) "Display multipart/encrypted LAYOUT." (vm-pgg-state-set 'encrypted) (let* ((part-list (vm-mm-layout-parts layout)) (header (car part-list)) (message (car (cdr part-list))) status) (cond ((eq (vm-pgg-get-mime-decoded) 'decoded) ;; after decode the state of vm-mime-decoded is 'buttons nil) ((not (and (= (length part-list) 2) (vm-mime-types-match (car (vm-mm-layout-type header)) "application/pgp-encrypted") ;; TODO: check version and protocol here? (vm-mime-types-match (car (vm-mm-layout-type message)) "application/octet-stream"))) (insert "Unknown multipart/encrypted format.")) ((not vm-pgg-auto-decrypt) ;; add a button (let ((buffer-read-only nil)) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action 'vm-pgg-mime-decrypt :layout layout))) (t ;; decode the message now (save-excursion (set-buffer (vm-buffer-of (vm-mm-layout-message message))) (save-restriction (widen) (setq status (pgg-decrypt-region (vm-mm-layout-body-start message) (vm-mm-layout-body-end message))))) (if (not status) (let ((start (point))) (vm-pgg-state-set 'error) (insert-buffer-substring pgg-errors-buffer) (put-text-property start (point) 'face 'vm-pgg-error)) (save-excursion (set-buffer pgg-output-buffer) (vm-pgg-crlf-cleanup (point-min) (point-max)) (setq message (vm-mime-parse-entity-safe nil :passing-message-only t))) (if message (vm-decode-mime-layout message) (insert-buffer-substring pgg-output-buffer)) (setq status (save-excursion (set-buffer pgg-errors-buffer) (goto-char (point-min)) ;; TODO: care for BADSIG (when (re-search-forward "GOODSIG [^\n\r]+" (point-max) t) (vm-pgg-state-set 'signed 'verified) (buffer-substring (match-beginning 0) (match-end 0))))) (if status (let ((start (point))) (insert "\n" status "\n") (put-text-property start (point) 'face 'vm-pgg-good-signature)))) t)))) ;;; ###autoload (defun vm-mime-display-internal-multipart/signed (layout) "Display multipart/signed LAYOUT." (vm-pgg-state-set 'signed) (let* ((part-list (vm-mm-layout-parts layout)) (message (car part-list)) (signature (car (cdr part-list))) status signature-file start end) (cond ((eq (vm-pgg-get-mime-decoded) 'decoded) ;; after decode the state of vm-mime-decoded is 'buttons nil) ((not (and (= (length part-list) 2) signature ;; TODO: check version and protocol here? (vm-mime-types-match (car (vm-mm-layout-type signature)) "application/pgp-signature"))) ;; insert the message (vm-decode-mime-layout message) (let (start end) (vm-pgg-state-set 'unknown) (setq start (point)) (insert (format "******* unknown signature type %s *******\n" (car (and signature (vm-mm-layout-type signature))))) (setq end (point)) (when signature (vm-decode-mime-layout signature)) (put-text-property start end 'face 'vm-pgg-unknown-signature-type)) t) (t ;; insert the message (vm-decode-mime-layout message) ;; write signature to a temp file (setq start (point)) (vm-mime-insert-mime-body signature) (setq end (point)) (write-region start end (setq signature-file (pgg-make-temp-file "vm-pgg-signature"))) (delete-region start end) (setq start (point)) (vm-insert-region-from-buffer (marker-buffer (vm-mm-layout-header-start message)) (vm-mm-layout-header-start message) (vm-mm-layout-body-end message)) (setq end (point-marker)) (vm-pgg-make-crlf start end) (setq status (pgg-verify-region start end signature-file vm-pgg-fetch-missing-keys)) (delete-file signature-file) (delete-region start end) ;; now insert the content (insert "\n") (let ((start (point)) end) (if (not status) (progn (vm-pgg-state-set 'error) (insert-buffer-substring pgg-errors-buffer)) (vm-pgg-state-set 'verified) (insert-buffer-substring (if vm-fsfemacs-p pgg-errors-buffer pgg-output-buffer)) (vm-pgg-crlf-cleanup start (point))) (setq end (point)) (put-text-property start end 'face (if status 'vm-pgg-good-signature 'vm-pgg-bad-signature))) t)))) ;; we must add these in order to force VM to call our handler (eval-and-compile ;; (if (listp vm-mime-auto-displayed-content-types) ;; (add-to-list 'vm-mime-auto-displayed-content-types "application/pgp-keys")) (if (listp vm-mime-internal-content-types) (add-to-list 'vm-mime-internal-content-types "application/pgp-keys")) (add-to-list 'vm-mime-button-format-alist '("application/pgp-keys" . "Snarf %d")) (add-to-list 'vm-mime-button-format-alist '("multipart/encrypted" . "Decrypt PGP/MIME message"))) (defun vm-pgg-mime-snarf-keys (button) "Replace the BUTTON with the output from `pgg-snarf-keys'." (let ((vm-pgg-auto-snarf t) (layout (copy-sequence (vm-extent-property button 'vm-mime-layout)))) (vm-set-extent-property button 'vm-mime-disposable t) (vm-set-extent-property button 'vm-mime-layout layout) (goto-char (vm-extent-start-position button)) (let ((buffer-read-only nil)) (vm-decode-mime-layout button t)))) ;;; ###autoload (defun vm-mime-display-internal-application/pgp-keys (layout) "Snarf keys in LAYOUT and display result of snarfing." (vm-pgg-state-set 'public-key) ;; insert the keys (if vm-pgg-auto-snarf (let ((start (point)) end status) (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (save-excursion (setq status (pgg-snarf-keys-region start end))) (delete-region start end) ;; now insert the result of snafing (if status (insert-buffer-substring pgg-output-buffer) (insert-buffer-substring pgg-errors-buffer))) (let ((buffer-read-only nil)) (vm-mime-insert-button :caption (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) :action 'vm-pgg-mime-snarf-keys :layout layout))) t) ;;; ###autoload (defun vm-pgg-snarf-keys () "*Snarf keys from the current message." (interactive) (if (vm-interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (save-restriction ;; ensure we are in the right buffer (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) ;; skip headers (goto-char (point-min)) (search-forward "\n\n") (goto-char (match-end 0)) ;; verify (unless (pgg-snarf-keys) (error "Snarfing failed")) (save-excursion (set-buffer (if vm-fsfemacs-p pgg-errors-buffer pgg-output-buffer)) (message (buffer-substring (point-min) (point-max)))))) ;;; ###autoload (defun vm-pgg-attach-public-key () "Attach your public key to a composition." (interactive) (let* ((pgg-default-user-id (or (and vm-pgg-get-author-headers (vm-pgg-get-author)) pgg-default-user-id)) (description (concat "public key of " pgg-default-user-id)) (buffer (get-buffer-create (concat " *" description "*"))) start) (save-excursion (set-buffer buffer) (erase-buffer) (setq start (point)) (pgg-insert-key) (if (= start (point)) (error "%s has no public key!" pgg-default-user-id))) (save-excursion (goto-char (point-max)) (insert "\n") (setq start (point)) (vm-attach-object buffer :type "application/pgp-keys" :params (list (concat "name=\"" pgg-default-user-id ".asc\"")) :description description) ;; a crude hack to set the disposition (let ((disposition (list "attachment" (concat "filename=\"" pgg-default-user-id ".asc\""))) (end (point))) (if (featurep 'xemacs) (vm-set-extent-property (vm-extent-at start 'vm-mime-disposition) 'vm-mime-disposition disposition) (put-text-property start end 'vm-mime-disposition disposition)))))) (defun vm-pgg-make-multipart-boundary (word) "Create a mime part boundery starting with WORD and return it. We cannot use `vm-mime-make-multipart-boundary' as it uses the current time as seed and thus creates the same boundery when called twice in a short period." (if word (setq word (concat word "+"))) (let ((boundary (concat word (make-string 15 ?a))) (i (length word))) (random) (while (< i (length boundary)) (aset boundary i (aref vm-mime-base64-alphabet (% (vm-abs (lsh (random) -8)) (length vm-mime-base64-alphabet)))) (vm-increment i)) boundary)) (defun vm-pgg-save-work (function &rest args) "Call FUNCTION with ARGS without messing up the composition in case of an error." (let ((composition-buffer (current-buffer)) (undo-list-backup buffer-undo-list) (work-buffer (get-buffer-create " *VM-PGG-WORK*"))) (save-excursion (set-buffer work-buffer) (buffer-disable-undo) (erase-buffer) (insert-buffer-substring composition-buffer) (setq major-mode 'mail-mode) (apply function args)) (vm-mail-mode-show-headers) (erase-buffer) (insert-buffer-substring work-buffer) (kill-buffer work-buffer))) ;;; ###autoload (defun vm-pgg-sign () "Sign the composition with PGP/MIME. If the composition is not encoded so far, it is encoded before signing. Signing of already encoded messages is discouraged. RFC 2015 and its successor 3156 forbid the use of 8bit encoding for signed messages, but require to use quoted-printable or base64 instead. Also lines starting with \"From \" cause trouble and should be quoted. Thus signing of encoded messages may cause an error. To avoid this you must set `vm-mime-8bit-text-transfer-encoding' to something different than 8bit and `vm-mime-composition-armor-from-lines' to t. The transfer encoding done by `vm-pgg-sign' can be controlled by the variable `vm-pgg-sign-text-transfer-encoding'." (interactive) (when (vm-mail-mode-get-header-contents "MIME-Version:") ;; do a simple sanity check ... too simple as we should walk the MIME part ;; hierarchy and only check the MIME headers ... (goto-char (point-min)) (when (re-search-forward "Content-Transfer-Encoding:\\s-*8bit" nil t) (describe-function 'vm-pgg-sign) (error "Signing is broken for 8bit encoding!")) (goto-char (point-min)) (when (re-search-forward "^From\\s-+" nil t) (describe-function 'vm-pgg-sign) (error "Signing is broken for lines starting with \"From \"!"))) (vm-pgg-save-work 'vm-pgg-sign-internal)) (defun vm-pgg-sign-internal () "Do the signing." ;; prepare composition (let ((vm-mime-8bit-text-transfer-encoding vm-pgg-sign-text-transfer-encoding) (vm-mime-composition-armor-from-lines t)) (vm-pgp-prepare-composition)) (let ((content-type (vm-mail-mode-get-header-contents "Content-Type:")) (encoding (vm-mail-mode-get-header-contents "Content-Transfer-Encoding:")) (boundary (vm-pgg-make-multipart-boundary "pgp+signed")) (pgg-text-mode t) ;; For GNU Emacs PGG (micalg "sha1") entry body-start) ;; fix the body (setq body-start (vm-marker (vm-pgp-goto-body-start))) (insert "Content-Type: " (or content-type "text/plain") "\n") (insert "Content-Transfer-Encoding: " (or encoding "7bit") "\n") (if (not (looking-at "\n")) (insert "\n")) ;; now create the signature (save-excursion ;; BUGME do we need the CRLF conversion? ; (vm-pgg-make-crlf (point) (point-max)) (unless (pgg-sign-region body-start (point-max) nil) (pop-to-buffer pgg-errors-buffer) (error "Signing error")) (and (setq entry (assq 2 (pgg-parse-armor (with-current-buffer pgg-output-buffer (buffer-string))))) (setq entry (assq 'hash-algorithm (cdr entry))) (if (cdr entry) (setq micalg (downcase (format "%s" (cdr entry))))))) ;; insert mime part bounderies (goto-char body-start) (insert "This is an OpenPGP/MIME signed message (RFC 2440 and 3156)\n") (insert "--" boundary "\n") (goto-char (point-max)) (insert "\n--" boundary "\n") ;; insert the signature (insert "Content-Type: application/pgp-signature\n\n") (goto-char (point-max)) (insert-buffer-substring pgg-output-buffer) (insert "\n--" boundary "--\n") ;; fix the headers (vm-mail-mode-remove-header "MIME-Version:") (vm-mail-mode-remove-header "Content-Type:") (vm-mail-mode-remove-header "Content-Transfer-Encoding:") (mail-position-on-field "MIME-Version") (insert "1.0") (mail-position-on-field "Content-Type") (insert "multipart/signed; boundary=\"" boundary "\";\n" "\tmicalg=pgp-" micalg "; protocol=\"application/pgp-signature\""))) ;;; ###autoload (defun vm-pgg-encrypt (&optional sign) "Encrypt the composition as PGP/MIME. With a prefix arg SIGN also sign it." (interactive "P") (vm-pgg-save-work 'vm-pgg-encrypt-internal sign)) (defun vm-pgg-encrypt-internal (sign) "Do the encrypting, if SIGN is t also sign it." (unless (vm-mail-mode-get-header-contents "MIME-Version:") (if vm-do-fcc-before-mime-encode (vm-do-fcc-before-mime-encode)) (vm-mime-encode-composition)) (let ((content-type (vm-mail-mode-get-header-contents "Content-Type:")) (encoding (vm-mail-mode-get-header-contents "Content-Transfer-Encoding:")) (boundary (vm-pgg-make-multipart-boundary "pgp+encrypted")) (pgg-text-mode t) ;; For GNU Emacs PGG body-start) ;; fix the body (setq body-start (vm-marker (vm-pgp-goto-body-start))) (insert "Content-Type: " (or content-type "text/plain") "\n") (insert "Content-Transfer-Encoding: " (or encoding "7bit") "\n") (insert "\n") (goto-char (point-max)) (insert "\n") (vm-pgg-cleartext-encrypt sign) (goto-char body-start) (insert "This is an OpenPGP/MIME encrypted message (RFC 2440 and 3156)\n") (insert "--" boundary "\n") (insert "Content-Type: application/pgp-encrypted\n\n") (insert "Version: 1\n\n") (insert "--" boundary "\n") (insert "Content-Type: application/octet-stream\n\n") (goto-char (point-max)) (insert "\n--" boundary "--\n") ;; fix the headers (vm-mail-mode-remove-header "MIME-Version:") (vm-mail-mode-remove-header "Content-Type:") (vm-mail-mode-remove-header "Content-Transfer-Encoding:") (mail-position-on-field "MIME-Version") (insert "1.0") (mail-position-on-field "Content-Type") (insert "multipart/encrypted; boundary=\"" boundary "\";\n" "\tprotocol=\"application/pgp-encrypted\""))) (defun vm-pgg-sign-and-encrypt () "*Sign and encrypt the composition as PGP/MIME." (interactive) (vm-pgg-encrypt t)) (defvar vm-pgg-prompt-last-action nil "The action last taken in `vm-pgg-prompt-for-action'.") (defvar vm-pgg-prompt-action-alist '((?s sign "Sign") (?e encrypt "encrypt") (?E sign-and-encrypt "both") (?n nil "nothing") (?q quit "quit")) "Alist of (KEY ACTION LABEL) elements.") (defun vm-pgg-prompt-for-action () "Prompt for an action and return it. See also `vm-pgg-prompt-action-alist'." (interactive) (let (prompt event action) (setq prompt (mapconcat (lambda (a) (format "%s (%c)" (nth 2 a) (car a))) vm-pgg-prompt-action-alist ", ") action (mapcar (lambda (a) (if (eq (nth 1 a) vm-pgg-prompt-last-action) (downcase (nth 2 a)))) vm-pgg-prompt-action-alist) prompt (format "%s (default %s)?" prompt (car (delete nil action))) action nil) (while (not event) (setq event (read-key-sequence prompt)) (if (featurep 'xemacs) (setq event (event-to-character (aref event 0))) (setq event (if (stringp event) (aref event 0)))) (if (eq event ?\r) (setq action vm-pgg-prompt-last-action) (setq action (assoc event vm-pgg-prompt-action-alist)) (if action (setq action (nth 1 action)) (setq event nil)))) (when (eq action 'quit) (error "Sending aborted!")) (if action (message "Action is %s." action) (message "No action selected.")) (setq vm-pgg-prompt-last-action action) action)) ;;; ###autoload (defun vm-pgg-ask-hook () "Hook to automatically ask for signing or encrypting outgoing messages with PGP/MIME. Put this function into `vm-mail-send-hook' to be asked each time you send a message whether or not you want to sign or encrypt the message. See `vm-pgg-ask-function' to determine which function is proposed. This hook should probably be the last of your hooks if you have several other functions there. Signing crucially relies on the fact that the message is not altered afterwards. To put it into `vm-mail-send-hook' put something like (add-hook 'vm-mail-send-hook 'vm-pgg-ask-hook t) into your VM init file." (interactive) ;; ensure we are the last hook (when (and (member 'vm-pgg-ask-hook vm-mail-send-hook) (cdr (member 'vm-pgg-ask-hook vm-mail-send-hook))) (describe-function 'vm-pgg-ask-hook) (error "`vm-pgg-ask-function' must be the last hook in `vm-mail-send-hook'!")) (let ((handler vm-pgg-ask-function) action) (when handler (setq action (if (fboundp handler) (funcall handler) (if (y-or-n-p (format "%s the composition? " handler)) handler))) (when action (funcall (intern (format "vm-pgg-%s" action))))))) (provide 'vm-pgg) ;;; vm-pgg.el ends here vm-8.2.0b/lisp/vm-pine.el0000755000175000017500000012714611676442160015450 0ustar srivastasrivasta;;; vm-pine.el --- draft handling and other neat functions for VM ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 1998-2006 Robert Fenk ;; ;; Author: Robert Fenk ;; Status: Tested with XEmacs 21.4.19 & VM 7.19 ;; Keywords: vm draft handling ;; X-URL: http://www.robf.de/Hacking/elisp ;; ;; This code is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 1, or (at your option) ;; any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; ;;; Commentary: ;; ;; This package provides the following new features for VM: ;; ;; A Pine-like postpone message function and folder. There are two new ;; functions. `vm-postpone-message' bound to [C-c C-d] in ;; the `vm-mail-mode' and the function `vm-continue-postponed-message' ;; is bound to [C] in a folder buffer. ;; ;; Typical usage: If you are writing a mail message, and you wish to ;; postpone it for a while, hit C-c C-d. The message will be saved in ;; a folder called "postponed" by default. Later, when you wish to ;; resume editing that file, visit the "postponed" folder, find the ;; message you wish to continue editing, and then hit C to resume ;; editing. ;; ;; Furthermore, this facility can be configured, using ;; `vm-continue-what-message' to imitate Pine's message composing. ;; You can set `vm-mode-map' in the following way to get Pine-like ;; behaviour: ;; ;; (define-key vm-mode-map "m" 'vm-continue-what-message) ;; (setq vm-zero-drafts-start-compose t) ;; ;; If you have postponed messages you will be asked if you want to continue ;; composing them, if you say "yes" you will visit the `vm-postponed-folder' ;; and you can select the message you would like to continue and press "m" ;; again! However be aware this works currently only if you expunge all ;; messages marked for deletion and save the postponed folder. ;; ;; You can also bind it to "C-x m" in order to check for postponed messages ;; when composing a message without starting VM. ;; ;; (autoload 'vm-continue-what-message-other-window "vm-pine" "" t) ;; (global-set-key "\C-xm" 'vm-continue-what-message-other-window) ;; ;; ;; Three new mail header insertion functions make life easier. The ;; bindings and names are: ;; "\C-c\C-f\C-a" vm-mail-return-receipt-to ;; "\C-c\C-f\C-p" vm-mail-priority ;; "\C-c\C-f\C-f" vm-mail-fcc ;; The variables `vm-mail-return-receipt-to' and `vm-mail-priority' ;; can be used to configure the inserted headers. ;; `vm-mail-fcc' can be configured by setting the variable ;; `vm-mail-folder-alist' which has the same syntax and default ;; value as `vm-auto-folder-alist'. ;; You may also add `vm-mail-auto-fcc' to `vm-reply-hook' in order to ;; automatically setup the FCC header according to the variable ;; `vm-mail-folder-alist'. ;; There is another fcc-function `vm-mail-to-fcc' which set the FCC ;; according to the recipients email-address. ;; ;;; Bug reports and feature requests: ;; Please send a backtrace and the version number of vm-pine.el! ;; Feature requests are welcome! ;;; Code: (provide 'vm-pine) (eval-when-compile (require 'vm-misc) (require 'vm-folder) (require 'vm-summary) (require 'vm-window) (require 'vm-minibuf) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-mime) (require 'vm-reply) ) (declare-function deiconify-frame "vm-xemacs" (&optional frame)) (declare-function frames-of-buffer "vm-xemacs" (&optional buffer visible-only)) (declare-function user-mail-address "vm-xemacs" ()) (declare-function vm-session-initialization "vm" ()) (declare-function vm-visit-folder "vm" (folder &optional read-only)) (declare-function bbdb-extract-address-components "ext:bbdb" (adstring &optional ignore-errors)) (declare-function bbdb/vm-alternate-full-name "ext:bbdb-vm" (address)) (if (not (boundp 'user-mail-address)) (if (functionp 'user-mail-address) (setq user-mail-address (user-mail-address)) (setq user-mail-address "unknown") (message "Please set the variable `user-mail-address'") (sit-for 2))) ; Group already defined in vm-vars.el ;; (defgroup vm nil ;; "VM" ;; :group 'mail) (defgroup vm-pine nil "Pine inspired extensions to VM." :group 'vm-ext) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-summary-function-f (m) "Return the recipient or newsgroup for uninteresting senders. If the \"From:\" header contains the user login or full name then this function returns the \"To:\" or \"Newsgroups:\" header field with a \"To:\" as prefix. For example the outgoing message box will now list to whom you sent the messages. Use `vm-fix-summary' to update the summary of a folder! With loaded BBDB it uses `vm-summary-function-B' to obtain the full name of the sender. The only difference to VMs default behavior is the honoring of messages sent to news groups. ;c) See also: `vm-summary-uninteresting-senders'" (interactive) (let ((case-fold-search t) (headers '(("From:" "") ("Newsgroups:" "News:") "To:" "CC:" "BCC:" "Resent-To:" "Resent-CC:" "Resent-BCC:" ("Sender:" "") ("Resent-From:" "Resent:"))) header-name arrow addresses address first) (while (and (not address) headers) (if (listp (car headers)) (setq header-name (caar headers) arrow (cadar headers)) (setq header-name (car headers) arrow (concat header-name " "))) (setq addresses (vm-get-header-contents m header-name)) (if addresses (setq addresses (vm-decode-mime-encoded-words-in-string addresses) addresses (or (if (functionp 'bbdb-extract-address-components) (bbdb-extract-address-components addresses t)) (list (mail-extract-address-components addresses)) addresses))) (if (not first) (setq first (car addresses))) (while addresses (if (or (not vm-summary-uninteresting-senders) (and vm-summary-uninteresting-senders (not (string-match vm-summary-uninteresting-senders (format "%s" (car addresses)))))) (setq address (car addresses) addresses nil)) (setq addresses (cdr addresses))) (setq headers (cdr headers))) (if (and (null address) (null first)) "" (if (and (null address) first) (setq address first)) (concat arrow (cond ((functionp 'bbdb/vm-alternate-full-name) (or (bbdb/vm-alternate-full-name (cadr address)) (car address) (cadr address))) (t (or (car address) (cadr address)))))))) ;;----------------------------------------------------------------------------- ;;;###autoload (defcustom vm-postponed-header "X-VM-postponed-data: " "Additional header which is inserted to postponed messages. It is used for internal things and should not be modified. It is a lisp list which currently contains the following items: while the last three are set by `vm-get-persistent-message-ids-for'." :type 'string :group 'vm-pine) ;;----------------------------------------------------------------------------- ;; A Pine-like postponed folder handling ;;;###autoload (defcustom vm-postponed-folder "postponed" "The name of the folder where postponed messages are saved." :type 'string :group 'vm-pine) ;;;###autoload (defcustom vm-postponed-message-headers '("From:" "Organization:" "Reply-To:" "To:" "Newsgroups:" "CC:" "BCC:" "FCC:" "In-Reply-To:" "References:" "Subject:" "X-Priority:" "Priority:") "Similar to `vm-forwarded-headers'. A list of headers that should be kept, when continuing a postponed message. The following mime headers should not be kept, since this breaks things: Mime-Version, Content-Type, Content-Transfer-Encoding." :type '(repeat (string)) :group 'vm-pine) ;;;###autoload (defcustom vm-postponed-message-discard-header-regexp nil "Similar to `vm-unforwarded-header-regexp'. A regular expression matching all headers that should be discard when when continuing a postponed message." :type 'regexp :group 'vm-pine) ;;;###autoload (defcustom vm-continue-postponed-message-hook nil "List of hook functions to be run after continuing a postponed message." :type 'hook :group 'vm-pine) ;;;###autoload (defcustom vm-postpone-message-hook nil "List of hook functions to be run before postponing a message." :type 'hook :group 'vm-pine) (defvar vm-postponed-message-folder-buffer nil "Buffer of source folder. This is only for internal use of vm-pine.el!!!") ;;----------------------------------------------------------------------------- ;; (define-key vm-mode-map "C" 'vm-continue-what-message) ;;----------------------------------------------------------------------------- (defun vm-get-persistent-message-ids-for (mlist) "Return a list of message id and folder name of all messages in MLIST." (let (mp midlist folder mid f) (while mlist (setq mp (car mlist) folder (buffer-file-name (vm-buffer-of (vm-real-message-of mp))) mid (vm-message-id-of mp) f (assoc folder midlist)) (if mid (if f (setcdr f (cons mid (cdr f))) (add-to-list 'midlist (list folder mid)))) (setq mlist (cdr mlist))) midlist)) (defun vm-get-message-pointers-for (msgidlist) "Return the message pointers belonging to the messages listed in MSGIDLIST. MSGIDLIST is a list as returned by `vm-get-persistent-message-ids-for'." (let (folder vm-message-pointers) (while msgidlist (setq folder (caar msgidlist)) (save-excursion (when (cond ((get-buffer folder) (set-buffer (get-buffer folder))) ((get-file-buffer folder) (set-buffer (get-file-buffer folder))) ((file-exists-p folder) (vm-visit-folder folder)) (t (message "The folder '%s' does not exist anymore. Maybe it was virtual or closed before postponing." folder) nil)) (vm-select-folder-buffer) (save-restriction (widen) (goto-char (point-min)) (let ((msgid-regexp (concat "^Message-Id:\\s-*" (regexp-opt (cdar msgidlist)))) (point-max (point-max)) (case-fold-search t)) (while (re-search-forward msgid-regexp point-max t) (let ((point (point)) (mp vm-message-list)) (while mp (if (and (>= point (vm-start-of (car mp))) (<= point (vm-end-of (car mp)))) (setq vm-message-pointers (cons (car mp) vm-message-pointers) mp nil) (setq mp (cdr mp))))))))) (setq msgidlist (cdr msgidlist)))) vm-message-pointers)) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-continue-postponed-message (&optional silent) "Continue composing of the currently selected message. Before continuing the composition you may decode the presentation as you like, by pressing [D] and viewing part of the message! Then current message is copied to a new buffer and the vm-mail-mode is entered. When every thing is finished the hook functions in `vm-mail-mode-hook' and `vm-continue-postponed-message-hook' are executed. When called with a prefix argument it will not switch to the composition buffer, this may be used for automatic editing of messages. The variables `vm-postponed-message-headers' and `vm-postponed-message-discard-header-regexp' control which headers are copied to the composition buffer. If optional argument SILENT is positive then act in background (no frame creation)." (interactive "P") (vm-session-initialization) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if (eq vm-system-state 'previewing) (vm-show-current-message)) (save-restriction (widen) (let* ((folder-buffer (current-buffer)) (presentation-buffer vm-presentation-buffer) (vmp vm-message-pointer) (is-decoded vm-mime-decoded) (hstart (vm-headers-of (car vmp))) (tstart (vm-text-of (car vmp))) (tend (- (vm-end-of (car vmp)) 1)) (to (format "mail to %s" (vm-get-header-contents (car vmp) "To:" ","))) (vm-pp-data (vm-get-header-contents (car vmp) vm-postponed-header))) ;; Prepare the composition buffer (if (and to (string-match "[^,\n<(]+" to)) (setq to (match-string 0 to))) (if (not silent) (let ((vm-mail-hook nil) (vm-mail-mode-hook nil) (this-command 'vm-mail)) (vm-mail-internal :to to)) (set-buffer (generate-new-buffer to)) (setq default-directory (expand-file-name (or vm-folder-directory "~/"))) (auto-save-mode (if auto-save-default 1 -1)) (let ((mail-mode-hook nil) (mail-setup-hook nil)) (mail-mode)) (setq vm-mail-buffer folder-buffer)) (make-local-variable 'vm-postponed-message-folder-buffer) (setq vm-postponed-message-folder-buffer (vm-buffer-of (vm-real-message-of (car vmp)))) (make-local-variable 'vm-message-pointer) (setq vm-message-pointer vmp) (vm-make-local-hook 'mail-send-hook) (add-hook 'mail-send-hook 'vm-delete-postponed-message t t) (erase-buffer) ;; set the VM variables for setting source message attributes (when vm-pp-data (make-local-variable 'vm-reply-list) (make-local-variable 'vm-forward-list) (make-local-variable 'vm-redistribute-list) (setq vm-pp-data (read vm-pp-data) vm-reply-list (and (nth 1 vm-pp-data) (vm-get-message-pointers-for (nth 1 vm-pp-data))) vm-forward-list (and (nth 2 vm-pp-data) (vm-get-message-pointers-for (nth 2 vm-pp-data))) vm-redistribute-list (and (nth 3 vm-pp-data) (vm-get-message-pointers-for (nth 3 vm-pp-data)))) (if vm-reply-list (setq vm-system-state 'replying)) (if vm-forward-list (setq vm-system-state 'forwarding)) (if vm-redistribute-list (setq vm-system-state 'redistributing))) ;; Prepare headers (insert-buffer-substring folder-buffer hstart tstart) (goto-char (point-min)) (cond ((or (vm-mime-plain-message-p (car vmp)) is-decoded) (vm-reorder-message-headers nil :keep-list vm-postponed-message-headers :discard-regexp vm-postponed-message-discard-header-regexp)) (t ; copy undecoded messages with mime headers (vm-reorder-message-headers nil :keep-list (append '("MIME-Version:" "Content-type:") vm-postponed-message-headers) :discard-regexp vm-postponed-message-discard-header-regexp))) (vm-decode-mime-encoded-words) (search-forward-regexp "\n\n") (replace-match (concat "\n" mail-header-separator "\n") t t) ;; Add message body as previewed (goto-char (point-max)) (if presentation-buffer ;; when using presentation buffer we have to (save-excursion (set-buffer presentation-buffer) (goto-char (point-min)) (search-forward-regexp "\n\n") (setq tstart (match-end 0) tend (point-max))) (setq presentation-buffer folder-buffer)) (insert-buffer-substring presentation-buffer tstart tend) ;; in order to show headers hidden by vm-shrunken-headers (put-text-property (point-min) (point-max) 'invisible nil) ;; and add the buttons for attachments (vm-mime-convert-to-attachment-buttons))) (when (not silent) (run-hooks 'mail-setup-hook) (run-hooks 'vm-mail-hook) (run-hooks 'vm-mail-mode-hook)) (run-hooks 'vm-continue-postponed-message-hook)) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-reply-by-continue-postponed-message () "Like `vm-reply' but preserves attachments." (interactive) (let ((vm-continue-postponed-message-hook) (vm-reply-hook nil) (vm-mail-mode-hook nil) (mail-setup-hook nil) (mail-signature nil) reply-buffer start end) (vm-reply 1) (save-excursion (vm-continue-postponed-message t) (goto-char (point-min)) (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") (point-max)) (forward-char 1) (setq reply-buffer (current-buffer) start (point) end (point-max))) (goto-char (point-max)) (insert-buffer-substring reply-buffer start end) (vm-add-reply-subject-prefix (car vm-message-pointer))) (run-hooks 'mail-setup-hook) (run-hooks 'vm-mail-hook) (run-hooks 'vm-mail-mode-hook) (run-hooks 'vm-reply-hook)) ;;----------------------------------------------------------------------------- (defun vm-delete-postponed-message () "Delete the source message belonging to the continued composition." (interactive) (if vm-message-pointer (condition-case nil (let* ((msg (car vm-message-pointer)) (buffer (vm-buffer-of msg))) ;; only delete messages which have been postponed by us before (when (vm-get-header-contents msg vm-postponed-header) (vm-set-deleted-flag msg t) (vm-update-summary-and-mode-line)) ;; in the postponded folder expunge them right now (when (string= (buffer-name buffer) (file-name-nondirectory vm-postponed-folder)) (if (frames-of-buffer buffer t) (iconify-frame (car (frames-of-buffer buffer)))) (save-excursion (switch-to-buffer buffer) (vm-expunge-folder) (vm-save-folder) (when (not vm-message-list) (let ((this-command 'vm-quit)) (vm-quit)))))) (error "Folder buffer closed before deletion of source message.")))) ;;----------------------------------------------------------------------------- ;; The following functions have been integrated into vm-mime.el ;; USR, 2011-01-25 (defalias 'vm-decode-postponed-mime-message 'vm-mime-convert-to-attachment-buttons) (make-obsolete 'vm-decode-postponed-mime-message 'vm-mime-convert-to-attachment-buttons "8.2.0") (defalias 'vm-pine-fake-attachment-overlays 'vm-mime-re-fake-attachment-overlays) (make-obsolete 'vm-pine-fake-attachment-overlays 'vm-mime-re-fake-attachment-overlays "8.2.0") (defalias 'vm-decode-postponed-mime-button 'vm-mime-replace-by-attachment-button) (make-obsolete 'vm-decode-postponed-mime-button 'vm-mime-replace-by-attachment-button "8.2.0") ;;----------------------------------------------------------------------------- (define-key vm-mail-mode-map "\C-c\C-d" 'vm-postpone-message) (defvar vm-postpone-message-modes-to-disable '(font-lock-mode ispell-minor-mode filladapt-mode auto-fill-mode) "A list of modes to disable before postponing a message.") ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-postpone-message (&optional folder dont-kill no-postpone-header) "Save the current composition as a draft. Before saving the composition the `vm-postpone-message-hook' functions are executed and it is written into the FOLDER `vm-postponed-folder'. When called with a prefix argument you will be asked for the folder. Optional argument DONT-KILL is positive, then do not kill source message." (interactive "P") (let ((message-buffer (current-buffer)) folder-buffer target-type) (let (m (modes vm-postpone-message-modes-to-disable)) (while modes (setq m (car modes) modes (cdr modes)) (if (and (boundp m) (symbol-value m)) (funcall m 0)))) (if (and folder (not (stringp folder))) (setq folder (vm-read-file-name (format "Postpone to folder (%s): " vm-postponed-folder) (or vm-folder-directory default-directory) vm-postponed-folder nil nil 'vm-folder-history))) ;; there is no explicit folder given ... (if (not folder) (if vm-postponed-message-folder-buffer (setq folder (buffer-file-name vm-postponed-message-folder-buffer)) (setq folder (expand-file-name vm-postponed-folder (or vm-folder-directory default-directory))))) (if (not folder) (error "I could not find a folder for postponing messages!")) ;; if it is no absolute folder path then prepend the folder directory (if (not (file-name-absolute-p folder)) (setq folder (expand-file-name folder (or vm-folder-directory default-directory)))) ;; Now add possibly missing headers (goto-char (point-min)) (vm-mail-mode-show-headers) (if (not (vm-mail-mode-get-header-contents "From:")) (let* ((login user-mail-address) (fullname (user-full-name))) (cond ((and (eq mail-from-style 'angles) login fullname) (insert (format "From: %s <%s>\n" fullname login))) ((and (eq mail-from-style 'parens) login fullname) (insert (format "From: %s (%s)\n" login fullname))) (t (insert (format "From: %s\n" login)))))) ;; mime-encode the message if necessary and add "attachment" disposition (condition-case nil (vm-mime-encode-composition t) (error t)) ;; add the current date (if (not (vm-mail-mode-get-header-contents "Date:")) (insert "Date: " (format-time-string "%a, %d %b %Y %H:%M:%S %Z" (current-time)) "\n")) ;; add the postponed header (vm-mail-mode-remove-header vm-postponed-header) (if no-postpone-header nil (insert vm-postponed-header " " (format "(\"%s\" %S %S %S)\n" (format-time-string "%a, %d %b %Y %T %Z" (current-time)) (vm-get-persistent-message-ids-for vm-reply-list) (vm-get-persistent-message-ids-for vm-forward-list) (vm-get-persistent-message-ids-for vm-redistribute-list)))) ;; ensure that the message ends with an empty line! (goto-char (point-max)) (skip-chars-backward " \t\n") (delete-region (point) (point-max)) (insert "\n\n\n") ;; run the hooks (run-hooks 'vm-postpone-message-hook) ;; delete mail header separator (goto-char (point-min)) (if (re-search-forward (concat "^\\(" (regexp-quote mail-header-separator) "\\)$") nil t) (delete-region (match-beginning 0) (match-end 0))) (setq folder-buffer (vm-get-file-buffer folder)) (if folder-buffer ;; o.k. the folder is already opened (save-excursion (set-buffer folder-buffer) (vm-error-if-folder-read-only) (let ((buffer-read-only nil)) (vm-save-restriction (widen) (goto-char (point-max)) (vm-write-string (current-buffer) (vm-leading-message-separator)) (insert-buffer-substring message-buffer) (vm-write-string (current-buffer) (vm-trailing-message-separator)) (cond ((eq major-mode 'vm-mode) (vm-increment vm-messages-not-on-disk) (vm-clear-modification-flag-undos))) (vm-check-for-killed-summary) (vm-assimilate-new-messages) (vm-update-summary-and-mode-line)))) ;; well the folder is not visited, so we write to the file (setq target-type (or (vm-get-folder-type folder) vm-default-folder-type)) (if (eq target-type 'unknown) (error "Folder `%s' type is unrecognized" folder)) (vm-write-string folder (vm-leading-message-separator target-type)) (write-region (point-min) (point-max) folder t 'quiet) (vm-write-string folder (vm-trailing-message-separator target-type))) ;; delete source message (vm-delete-postponed-message) ;; mess around with the window configuration (let ((b (current-buffer)) (this-command 'vm-mail-send-and-exit)) (cond ((null (buffer-name b));; dead buffer ;; This improves window configuration behavior in ;; XEmacs. It avoids taking the folder buffer from ;; one frame and attaching it to the selected frame. (set-buffer (window-buffer (selected-window))) (vm-display nil nil '(vm-mail-send-and-exit) '(vm-mail-send-and-exit reading-message startup))) (t (vm-display b nil '(vm-mail-send-and-exit) '(vm-mail-send-and-exit reading-message startup))))) ;; and kill this buffer? (if dont-kill (insert (concat "FCC: " folder "\n" mail-header-separator)) (kill-this-buffer)) (if (vm-interactive-p) (message "Message postponed to folder `%s'" folder)))) ;;----------------------------------------------------------------------------- (defun vm-buffer-in-vm-mode () (member major-mode '(vm-mode vm-virtual-mode vm-presentation-mode vm-summary-mode vm-mail-mode))) (defcustom vm-continue-what-message 'ask "Whether to never continue, ask or always continue postponed messages." :type '(choice (const :tag "never" nil) (const ask) (const continue)) :group 'vm-pine) (defcustom vm-zero-drafts-start-compose nil "When t and there are no drafts, `vm-continue-what-message' call `vm-mail'." :type '(choice (const :tag "do nothing" nil) (const :tag "start new message" t)) :group 'vm-pine) (defun vm-continue-what-message-composing () "Decide whether to compose a new message or continue a draft. This checks if the postponed folder contains drafts. Drafts in other folders are not recognized!" (save-excursion (vm-session-initialization) (let* ((ppfolder (and vm-postponed-folder (expand-file-name vm-postponed-folder (or vm-folder-directory default-directory)))) action buffer) (when current-prefix-arg (setq action 'force-continue)) (when (vm-find-composition-buffer) (setq action 'continue)) ;; postponed message in current folder (when (vm-buffer-in-vm-mode) (vm-check-for-killed-folder) (vm-select-folder-buffer) (if (and vm-message-pointer (vm-get-header-contents (vm-real-message-of (car vm-message-pointer)) (regexp-quote vm-postponed-header)) (not (vm-deleted-flag (car vm-message-pointer)))) (setq action 'continue))) ;; postponed message in postponed folder (when (and (not action) (setq buffer (vm-get-file-buffer ppfolder))) (if (and (get-buffer-window-list buffer nil 0)) (when (save-excursion (set-buffer buffer) (not (vm-deleted-flag (car vm-message-pointer)))) (message "Please select a draft!") (select-window (car (get-buffer-window-list buffer nil 0))) (if (and vm-xemacs-p (frames-of-buffer buffer)) (deiconify-frame (car (frames-of-buffer buffer)))) (setq action 'none)) (setq action 'visit))) ;; visit postponed folder (when (and (not action) (file-exists-p ppfolder) (> (nth 7 (file-attributes ppfolder)) 0)) (setq action 'visit)) (if (not action) (setq action 'new)) ;; decide what to do (setq action (cond ((eq vm-continue-what-message nil) 'new) ((eq vm-continue-what-message 'ask) (if (equal action 'visit) (if (y-or-n-p "Continue composition of postponed messages? ") 'visit 'new) action)) ((eq vm-continue-what-message 'continue) action) (t action)))))) ;;;###autoload (defun vm-continue-what-message (&optional where) "Continue compositions or postponed messages if there are some. With a prefix arg, call `vm-continue-postponed-message', i.e. continue the currently selected message. See `vm-continue-what-message' and `vm-zero-drafts-start-compose' for configuration." (interactive) (if where (setq where (concat "-" where))) (let ((action (vm-continue-what-message-composing)) (visit (intern (concat "vm-visit-folder" (or where "")))) (mail (intern (concat "vm-mail" (or where ""))))) (cond ((equal action 'force-continue) (vm-continue-postponed-message)) ((equal action 'continue) (if (vm-find-composition-buffer) (vm-continue-composing-message) (vm-continue-postponed-message))) ((equal action 'visit) (funcall visit vm-postponed-folder) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (vm-make-local-hook 'vm-quit-hook) (add-hook 'vm-quit-hook 'vm-expunge-folder nil t) (vm-expunge-folder) (cond ((= (length vm-message-list) 0) (let ((this-command 'vm-quit)) (vm-quit)) (let ((this-command mail)) (funcall mail))) ((= (length vm-message-list) 1) (vm-continue-postponed-message)))) ((and vm-zero-drafts-start-compose (equal action 'new)) (let ((this-command mail)) (funcall mail))) (t (message "There are no known drafts."))))) ;;;###autoload (defun vm-continue-what-message-other-window () "Ask for continuing of postponed messages if there are some." (interactive) (vm-continue-what-message "other-window")) ;;;###autoload (defun vm-continue-what-message-other-frame () "Ask for continuing of postponed messages if there are some." (interactive) (vm-continue-what-message "other-frame")) ;;----------------------------------------------------------------------------- ;; And now do some cool stuff when killing a mail buffer ;; This was inspired by Uwe Brauer (defcustom vm-save-killed-message 'ask "How `vm-save-killed-message-hook' handles saving of a mail as a draft. If set to 'ask it will ask whether to save the mail as draft or not. If set to 'always it will save without asking. If set to nil it will never save them nor it will ask." :type '(choice (const ask) (const always) (const :tag "never" nil)) :group 'vm-pine) (defcustom vm-save-killed-messages-folder vm-postponed-folder "The name of the folder where killed messages are saved." :type 'string :group 'vm-pine) (defun vm-add-save-killed-message-hook () (vm-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'vm-save-killed-message-hook nil t)) (defun vm-remove-save-killed-message-hook () (remove-hook 'kill-buffer-hook 'vm-save-killed-message-hook t)) (defun vm-save-killed-message-hook () (if (or (and (equal vm-save-killed-message 'ask) (y-or-n-p (format "Save `%s' as draft in folder `%s'? " (buffer-name) vm-save-killed-messages-folder))) (equal vm-save-killed-message 'always)) (vm-postpone-message vm-save-killed-messages-folder t) (message "`%s' is gone forever!" (buffer-name)))) (add-hook 'vm-mail-mode-hook 'vm-add-save-killed-message-hook) (add-hook 'mail-send-hook 'vm-remove-save-killed-message-hook) (add-hook 'vm-postpone-message-hook 'vm-remove-save-killed-message-hook) ;;----------------------------------------------------------------------------- ;; New header fields (define-key vm-mail-mode-map "\C-c\C-f\C-a" 'vm-mail-return-receipt-to) (define-key vm-mail-mode-map "\C-c\C-f\C-p" 'vm-mail-priority) (define-key vm-mail-mode-map "\C-c\C-f\C-f" 'vm-mail-fcc) (define-key vm-mail-mode-map "\C-c\C-f\C-n" 'vm-mail-notice-requested-upon-delivery-to) ;;;###autoload (defcustom vm-mail-return-receipt-to (concat (user-full-name) " <" user-mail-address ">") "The address where return receipts should be sent to." :type 'string :group 'vm-pine) ;;;###autoload (defun vm-mail-return-receipt-to () "Insert the \"Return-Receipt-To\" header into a `vm-mail-mode' buffer. See the variable `vm-mail-return-receipt-to'." (interactive) (expand-abbrev) (save-excursion (or (mail-position-on-field "Return-Receipt-To" t) (progn (mail-position-on-field "Subject") (insert "\nReturn-Receipt-To: " vm-mail-return-receipt-to "\nRead-Receipt-To: " vm-mail-return-receipt-to "\nDelivery-Receipt-To: " vm-mail-return-receipt-to)))) (message "Remove those headers you do not require!")) ;;;###autoload (defun vm-mail-notice-requested-upon-delivery-to () "Notice-Requested-Upon-Delivery-To:" (interactive) (expand-abbrev) (save-excursion (or (mail-position-on-field "Notice-Requested-Upon-Delivery-To" t) (progn (mail-position-on-field "Subject") (insert "\nNotice-Requested-Upon-Delivery-To: " (let ((to (vm-mail-get-header-contents "\\(.*-\\)?To:"))) (if to to ""))))))) ;;;###autoload (defcustom vm-mail-priority "Priority: urgent\nImportance: High\nX-Priority: 1" "The priority headers." :type 'string :group 'vm-pine) ;;;###autoload (defun vm-mail-priority () "Insert priority headers into a `vm-mail-mode' buffer. See the variable `vm-mail-priority'." (interactive) (expand-abbrev) (save-excursion (or (mail-position-on-field "Priority" t) (progn (mail-position-on-field "Subject") (insert "\n" vm-mail-priority))))) ;;----------------------------------------------------------------------------- (if (not vm-xemacs-p) (defun user-home-directory () (getenv "HOME"))) (defun vm-mail-fcc-file-join (dir file) "Returns a nice path to a folder." (let* ((path (expand-file-name file dir))) (if path (vm-abbreviate-file-name path) dir))) ;;;###autoload (defcustom vm-mail-folder-alist (if (boundp 'vm-auto-folder-alist) vm-auto-folder-alist) "Like `vm-auto-folder-alist' but for outgoing messages. It should be fed to `vm-mail-select-folder'." :type 'list :group 'vm-pine) ;;;###autoload (defcustom vm-mail-fcc-default '(or (vm-mail-select-folder vm-mail-folder-alist) (vm-mail-to-fcc nil t) mail-archive-file-name) "A list which is evaluated to return a folder name. By reordering the elements of this list or adding own functions you can control the behavior of vm-mail-fcc and `vm-mail-auto-fcc'. You may allow a sophisticated decision for the right folder for your outgoing message." :type 'list :group 'vm-pine) ;;;###autoload (defun vm-mail-fcc (&optional arg) "Insert the FCC-header into a `vm-mail-mode' buffer. Like `mail-fcc', but honors VM variables and offers a default folder according to `vm-mail-folder-alist'. Called with prefix ARG it just removes the FCC-header." (interactive "P") (expand-abbrev) (let ((dir (or vm-folder-directory default-directory)) (fcc nil) (folder (vm-mail-mode-get-header-contents "FCC:")) (prompt nil)) (if arg (progn (vm-mail-mode-remove-header "FCC:") (message "FCC header removed!")) (save-excursion (setq fcc (eval vm-mail-fcc-default)) ;; cleanup the name (setq fcc (if fcc (vm-mail-fcc-file-join dir fcc))) (setq prompt (if fcc (format "FCC to folder (%s): " fcc) "FCC to folder: ")) (setq folder (if (and folder (not (file-directory-p folder))) (file-relative-name folder dir))) ;; we got the name so insert it (vm-mail-mode-remove-header "FCC:") (setq fcc (vm-read-file-name prompt dir fcc nil folder 'vm-folder-history)) (setq fcc (vm-mail-fcc-file-join dir fcc)) (if (file-directory-p fcc) (error "Folder `%s' in no file, but a directory!" fcc) (mail-position-on-field "FCC") (insert fcc)))))) ;;;###autoload (defun vm-mail-auto-fcc () "Add a new FCC field, with file name guessed by `vm-mail-folder-alist'. You likely want to add it to `vm-reply-hook' by (add-hook 'vm-reply-hook 'vm-mail-auto-fcc) or if sure about what you are doing you can add it to mail-send-hook." (interactive "") (expand-abbrev) (save-excursion (let ((dir (or vm-folder-directory default-directory)) (fcc nil)) (vm-mail-mode-remove-header "FCC:") (setq fcc (eval vm-mail-fcc-default)) (if fcc (if (file-directory-p fcc) (error "Folder `%s' in no file, but a directory!" fcc) (progn (mail-position-on-field "FCC") (insert (vm-mail-fcc-file-join dir fcc)))))))) ;;;###autoload (defun vm-mail-select-folder (folder-alist) "Return a folder according to FOLDER-ALIST for the current message. This function is a slightly changed version of `vm-auto-select-folder'." (interactive) (condition-case error-data (catch 'match (let (header tuple-list) (while folder-alist (setq header (vm-mail-get-header-contents (car (car folder-alist)) ", ")) (if (null header) () (setq tuple-list (cdr (car folder-alist))) (while tuple-list (if (let ((case-fold-search vm-auto-folder-case-fold-search)) (string-match (car (car tuple-list)) header)) ;; Don't waste time eval'ing an atom. (if (stringp (cdr (car tuple-list))) (throw 'match (cdr (car tuple-list))) (let* ((match-data (vm-match-data)) ;; allow this buffer to live forever (buf (get-buffer-create " *vm-auto-folder*")) (result)) ;; Set up a buffer that matches our cached ;; match data. (save-excursion (set-buffer buf) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for empty buffer (widen) (erase-buffer) (insert header) ;; It appears that get-buffer-create clobbers the ;; match-data. ;; ;; The match data is off by one because we matched ;; a string and Emacs indexes strings from 0 and ;; buffers from 1. ;; ;; Also store-match-data only accepts MARKERS!! ;; AUGHGHGH!! (store-match-data (mapcar (function (lambda (n) (and n (vm-marker n)))) (mapcar (function (lambda (n) (and n (1+ n)))) match-data))) (setq result (eval (cdr (car tuple-list)))) (while (consp result) (setq result (vm-mail-select-folder result))) (if result (throw 'match result)))))) (setq tuple-list (cdr tuple-list)))) (setq folder-alist (cdr folder-alist))) nil )) (error "Error processing folder-alist: %s" (prin1-to-string error-data)))) ;;;###autoload (defcustom vm-mail-to-regexp "\\([^<\t\n ]+\\)@" "A regexp matching the part of an email address to use as FCC-folder. The string enclosed in \"\\\\(\\\\)\" is used as folder name." :type 'regexp :group 'vm-pine) ;;;###autoload (defcustom vm-mail-to-headers '("To:" "CC:" "BCC:") "A list of headers for finding the email address to use as FCC-folder." :type '(repeat (string)) :group 'vm-pine) ;;;###autoload (defun vm-mail-to-fcc (&optional arg return-only) "Insert a FCC-header into a `vm-mail-mode' buffer. Like `mail-fcc', but honors VM variables and inserts the first email address (or the like matched by `vm-mail-to-regexp') found in the headers listed in `vm-mail-to-headers'. Called with prefix ARG it just removes the FCC-header. If optional argument RETURN-ONLY is t just returns FCC." (interactive "P") (expand-abbrev) (let ((fcc nil) (headers vm-mail-to-headers)) (if arg (progn (vm-mail-mode-remove-header "FCC:") (message "FCC header removed!")) (progn (while (and (not fcc) headers) (setq fcc (vm-mail-get-header-contents (car headers))) (if (and fcc (string-match vm-mail-to-regexp fcc)) (setq fcc (match-string 1 fcc)) (setq fcc nil)) (setq headers (cdr headers))) (setq fcc (or fcc mail-archive-file-name)) (if return-only fcc (if fcc (if (file-directory-p fcc) (error "Folder `%s' in no file, but a directory!" fcc) (vm-mail-mode-remove-header "FCC:") (mail-position-on-field "FCC") (insert (vm-mail-fcc-file-join (or vm-folder-directory default-directory) fcc))))))))) ;;----------------------------------------------------------------------------- ;;; vm-pine.el ends here vm-8.2.0b/lisp/vm-toolbar.el0000755000175000017500000006347311676442160016161 0ustar srivastasrivasta;;; vm-toolbar.el --- Toolbar related functions and commands ;; ;; This file is part of VM ;; ;; Copyright (C) 1995-1997, 2000, 2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-toolbar) (eval-when-compile (require 'vm-misc) (require 'vm-window) ) (declare-function vm-follow-summary-cursor "vm-motion" ()) (declare-function vm-mime-plain-message-p "vm-mime" (message)) (declare-function vm-save-message "vm-save" (folder &optional count mlist quiet)) (declare-function vm-auto-select-folder "vm-save" (mp auto-folder-alist)) (declare-function glyph-height "vm-xemacs" (glyph &optional window)) (declare-function glyph-width "vm-xemacs" (glyph &optional window)) (declare-function make-glyph "vm-xemacs" (&optional spec-list type)) (declare-function set-specifier "vm-xemacs" (specifier value &optional locale tag-set how-to-add)) (defvar vm-toolbar-specifier nil) (defvar right-toolbar) (defvar right-toolbar-width) (defvar left-toolbar) (defvar left-toolbar-width) (defvar bottom-toolbar) (defvar bottom-toolbar-height) (defvar top-toolbar) (defvar top-toolbar-height) (defconst vm-toolbar-next-button [vm-toolbar-next-icon vm-toolbar-next-command (vm-toolbar-any-messages-p) "Go to the next message.\n The command `vm-toolbar-next-command' is run, which is normally fbound to `vm-next-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-next-command 'some-other-command)"]) (defvar vm-toolbar-next-icon nil) (or (fboundp 'vm-toolbar-next-command) (fset 'vm-toolbar-next-command 'vm-next-message)) (defconst vm-toolbar-previous-button [vm-toolbar-previous-icon vm-toolbar-previous-command (vm-toolbar-any-messages-p) "Go to the previous message.\n The command `vm-toolbar-previous-command' is run, which is normally fbound to `vm-previous-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-previous-command 'some-other-command)"]) (defvar vm-toolbar-previous-icon nil) (or (fboundp 'vm-toolbar-previous-command) (fset 'vm-toolbar-previous-command 'vm-previous-message)) (defconst vm-toolbar-autofile-button [vm-toolbar-autofile-icon vm-toolbar-autofile-message (vm-toolbar-can-autofile-p) "Save the current message to a folder selected using vm-auto-folder-alist."]) (defvar vm-toolbar-autofile-icon nil) (defconst vm-toolbar-file-button [vm-toolbar-file-icon vm-toolbar-file-command (vm-toolbar-any-messages-p) "Save the current message to a folder.\n The command `vm-toolbar-file-command' is run, which is normally fbound to `vm-save-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-file-command 'some-other-command)"]) (defvar vm-toolbar-file-icon nil) (or (fboundp 'vm-toolbar-file-command) (fset 'vm-toolbar-file-command 'vm-save-message)) (defconst vm-toolbar-getmail-button [vm-toolbar-getmail-icon vm-toolbar-getmail-command (vm-toolbar-mail-waiting-p) "Retrieve spooled mail for the current folder.\n The command `vm-toolbar-getmail-command' is run, which is normally fbound to `vm-get-new-mail'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-getmail-command 'some-other-command)"]) (defvar vm-toolbar-getmail-icon nil) (or (fboundp 'vm-toolbar-getmail-command) (fset 'vm-toolbar-getmail-command 'vm-get-new-mail)) (defconst vm-toolbar-print-button [vm-toolbar-print-icon vm-toolbar-print-command (vm-toolbar-any-messages-p) "Print the current message.\n The command `vm-toolbar-print-command' is run, which is normally fbound to `vm-print-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-print-command 'some-other-command)"]) (defvar vm-toolbar-print-icon nil) (or (fboundp 'vm-toolbar-print-command) (fset 'vm-toolbar-print-command 'vm-print-message)) (defconst vm-toolbar-visit-button [vm-toolbar-visit-icon vm-toolbar-visit-command t "Visit a different folder.\n The command `vm-toolbar-visit-command' is run, which is normally fbound to `vm-visit-folder'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-visit-command 'some-other-command)"]) (defvar vm-toolbar-visit-icon nil) (or (fboundp 'vm-toolbar-visit-command) (fset 'vm-toolbar-visit-command 'vm-visit-folder)) (defconst vm-toolbar-reply-button [vm-toolbar-reply-icon vm-toolbar-reply-command (vm-toolbar-any-messages-p) "Reply to the current message.\n The command `vm-toolbar-reply-command' is run, which is normally fbound to `vm-followup-include-text'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-reply-command 'some-other-command)"]) (defvar vm-toolbar-reply-icon nil) (or (fboundp 'vm-toolbar-reply-command) (fset 'vm-toolbar-reply-command 'vm-followup-include-text)) (defconst vm-toolbar-forward-button [vm-toolbar-forward-icon vm-toolbar-forward-command (vm-toolbar-any-messages-p) "Forward the current message.\n The command `vm-toolbar-forward-command' is run, which is normally fbound to `vm-forward-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-forward-command 'some-other-command)"]) (defvar vm-toolbar-forward-icon nil) (or (fboundp 'vm-toolbar-forward-command) (fset 'vm-toolbar-forward-command 'vm-forward-message)) (defconst vm-toolbar-followup-button [vm-toolbar-followup-icon vm-toolbar-followup-command (vm-toolbar-any-messages-p) "Follow up the current message.\n The command `vm-toolbar-followup-command' is run, which is normally fbound to `vm-followup-message'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-followup-command 'some-other-command)"]) (defvar vm-toolbar-followup-icon nil) (or (fboundp 'vm-toolbar-followup-command) (fset 'vm-toolbar-followup-command 'vm-followup)) (defconst vm-toolbar-compose-button [vm-toolbar-compose-icon vm-toolbar-compose-command t "Compose a new message.\n The command `vm-toolbar-compose-command' is run, which is normally fbound to `vm-mail'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-compose-command 'some-other-command)"]) (defvar vm-toolbar-compose-icon nil) (or (fboundp 'vm-toolbar-compose-command) (fset 'vm-toolbar-compose-command 'vm-mail)) (defconst vm-toolbar-decode-mime-button [vm-toolbar-decode-mime-icon vm-toolbar-decode-mime-command (vm-toolbar-can-decode-mime-p) "Decode the MIME objects in the current message.\n The objects might be displayed immediately, or buttons might be displayed that you need to click on to view the object. See the documentation for the variables vm-mime-internal-content-types and vm-mime-external-content-types-alist to see how to control whether you see buttons or objects.\n The command `vm-toolbar-decode-mime-command' is run, which is normally fbound to `vm-decode-mime-messages'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-decode-mime-command 'some-other-command)"]) (defvar vm-toolbar-decode-mime-icon nil) (or (fboundp 'vm-toolbar-decode-mime-command) (fset 'vm-toolbar-decode-mime-command 'vm-decode-mime-message)) ;; The values of these two are used by the FSF Emacs toolbar ;; code. The values don't matter as long as they are different ;; (as compared with eq). Under XEmacs these values are ignored ;; and overwritten. (defvar vm-toolbar-delete-icon t) (defvar vm-toolbar-undelete-icon nil) (defconst vm-toolbar-delete/undelete-button [vm-toolbar-delete/undelete-icon vm-toolbar-delete/undelete-message (vm-toolbar-any-messages-p) "Delete the current message, or undelete it if it is already deleted."]) (defvar vm-toolbar-delete/undelete-icon nil) (make-variable-buffer-local 'vm-toolbar-delete/undelete-icon) (defvar vm-toolbar-help-icon nil) (defvar vm-toolbar-recover-icon nil) (defvar vm-toolbar-helper-icon nil) (make-variable-buffer-local 'vm-toolbar-helper-icon) (defconst vm-toolbar-help-button [vm-toolbar-helper-icon vm-toolbar-helper-command (vm-toolbar-can-help-p) "Don't Panic.\n VM uses this button to offer help if you're in trouble. Under normal circumstances, this button runs `vm-help'. If the current folder looks out-of-date relative to its auto-save file then this button will run `vm-recover-folder'. If there is mail waiting in one of the spool files associated with the current folder, and the `getmail' button is not on the toolbar, this button will run `vm-get-new-mail'. If the current message needs to be MIME decoded then this button will run 'vm-decode-mime-message'."]) (defvar vm-toolbar-helper-command nil) (make-variable-buffer-local 'vm-toolbar-helper-command) ;;;###autoload (defun vm-toolbar-helper-command () (interactive) (setq this-command vm-toolbar-helper-command) (call-interactively vm-toolbar-helper-command)) (defconst vm-toolbar-quit-button [vm-toolbar-quit-icon vm-toolbar-quit-command (vm-toolbar-can-quit-p) "Quit visiting this folder.\n The command `vm-toolbar-quit-command' is run, which is normally fbound to `vm-quit'. You can make this button run some other command by using a Lisp s-expression like this one in your .vm file: (fset 'vm-toolbar-quit-command 'some-other-command)"]) (defvar vm-toolbar-quit-icon nil) (or (fboundp 'vm-toolbar-quit-command) (fset 'vm-toolbar-quit-command 'vm-quit)) (defun vm-toolbar-any-messages-p () (condition-case nil (save-excursion (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) vm-message-list) (error nil))) ;;;###autoload (defun vm-toolbar-delete/undelete-message (&optional prefix-arg) (interactive "P") (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((current-prefix-arg prefix-arg)) (if (vm-deleted-flag (car vm-message-pointer)) (call-interactively 'vm-undelete-message) (call-interactively 'vm-delete-message)))) ;;;###autoload (defun vm-toolbar-can-autofile-p () (interactive) (condition-case nil (save-excursion (vm-check-for-killed-folder) (vm-select-folder-buffer-if-possible) (and vm-message-pointer (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) (error nil))) ;;;###autoload (defun vm-toolbar-autofile-message () (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-error-if-folder-read-only) (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) (if file (progn (vm-save-message file 1) (vm-inform 5 "Message saved to %s" file)) (error "No match for message in vm-auto-folder-alist.")))) (defun vm-toolbar-can-recover-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (and vm-folder-read-only buffer-file-name buffer-auto-save-file-name (null (buffer-modified-p)) (file-newer-than-file-p buffer-auto-save-file-name buffer-file-name))) (error nil))) (defun vm-toolbar-can-decode-mime-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (and vm-display-using-mime vm-message-pointer vm-presentation-buffer (not (vm-mime-plain-message-p (car vm-message-pointer))))) (error nil))) (defun vm-toolbar-can-quit-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (memq major-mode '(vm-mode vm-virtual-mode))) (error nil))) (defun vm-toolbar-mail-waiting-p () (condition-case nil (save-excursion (vm-select-folder-buffer) (or (not (natnump vm-mail-check-interval)) vm-spooled-mail-waiting)) (error nil))) (fset 'vm-toolbar-can-help-p 'vm-toolbar-can-quit-p) (defun vm-toolbar-update-toolbar () (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer))) (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon) (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)) (cond ((vm-toolbar-can-recover-p) (setq vm-toolbar-helper-command 'vm-recover-folder vm-toolbar-helper-icon vm-toolbar-recover-icon)) ((and (vm-toolbar-mail-waiting-p) (not (memq 'getmail vm-use-toolbar))) (setq vm-toolbar-helper-command 'vm-get-new-mail vm-toolbar-helper-icon vm-toolbar-getmail-icon)) ((and (vm-toolbar-can-decode-mime-p) (not vm-mime-decoded) (not (memq 'mime vm-use-toolbar))) (setq vm-toolbar-helper-command 'vm-decode-mime-message vm-toolbar-helper-icon vm-toolbar-decode-mime-icon)) (t (setq vm-toolbar-helper-command 'vm-help vm-toolbar-helper-icon vm-toolbar-help-icon))) (if (and vm-summary-buffer (buffer-name vm-summary-buffer)) (vm-copy-local-variables vm-summary-buffer 'vm-toolbar-delete/undelete-icon 'vm-toolbar-helper-command 'vm-toolbar-helper-icon)) (if (and vm-presentation-buffer (buffer-name vm-presentation-buffer)) (vm-copy-local-variables vm-presentation-buffer 'vm-toolbar-delete/undelete-icon 'vm-toolbar-helper-command 'vm-toolbar-helper-icon)) (and vm-toolbar-specifier (progn (set-specifier vm-toolbar-specifier (cons (current-buffer) nil)) (set-specifier vm-toolbar-specifier (cons (current-buffer) vm-toolbar))))) (defun vm-toolbar-install-or-uninstall-toolbar () (and (vm-toolbar-support-possible-p) vm-use-toolbar (vm-toolbar-install-toolbar)) (if (and vm-fsfemacs-p (not vm-use-toolbar)) (vm-toolbar-fsfemacs-uninstall-toolbar))) (defcustom vm-toolbar-height nil "*Desired height of the toolbar." :group 'vm-toolbar :type '(choice (const :tag "Automatic" nil) integer)) (defun vm-toolbar-install-toolbar () ;; drag these in now instead of waiting for them to be ;; autoloaded. the "loading..." messages could come at a bad ;; moment and wipe an important echo area message, like "Auto ;; save file is newer..." (require 'vm-save) (require 'vm-summary) (if vm-fsfemacs-p (if (not vm-fsfemacs-toolbar-installed-p) (vm-toolbar-fsfemacs-install-toolbar)) (if (not (vm-toolbar-pixmap-directory)) (progn (vm-warn 0 2 "Bad toolbar pixmap directory, can't setup toolbar.")) (vm-toolbar-initialize) (let ((height (or vm-toolbar-height (+ 5 (glyph-height (car vm-toolbar-help-icon))))) (width (+ 5 (glyph-width (car vm-toolbar-help-icon)))) (frame (selected-frame)) (buffer (current-buffer)) (tag-set '(win)) (myframe (vm-created-this-frame-p)) toolbar ) ;; glyph-width and glyph-height return 0 at startup sometimes ;; use reasonable values if they fail. (if (= width 4) (setq width 38)) (if (= height 4) (setq height 38)) ;; honor user setting of vm-toolbar if they are daring enough ;; to set it. (if vm-toolbar (setq toolbar vm-toolbar) (setq toolbar (vm-toolbar-make-toolbar-spec) vm-toolbar toolbar)) (cond ((eq vm-toolbar-orientation 'right) (setq vm-toolbar-specifier right-toolbar) (if myframe (set-specifier right-toolbar toolbar frame tag-set)) (set-specifier right-toolbar toolbar buffer) (set-specifier right-toolbar-width width frame tag-set)) ((eq vm-toolbar-orientation 'left) (setq vm-toolbar-specifier left-toolbar) (if myframe (set-specifier left-toolbar toolbar frame tag-set)) (set-specifier left-toolbar toolbar buffer) (set-specifier left-toolbar-width width frame tag-set)) ((eq vm-toolbar-orientation 'bottom) (setq vm-toolbar-specifier bottom-toolbar) (if myframe (set-specifier bottom-toolbar toolbar frame tag-set)) (set-specifier bottom-toolbar toolbar buffer) (set-specifier bottom-toolbar-height height frame tag-set)) (t (setq vm-toolbar-specifier top-toolbar) (if myframe (set-specifier top-toolbar toolbar frame tag-set)) (set-specifier top-toolbar toolbar buffer) (set-specifier top-toolbar-height height frame tag-set))))))) (defun vm-toolbar-make-toolbar-spec () (let ((button-alist '( (autofile . vm-toolbar-autofile-button) (compose . vm-toolbar-compose-button) (delete/undelete . vm-toolbar-delete/undelete-button) (file . vm-toolbar-file-button) (getmail . vm-toolbar-getmail-button) (help . vm-toolbar-help-button) (mime . vm-toolbar-decode-mime-button) (next . vm-toolbar-next-button) (previous . vm-toolbar-previous-button) (print . vm-toolbar-print-button) (quit . vm-toolbar-quit-button) (reply . vm-toolbar-reply-button) (forward . vm-toolbar-forward-button) (followup . vm-toolbar-followup-button) (visit . vm-toolbar-visit-button) )) (button-list vm-use-toolbar) cons (toolbar nil)) (while button-list (cond ((null (car button-list)) (setq toolbar (cons nil toolbar))) ((integerp (car button-list)) (if (< 0 (car button-list)) (setq toolbar (cons (vector ':size (car button-list) ':style '2d) toolbar)))) (t (setq cons (assq (car button-list) button-alist)) (if cons (setq toolbar (cons (symbol-value (cdr cons)) toolbar))))) (setq button-list (cdr button-list))) (nreverse toolbar) )) (defun vm-toolbar-initialize () (cond (vm-fsfemacs-p nil) ((null vm-toolbar-help-icon) (let ((tuples (list '(vm-toolbar-decode-mime-icon "mime-up.xpm" "mime-dn.xpm" "mime-xx.xpm") '(vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm") '(vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm" "previous-dn.xpm") '(vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm") '(vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm" "undelete-dn.xpm") '(vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm" "autofile-dn.xpm") '(vm-toolbar-getmail-icon "getmail-up.xpm" "getmail-dn.xpm" "getmail-dn.xpm") '(vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm") '(vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm") '(vm-toolbar-forward-icon "forward-up.xpm" "forward-dn.xpm" "forward-dn.xpm") '(vm-toolbar-followup-icon "followup-up.xpm" "followup-dn.xpm" "followup-dn.xpm") '(vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm") '(vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm") '(vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm") '(vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm") '(vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm") '(vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm") )) tuple files var) (while tuples (setq tuple (car tuples) var (car tuple) files (cdr tuple)) (set var (mapcar (function (lambda (f) (make-glyph (expand-file-name f (vm-toolbar-pixmap-directory))))) files)) (setq tuples (cdr tuples)))))) (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) (setq-default vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) (setq vm-toolbar-helper-command 'vm-help) (setq vm-toolbar-helper-icon vm-toolbar-help-icon) (setq-default vm-toolbar-helper-icon vm-toolbar-help-icon)) (defun vm-toolbar-fsfemacs-uninstall-toolbar () (define-key vm-mode-map [toolbar] nil) (setq vm-fsfemacs-toolbar-installed-p nil)) (defun vm-toolbar-fsfemacs-install-toolbar () (let ((button-list (reverse vm-use-toolbar)) (dir (vm-toolbar-pixmap-directory)) (extension "xpm") item t-spec sym name images) (defvar tool-bar-map) ;; hide the toolbar entries that are in the global keymap so ;; VM has full control of the toolbar in its buffers. (if (and (boundp 'tool-bar-map) (consp tool-bar-map)) (let ((map (cdr tool-bar-map)) (v [tool-bar x])) (while map (aset v 1 (car (car map))) (define-key vm-mode-map v 'undefined) (setq map (cdr map))))) (while button-list (setq sym (car button-list)) (cond ((null sym) ;; can't do flushright in FSF Emacs t) ((integerp sym) ;; can't do separators in FSF Emacs t) ((memq sym '(autofile compose file getmail mime next previous print quit reply followup forward visit)) (setq t-spec (symbol-value (intern (format "vm-toolbar-%s-button" (if (eq sym 'mime) 'decode-mime sym))))) (setq name (symbol-name sym)) (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir (if (eq sym 'mime) nil 'heuristic))) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar sym) item)) ((eq sym 'delete/undelete) (setq t-spec vm-toolbar-delete/undelete-button) (setq name "delete") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir 'heuristic)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'delete) item) (setq name "undelete") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir 'heuristic)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'undelete) item)) ((eq sym 'help) (setq t-spec vm-toolbar-help-button) (setq name "help") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir 'heuristic)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-helper-command 'vm-help) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'help-help) item) (setq name "recover") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir 'heuristic)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-helper-command 'recover-file) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'help-recover) item) (setq name "getmail") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir 'heuristic)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-helper-command 'vm-get-new-mail) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'help-getmail) item) (setq name "mime") (setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec name extension dir nil)) (setq item (list 'menu-item name (aref t-spec 1) ':help (aref t-spec 3) ':visible '(eq vm-toolbar-helper-command 'vm-decode-mime-message) ':enable (aref t-spec 2) ; ':button '(:toggle nil) ':image images)) (define-key vm-mode-map (vector 'tool-bar 'help-mime) item))) (setq button-list (cdr button-list)))) (setq vm-fsfemacs-toolbar-installed-p t)) (defun vm-toolbar-make-fsfemacs-toolbar-image-spec (name extension dir mask) (if vm-gtk-emacs-p ;; the GTK-toolbar will not display icons when providing a vector since ;; some version of GTK resp. Emacs 22 ... (list 'image ':type (intern extension) ':file (expand-file-name (format "%s-up.%s" name extension) dir)) (vector (list 'image ':type (intern extension) ':file (expand-file-name (format "%s-dn.%s" name extension) dir)) (list 'image ':type (intern extension) ':file (expand-file-name (format "%s-up.%s" name extension) dir)) (list 'image ':type (intern extension) ':file (expand-file-name (format "%s-dn.%s" name extension) dir)) (list 'image ':type (intern extension) ':file (expand-file-name (format "%s-dn.%s" name extension) dir))))) ;;; vm-toolbar.el ends here vm-8.2.0b/lisp/vm-version.el0000755000175000017500000001332411676442160016172 0ustar srivastasrivasta;;; vm-version.el --- Version information about VM and the Emacs running VM. ;; ;; Copyright (C) Kyle E. Jones, Robert Widhopf-Fenk ;; Copyright (C) 2003-2007 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-version) ;; Don't use vm-device-type here because it may not not be loaded yet. (declare-function device-type "vm-xemacs" ()) (declare-function device-matching-specifier-tag-list "vm-xemacs" ()) (defconst vm-version (condition-case nil (with-temp-buffer (insert-file-contents-literally (expand-file-name "version.txt" (and load-file-name (file-name-directory load-file-name)))) (read (current-buffer))) (file-error "undefined")) "Version number of VM.") (defun vm-version () "Return the value of the variable `vm-version'." (interactive) (when (interactive-p) (or (and (stringp vm-version) (string-match "[0-9]" vm-version)) (error "Cannot determine VM version!")) (message "VM version is: %s" vm-version)) vm-version) (defconst vm-xemacs-p (featurep 'xemacs)) (defconst vm-xemacs-mule-p (and vm-xemacs-p (featurep 'mule))) (defconst vm-xemacs-file-coding-p (and vm-xemacs-p (featurep 'file-coding) ;; paranoia (fboundp 'set-buffer-file-coding-system))) (defconst vm-fsfemacs-p (not vm-xemacs-p)) (defconst vm-fsfemacs-mule-p (and (not vm-xemacs-mule-p) (featurep 'mule) (fboundp 'set-buffer-file-coding-system))) (defun vm-xemacs-p () vm-xemacs-p) (defun vm-xemacs-mule-p () vm-xemacs-mule-p) (defun vm-xemacs-file-coding-p () vm-xemacs-file-coding-p) (defun vm-fsfemacs-p () vm-fsfemacs-p) (defun vm-fsfemacs-mule-p () vm-fsfemacs-mule-p) (defun vm-emacs-mule-p () (or vm-xemacs-mule-p vm-fsfemacs-mule-p)) (defun vm-mouse-fsfemacs-mouse-p () (and vm-fsfemacs-p (fboundp 'set-mouse-position))) (defun vm-mouse-xemacs-mouse-p () (and vm-xemacs-p (fboundp 'set-mouse-position))) (defun vm-menu-fsfemacs-menus-p () (and vm-fsfemacs-p (fboundp 'menu-bar-mode))) (defun vm-menu-fsfemacs19-menus-p () (and vm-fsfemacs-p (fboundp 'menu-bar-mode) (= emacs-major-version 19))) (defun vm-menu-xemacs-menus-p () (and vm-xemacs-p (fboundp 'set-buffer-menubar))) (defun vm-menu-can-eval-item-name () (and vm-xemacs-p (fboundp 'check-menu-syntax) (condition-case nil (check-menu-syntax '("bar" ((identity "foo") 'ding t))) (error nil)))) (defun vm-multiple-frames-possible-p () (cond (vm-xemacs-p (or (memq 'win (device-matching-specifier-tag-list)) (featurep 'tty-frames))) (vm-fsfemacs-p (fboundp 'make-frame)))) (defun vm-mouse-support-possible-p () (cond (vm-xemacs-p (featurep 'window-system)) (vm-fsfemacs-p (fboundp 'track-mouse)))) (defun vm-mouse-support-possible-here-p () (cond (vm-xemacs-p (memq 'win (device-matching-specifier-tag-list))) (vm-fsfemacs-p (memq window-system '(x mac w32 win32))))) (defun vm-menu-support-possible-p () (cond (vm-xemacs-p (featurep 'menubar)) (vm-fsfemacs-p (fboundp 'menu-bar-mode)))) (defun vm-menubar-buttons-possible-p () "Menubar buttons are menus that have an immediate action. Some Windowing toolkits do not allow such buttons. This says whether such buttons are possible under the current windowing system." (not (cond (vm-xemacs-p (memq (device-type) '(gtk ns))) (vm-fsfemacs-p (or (and (eq window-system 'x) (featurep 'gtk)) (eq window-system 'ns)))))) (defun vm-toolbar-support-possible-p () (or (and vm-xemacs-p (featurep 'toolbar)) (and vm-fsfemacs-p (fboundp 'tool-bar-mode) (boundp 'tool-bar-map)))) (defun vm-multiple-fonts-possible-p () (cond (vm-xemacs-p (memq (device-type) '(x gtk mswindows))) (vm-fsfemacs-p (memq window-system '(x mac w32 win32))))) (defun vm-images-possible-here-p () (or (and vm-xemacs-p (memq (device-type) '(x gtk mswindows))) (and vm-fsfemacs-p window-system (or (fboundp 'image-type-available-p) (and (stringp vm-imagemagick-convert-program) (stringp vm-imagemagick-identify-program)))))) (defun vm-image-type-available-p (type) (if (fboundp 'image-type-available-p) (image-type-available-p type) (or (featurep type) (eq type 'xbm)))) (defun vm-load-features (feature-list &optional silent) "Try to load those features listed in FEATURE_LIST. If SILENT is t, do not display warnings for unloadable features. Return the list of loaded features." (setq feature-list (mapcar (lambda (f) (condition-case nil (progn (require f) f) (error (if (load (format "%s" f) t) f (when (not silent) (message "WARNING: Could not load feature %S." f) ;; (sit-for 1) (message "WARNING: Related functions may not work correctly!") ;; (sit-for 1) ) nil)))) feature-list)) (delete nil feature-list)) ;;; vm-version.el ends here vm-8.2.0b/lisp/vm-license.el0000755000175000017500000000407111676442160016126 0ustar srivastasrivasta;;; vm-license.el --- Code to show VM's warranty and copying restrictions ;; ;; This file is part of VM ;; ;; Copyright (C) 1989, 1994 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-license) (eval-when-compile (require 'vm-window)) (declare-function Info-goto-node "ext:info" (nodename &optional fork)) ;;;###autoload (defun vm-show-copying-restrictions (&optional warranty) "Show VM's license, i.e. the GPL." (interactive) (require 'info) (let ((pop-up-windows (eq vm-mutable-window-configuration t)) (pop-up-frames (and vm-mutable-frame-configuration vm-frame-per-help))) (or (condition-case () (progn (Info-goto-node "(vm)License") t) (error nil)) (condition-case () (progn (Info-goto-node "(vm.info)License") t) (error nil)) (error "VM Info documentation appears not to be installed")) (vm-display (current-buffer) t nil nil) (vm-display nil nil '(vm-show-copying-restrictions vm-show-no-warranty) (list this-command)) (if warranty (let ((case-fold-search nil)) (search-forward "NO WARRANTY\n" nil t) (forward-line -1) (set-window-start (selected-window) (point)))))) ;;;###autoload (defun vm-show-no-warranty () "Display \"NO WARRANTY\" section of the GNU General Public License." (interactive) (vm-show-copying-restrictions t)) ;;; vm-license.el ends here vm-8.2.0b/lisp/vm-w3.el0000755000175000017500000000500211676442161015031 0ustar srivastasrivasta;;; vm-w3.el --- additional functions to make VM use w3 for HTML mails ;; ;; This file is part of VM ;; ;; Copyright (C) 2008 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; You need to have w3 installed for this module to work. ;;; Code: (eval-when-compile (require 'cl) (require 'advice) (require 'vm-mime) ) (eval-and-compile (vm-load-features '(w3))) (declare-function w3-region "ext:w3-display.el" (st nd)) (defvar vm-w3-text/html-message nil "The currently displayed message.") (defvar url-working-buffer) (defvar url-current-content-length) (defvar url-current-mime-encoding) (defvar url-current-mime-type) (defvar url-current-mime-headers) (defun vm-w3-cid-retrieve (url) "Insert content of URL." (set-buffer (get-buffer-create url-working-buffer)) (let ((part (vm-mime-cid-retrieve url vm-w3-text/html-message)) type encoding) (setq type (car (vm-mm-layout-type part))) (setq encoding (vm-mm-layout-encoding part)) (if (= 0 (length type)) (setq type "text/plain")) (if (= 0 (length encoding)) (setq encoding "8bit")) (setq url-current-content-length (point-max) url-current-mime-type type url-current-mime-encoding encoding url-current-mime-headers (list (cons "content-type" type) (cons "content-encoding" encoding))))) (defadvice url-cid (around vm-w3 activate) (if nil;(not vm-w3-text/html-message) ad-do-it (vm-w3-cid-retrieve (ad-get-arg 0)))) ;;;###autoload (defun vm-mime-display-internal-w3-text/html (start end layout) (setq vm-w3-text/html-message (vm-mm-layout-message layout)) (let nil;((vm-w3-text/html-message (vm-mm-layout-message layout))) (w3-region start (1- end))) ;; remove read-only text properties (let ((inhibit-read-only t)) (remove-text-properties start end '(read-only nil)))) vm-8.2.0b/lisp/vm-virtual.el0000755000175000017500000012374011676442160016177 0ustar srivastasrivasta;;; vm-virtual.el --- Virtual folders for VM ;; ;; This file is part of VM ;; ;; Copyright (C) 1990-1997 Kyle E. Jones ;; Copyright (C) 2000-2006 Robert Widhopf-Fenk ;; Copyright (C) 2011 Uday S. Reddy ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-virtual) (eval-when-compile (require 'vm-misc) (require 'vm-minibuf) (require 'vm-menu) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-undo) (require 'vm-delete) (require 'vm-save) (require 'vm-reply) (require 'vm-sort) (require 'vm-thread) ) (declare-function vm-visit-folder "vm" (folder &optional read-only revisit)) (declare-function vm-visit-virtual-folder "vm" (folder &optional read-only bookmark)) (declare-function vm-mode "vm" (&optional read-only)) (declare-function vm-get-folder-buffer "vm" (folder)) ;;;###autoload (defun vm-build-virtual-message-list (new-messages &optional dont-finalize) "Builds a list of messages matching the virtual folder definition stored in the variable `vm-virtual-folder-definition'. If the NEW-MESSAGES argument is nil, the message list is derived from the folders listed in the virtual folder definition and selected by the various selectors. The resulting message list is assigned to `vm-message-list' unless DONT-FINALIZE is non-nil. If NEW-MESSAGES is non-nil then it is a list of messages to be tried against the selector parts of the virtual folder definition. Matching messages are added to `vm-message-list', instead of replacing it. The messages in the NEW-MESSAGES list, if any, must all be in the same real folder. The list of matching virtual messages is returned. If DONT-FINALIZE is nil, in addition to `vm-message-list' being set, the virtual messages are added to the virtual message lists of their real messages, the current buffer is added to `vm-virtual-buffers' list of each real folder buffer represented in the virtual list, and `vm-real-buffers' is set to a list of all the real folder buffers involved." (let ((clauses (cdr vm-virtual-folder-definition)) (message-set (make-vector 311 0)) (vbuffer (current-buffer)) (mirrored vm-virtual-mirror) (case-fold-search t) (tail-cons (if dont-finalize nil (vm-last vm-message-list))) (new-message-list nil) virtual location-vector message folders folder buffer selectors sel-list selector arglist i real-buffers-used components) (if dont-finalize nil ;; Since there is at most one virtual message in the folder ;; buffer of a virtual folder, the location data vector (and ;; the markers in it) of all virtual messages in a virtual ;; folder is shared. We initialize the vector here if it ;; hasn't been created already. (if vm-message-list (setq location-vector (vm-location-data-of (car vm-message-pointer))) (setq i 0 location-vector (make-vector vm-location-data-vector-length nil)) (while (< i vm-location-data-vector-length) (aset location-vector i (vm-marker nil)) (vm-increment i))) ;; To keep track of the messages in a virtual folder to ;; prevent duplicates we create and maintain a set that ;; contain all the real messages. (dolist (m vm-message-list) (intern (vm-message-id-number-of (vm-real-message-of m)) message-set))) ;; now select the messages (save-excursion (dolist (clause clauses) (setq folders (car clause) selectors (cdr clause)) (while folders ; folders can change below (setq folder (car folders)) (cond ((and (stringp folder) (vm-pop-folder-spec-p folder)) ;; POP folder, fine nil) ((and (stringp folder) (vm-imap-folder-spec-p folder)) ;; IMAP folder, fine nil) ((stringp folder) ;; Local folder, use full path (setq folder (expand-file-name folder vm-folder-directory))) ((listp folder) ;; Sexpr, eval it (setq folder (eval folder)))) (cond ((null folder) ;; folder was a s-expr which returned nil ;; skip it nil ) ((and (stringp folder) (file-directory-p folder)) ;; an entire directory! (setq folders (nconc folders (vm-delete-backup-file-names (vm-delete-auto-save-file-names (vm-delete-directory-file-names (directory-files folder t nil))))))) ((or (null new-messages) ;; If we're assimilating messages into an ;; existing virtual folder, only allow selectors ;; that would be normally applied to this folder. (and (bufferp folder) (eq (vm-buffer-of (car new-messages)) folder)) (and (stringp folder) (eq (vm-buffer-of (car new-messages)) ;; letter bomb protection ;; set inhibit-local-variables to t for v18 Emacses ;; set enable-local-variables to nil ;; for newer Emacses (let ((inhibit-local-variables t) (coding-system-for-read (vm-binary-coding-system)) (enable-local-eval nil) (enable-local-variables nil) (vm-frame-per-folder nil) (vm-verbosity (1- vm-verbosity))) (vm-visit-folder folder nil t) (vm-select-folder-buffer) (current-buffer))))) ;; Check if the folder is already visited, or visit it (cond ((bufferp folder) (setq buffer folder) (setq components (cons (cons buffer nil) components)) (set-buffer folder)) ((setq buffer (vm-get-folder-buffer folder)) (setq components (cons (cons buffer nil) components)) (set-buffer buffer)) (t (let ((inhibit-local-variables t) (coding-system-for-read (vm-binary-coding-system)) (enable-local-eval nil) (enable-local-variables nil) (vm-frame-per-folder nil) (vm-verbosity (1- vm-verbosity))) (vm-visit-folder folder nil t) (vm-select-folder-buffer) (setq buffer (current-buffer)) (setq components (cons (cons buffer t) components)) (set-buffer buffer)))) (if (eq major-mode 'vm-virtual-mode) (setq virtual t real-buffers-used (append vm-real-buffers real-buffers-used)) (setq virtual nil) (unless (memq (current-buffer) real-buffers-used) (setq real-buffers-used (cons (current-buffer) real-buffers-used))) (unless (eq major-mode 'vm-mode) (vm-mode))) ;; change (sexpr) into ("/file" "/file2" ...) ;; this assumes that there will never be (sexpr sexpr2) ;; in a virtual folder spec. ;; But why are we doing this? This is ugly and ;; error-prone, and breaks things for server folders! ;; USR, 2010-09-20 ;; (when (bufferp folder) ;; (if virtual ;; (setcar (car clauses) ;; (delq nil ;; (mapcar 'buffer-file-name vm-real-buffers))) ;; (if buffer-file-name ;; (setcar (car clauses) (list buffer-file-name))))) ;; if new-messages non-nil use it instead of the ;; whole message list (dolist (m (or new-messages vm-message-list)) (when (and (or dont-finalize (not (intern-soft (vm-message-id-number-of (vm-real-message-of m)) message-set))) (if virtual (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (apply 'vm-vs-or m selectors)) (apply 'vm-vs-or m selectors))) (when (and vm-virtual-debug (member (vm-su-message-id m) vm-traced-message-ids)) (debug "vm-build-virtual-message-list" m) (apply 'vm-vs-or m selectors)) (unless dont-finalize (intern (vm-message-id-number-of (vm-real-message-of m)) message-set)) (setq message (copy-sequence (vm-real-message-of m))) (unless mirrored (vm-set-mirror-data-of message (make-vector vm-mirror-data-vector-length nil)) (vm-set-virtual-messages-sym-of message (make-symbol "")) (vm-set-virtual-messages-of message nil) (vm-set-attributes-of message (make-vector vm-attributes-vector-length nil))) (vm-set-location-data-of message location-vector) (vm-set-softdata-of message (make-vector vm-softdata-vector-length nil)) (if (eq m (symbol-value (vm-mirrored-message-sym-of m))) (vm-set-mirrored-message-sym-of message (vm-mirrored-message-sym-of m)) (let ((sym (make-symbol "<<>>"))) (set sym m) (vm-set-mirrored-message-sym-of message sym))) (vm-set-real-message-sym-of message (vm-real-message-sym-of m)) (vm-set-message-type-of message vm-folder-type) (vm-set-message-access-method-of message vm-folder-access-method) (vm-set-message-id-number-of message vm-message-id-number) (vm-increment vm-message-id-number) (vm-set-buffer-of message vbuffer) (vm-set-reverse-link-sym-of message (make-symbol "<--")) (vm-set-reverse-link-of message tail-cons) (if (null tail-cons) (setq new-message-list (list message) tail-cons new-message-list) (setcdr tail-cons (list message)) (if (null new-message-list) (setq new-message-list (cdr tail-cons))) (setq tail-cons (cdr tail-cons))))))) (setq folders (cdr folders))))) (if dont-finalize new-message-list ;; this doesn't need to work currently, but it might someday ;; (if virtual ;; (setq real-buffers-used (vm-delete-duplicates real-buffers-used))) (vm-increment vm-modification-counter) ;; Until this point the user doesn't really have a virtual ;; folder, as the virtual messages haven't been linked to the ;; real messages, virtual buffers to the real buffers, and no ;; message list has been installed. ;; ;; Now we tie it all together, with this section of code being ;; uninterruptible. (let ((inhibit-quit t) (label-obarray vm-label-obarray)) (unless vm-real-buffers (setq vm-real-buffers real-buffers-used)) (unless vm-component-buffers (setq vm-component-buffers components)) (save-excursion (dolist (real-buffer real-buffers-used) (set-buffer real-buffer) ;; inherit the global label lists of all the associated ;; real folders. (mapatoms (function (lambda (x) (intern (symbol-name x) label-obarray))) vm-label-obarray) (unless (memq vbuffer vm-virtual-buffers) (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))))) (dolist (m new-message-list) (vm-set-virtual-messages-of (vm-real-message-of m) (cons m (vm-virtual-messages-of (vm-real-message-of m))))) (if vm-message-list (when new-message-list (vm-set-summary-redo-start-point new-message-list) (vm-set-numbering-redo-start-point new-message-list)) (vm-set-summary-redo-start-point t) (vm-set-numbering-redo-start-point t) (setq vm-message-list new-message-list)) new-message-list )))) ;;;###autoload (defun vm-create-virtual-folder (selector &optional arg read-only name bookmark) "Create a new virtual folder from messages in the current folder. The messages will be chosen by applying the selector you specify, which is normally read from the minibuffer. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (save-current-buffer (vm-select-folder-buffer) (nconc (vm-read-virtual-selector "Create virtual folder of messages: ") (list prefix))))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (if vm-folder-read-only (setq read-only t)) (let ((use-marks (eq last-command 'vm-next-command-uses-marks)) (parent-summary-format vm-summary-format) vm-virtual-folder-alist ; shadow the global variable clause ) (unless name (if arg (setq name (format "%s %s %s" (buffer-name) selector arg)) (setq name (format "%s %s" (buffer-name) selector)))) (setq clause (if arg (list selector arg) (list selector))) (if use-marks (setq clause (list 'and '(marked) clause))) (setq vm-virtual-folder-alist `(( ,name (((get-buffer ,(buffer-name))) ,clause)))) (vm-visit-virtual-folder name read-only bookmark) (setq vm-summary-format parent-summary-format)) ;; have to do this again here because the known virtual ;; folder menu is now hosed because we installed it while ;; vm-virtual-folder-alist was bound to the temp value above (when vm-use-menus (vm-menu-install-known-virtual-folders-menu))) (defalias 'vm-create-search-folder 'vm-create-virtual-folder) ;;;###autoload (defun vm-create-virtual-folder-of-threads (selector &optional arg read-only name bookmark) "Create a new virtual folder of threads in the current folder. The threads will be chosen by applying the selector you specify, which is normally read from the minibuffer. If any message in a thread matches the selector then the thread is chosen. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (save-current-buffer (vm-select-folder-buffer) (nconc (vm-read-virtual-selector "Create virtual folder of threads: ") (list prefix))))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (vm-build-threads-if-unbuilt) (let ((use-marks (eq last-command 'vm-next-command-uses-marks)) (parent-summary-format vm-summary-format) vm-virtual-folder-alist ; shadow the global variable clause ) (unless name (if arg (setq name (format "%s %s %s" (buffer-name) selector arg)) (setq name (format "%s %s" (buffer-name) selector)))) (setq clause (if arg (list 'thread (list selector arg)) (list 'thread (list selector)))) (if use-marks (setq clause (list 'and '(marked) clause))) (setq vm-virtual-folder-alist `(( ,name (((get-buffer ,(buffer-name))) ,clause)))) (vm-visit-virtual-folder name read-only bookmark) (setq vm-summary-format parent-summary-format)) ;; have to do this again here because the known virtual ;; folder menu is now hosed because we installed it while ;; vm-virtual-folder-alist was bound to the temp value above (when vm-use-menus (vm-menu-install-known-virtual-folders-menu))) ;;;###autoload (defun vm-apply-virtual-folder (name &optional read-only) "Apply the selectors of a named virtual folder to the current folder and create a virtual folder containing the selected messages. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command)) (list (completing-read "Apply this virtual folder's selectors: " vm-virtual-folder-alist nil t) current-prefix-arg))) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((vfolder (assoc name vm-virtual-folder-alist)) (use-marks (eq last-command 'vm-next-command-uses-marks)) clauses vm-virtual-folder-alist) (or vfolder (error "No such virtual folder, %s" name)) (setq vfolder (vm-copy vfolder)) (setq clauses (cdr vfolder)) (while clauses (setcar (car clauses) (list (list 'get-buffer (buffer-name)))) (if use-marks (setcdr (car clauses) (list (list 'and '(marked) (nconc (list 'or) (cdr (car clauses))))))) (setq clauses (cdr clauses))) (setcar vfolder (format "%s/%s" (buffer-name) (car vfolder))) (setq vm-virtual-folder-alist (list vfolder)) (vm-visit-virtual-folder (car vfolder) read-only)) ;; have to do this again here because the "known virtual ;; folder" menu is now hosed because we installed it while ;; vm-virtual-folder-alist was bound to the temp value above (if vm-use-menus (vm-menu-install-known-virtual-folders-menu))) ;;;###autoload (defun vm-create-virtual-folder-same-subject () "Create a virtual folder (search folder) for all messages with the same subject as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let* ((subject (vm-so-sortable-subject (car vm-message-pointer))) (displayed-subject subject) (bookmark (if (vm-virtual-message-p (car vm-message-pointer)) (vm-real-message-of (car vm-message-pointer)) (car vm-message-pointer)))) (if (equal subject "") (setq subject "^$" displayed-subject "\"\"") (setq subject (regexp-quote subject))) (vm-create-virtual-folder 'sortable-subject subject nil (format "%s %s %s" (buffer-name) 'subject displayed-subject) bookmark))) ;;;###autoload (defun vm-create-virtual-folder-same-author () "Create a virtual folder (search folder) for all messages from the same author as the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let* ((author (vm-su-from (car vm-message-pointer))) (displayed-author author) (bookmark (if (vm-virtual-message-p (car vm-message-pointer)) (vm-real-message-of (car vm-message-pointer)) (car vm-message-pointer)))) (if (equal author "") (setq author "^$" displayed-author "") (setq author (regexp-quote author))) (vm-create-virtual-folder 'author author nil (format "%s %s %s" (buffer-name) 'author displayed-author) bookmark))) ;;;###autoload (defun vm-create-author-virtual-folder (&optional arg read-only name) "Create a virtual folder (search folder) of messages with the given author in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-string "Virtual folder of author/recipient: ") prefix))) (vm-create-virtual-folder 'author arg read-only name)) ;;;###autoload (defun vm-create-author-or-recipient-virtual-folder (&optional arg read-only name) "Create a virtual folder (search folder) with given author or recipient from messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-string "Virtual folder of author/recipient: ") prefix))) (vm-create-virtual-folder 'author-or-recipient arg read-only name)) ;;;###autoload (defun vm-create-subject-virtual-folder (&optional arg read-only subject) "Create a virtual folder (search folder) with given subject from messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-string "Virtual folder of subject: ") prefix))) (vm-create-virtual-folder 'subject arg read-only subject)) ;;;###autoload (defun vm-create-text-virtual-folder (&optional arg read-only subject) "Create a virtual folder (search folder) of all messsages with the given string in its text. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-string "Virtual folder of subject: ") prefix))) (vm-create-virtual-folder 'text arg read-only subject)) ;;;###autoload (defun vm-create-date-virtual-folder (&optional arg read-only subject) "Create a virtual folder (search folder) of all messsages with date in given range. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-number "Virtual folder of date in days: ") prefix))) (vm-create-virtual-folder 'newer-than arg read-only subject)) ;;;###autoload (defun vm-create-label-virtual-folder (&optional arg read-only name) "Create a virtual folder with given label from messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list (read-string "Virtual folder of label: ") prefix))) (vm-create-virtual-folder 'label arg read-only name)) ;;;###autoload (defun vm-create-flagged-virtual-folder (&optional read-only name) "Create a virtual folder (search folder) with all the flagged messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list prefix))) (vm-create-virtual-folder 'flagged read-only name)) ;;;###autoload (defun vm-create-new-virtual-folder (&optional read-only name) "Create a virtual folder (search folder) of all newly received messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list prefix))) (vm-create-virtual-folder 'new read-only name)) ;;;###autoload (defun vm-create-unseen-virtual-folder (&optional read-only name) "Create a virtual folder (search folder) of all unseen from messages in the current folder. Prefix arg means the new virtual folder should be visited read only." (interactive (let ((last-command last-command) (this-command this-command) (prefix current-prefix-arg)) (vm-select-folder-buffer) (list prefix))) (vm-create-virtual-folder 'unseen read-only name)) (defun vm-toggle-virtual-mirror () (interactive) (vm-select-folder-buffer-and-validate 0 (vm-interactive-p)) (if (not (eq major-mode 'vm-virtual-mode)) (error "This is not a virtual folder.")) (let ((mp vm-message-list) (inhibit-quit t) modified undo-list) (setq undo-list vm-saved-undo-record-list vm-saved-undo-record-list vm-undo-record-list vm-undo-record-list undo-list vm-undo-record-pointer undo-list) (setq modified vm-saved-buffer-modified-p vm-saved-buffer-modified-p (buffer-modified-p)) (set-buffer-modified-p modified) (if vm-virtual-mirror (while mp (vm-set-attributes-of (car mp) (or (vm-saved-virtual-attributes-of (car mp)) (make-vector vm-attributes-vector-length nil))) (vm-set-mirror-data-of (car mp) (or (vm-saved-virtual-mirror-data-of (car mp)) (make-vector vm-mirror-data-vector-length nil))) (vm-mark-for-summary-update (car mp) t) (setq mp (cdr mp))) (while mp ;; mark for summary update _before_ we set this message to ;; be mirrored. this will prevent the real message and ;; the other messages that will share attributes with ;; this message from having their summaries ;; updated... they don't need it. (vm-mark-for-summary-update (car mp) t) (vm-set-saved-virtual-attributes-of (car mp) (vm-attributes-of (car mp))) (vm-set-saved-virtual-mirror-data-of (car mp) (vm-mirror-data-of (car mp))) (vm-set-attributes-of (car mp) (vm-attributes-of (vm-real-message-of (car mp)))) (vm-set-mirror-data-of (car mp) (vm-mirror-data-of (vm-real-message-of (car mp)))) (setq mp (cdr mp)))) (setq vm-virtual-mirror (not vm-virtual-mirror)) (vm-increment vm-modification-counter)) (vm-update-summary-and-mode-line) (vm-inform 5 "Virtual folder now %s the underlying real folder%s." (if vm-virtual-mirror "mirrors" "does not mirror") (if (cdr vm-real-buffers) "s" ""))) ;;;###autoload (defun vm-virtual-help () (interactive) (vm-display nil nil '(vm-virtual-help) '(vm-virtual-help)) (vm-inform 0 "VV = visit, VX = apply selectors, VC = create, VM = toggle virtual mirror")) (defun vm-vs-or (m &rest selectors) (let ((result nil) selector arglist function) (while selectors (setq selector (car (car selectors)) function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (setq arglist (cdr (car selectors)) arglist (cdr (car selectors)) result (apply function m arglist) selectors (if result nil (cdr selectors)))) result )) (defun vm-vs-and (m &rest selectors) (let ((result t) selector arglist function) (while selectors (setq selector (car (car selectors)) function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (setq arglist (cdr (car selectors)) result (apply function m arglist) selectors (if (null result) nil (cdr selectors)))) result )) (defun vm-vs-not (m arg) (let ((selector (car arg)) (arglist (cdr arg)) function) (setq function (cdr (assq selector vm-virtual-selector-function-alist))) (if (null function) (error "Invalid virtual selector: %s" selector)) (not (apply function m arglist)))) (defun vm-vs-sexp (m arg) (vm-vs-and m arg)) (defun vm-vs-any (m) t) (defun vm-vs-thread (m arg) (let ((selector (car arg)) (arglist (cdr arg)) (root (vm-thread-root m)) tree function) (setq tree (vm-thread-subtree root)) (setq function (cdr (assq selector vm-virtual-selector-function-alist))) (vm-find tree (lambda (m) (apply function m arglist))))) (defun vm-vs-thread-all (m arg) (let ((selector (car arg)) (arglist (cdr arg)) (root (vm-thread-root m)) tree function) (setq tree (vm-thread-subtree root)) (setq function (cdr (assq selector vm-virtual-selector-function-alist))) (vm-for-all tree (lambda (m) (apply function m arglist))))) (defun vm-vs-author (m arg) (or (string-match arg (vm-su-full-name m)) (string-match arg (vm-su-from m)))) (defun vm-vs-recipient (m arg) (or (string-match arg (vm-su-to m)) (string-match arg (vm-su-to-names m)))) (defun vm-vs-author-or-recipient (m arg) (or (vm-vs-author m arg) (vm-vs-recipient m arg))) (defun vm-vs-subject (m arg) (string-match arg (vm-su-subject m))) (defun vm-vs-sortable-subject (m arg) (string-match arg (vm-so-sortable-subject m))) (defun vm-vs-sent-before (m arg) (string< (vm-so-sortable-datestring m) (vm-timezone-make-date-sortable arg))) (defun vm-vs-sent-after (m arg) (string< (vm-timezone-make-date-sortable arg) (vm-so-sortable-datestring m))) (defun vm-vs-older-than (m arg) (let ((date (vm-get-header-contents m "Date:"))) (if date (> (days-between (current-time-string) date) arg)))) (defun vm-vs-newer-than (m arg) (let ((date (vm-get-header-contents m "Date:"))) (if date (<= (days-between (current-time-string) date) arg)))) (defun vm-vs-outgoing (m) (and vm-summary-uninteresting-senders (or (string-match vm-summary-uninteresting-senders (vm-su-full-name m)) (string-match vm-summary-uninteresting-senders (vm-su-from m))))) (defun vm-vs-uninteresting-senders (m) (string-match vm-summary-uninteresting-senders (vm-get-header-contents m "From:"))) (defun vm-vs-attachment (m) (or (vm-attachments-flag m) (vm-vs-text m vm-vs-attachment-regexp))) (defun vm-vs-spam-word (m &optional selector) (if (and (not vm-spam-words) vm-spam-words-file (file-readable-p vm-spam-words-file) (not (get-file-buffer vm-spam-words-file))) (save-excursion (set-buffer (find-file-noselect vm-spam-words-file)) (goto-char (point-min)) (while (re-search-forward "^\\s-*\\([^#;].*\\)\\s-*$" (point-max) t) (setq vm-spam-words (cons (match-string 1) vm-spam-words))) (setq vm-spam-words-regexp (regexp-opt vm-spam-words)))) (if (and m vm-spam-words-regexp) (let ((case-fold-search t)) (cond ((eq selector 'header) (vm-vs-header m vm-spam-words-regexp)) ((eq selector 'header-or-text) (vm-vs-header-or-text m vm-spam-words-regexp)) (t (vm-vs-text m vm-spam-words-regexp)))))) (defun vm-vs-spam-score (m min &optional max) "True when the spam score is >= MIN and optionally <= MAX. The headers that will be checked are those listed in `vm-vs-spam-score-headers'." (let ((spam-headers vm-vs-spam-score-headers) it-is-spam) (while spam-headers (let* ((spam-selector (car spam-headers)) (score (vm-get-header-contents m (car spam-selector)))) (when (and score (string-match (nth 1 spam-selector) score)) (setq score (funcall (nth 2 spam-selector) (match-string 0 score))) (if (and (<= min score) (or (null max) (<= score max))) (setq it-is-spam t spam-headers nil)))) (setq spam-headers (cdr spam-headers))) it-is-spam)) (defun vm-vs-header (m arg) (save-excursion (save-restriction (widen) (goto-char (vm-headers-of (vm-real-message-of m))) (re-search-forward arg (vm-text-of (vm-real-message-of m)) t)))) (defun vm-vs-header-field (m field arg) (let ((header (vm-get-header-contents m field))) (string-match arg header))) (defun vm-vs-uid (m arg) (equal (vm-imap-uid-of m) arg)) (defun vm-vs-uidl (m arg) (equal (vm-pop-uidl-of m) arg)) (defun vm-vs-message-id (m arg) (equal (vm-su-message-id m) arg)) (defun vm-vs-label (m arg) (vm-member arg (vm-labels-of m))) (defun vm-vs-text (m arg) (save-excursion (save-restriction (widen) (goto-char (vm-text-of (vm-real-message-of m))) (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t)))) (defun vm-vs-header-or-text (m arg) (save-excursion (save-restriction (widen) (goto-char (vm-headers-of (vm-real-message-of m))) (re-search-forward arg (vm-text-end-of (vm-real-message-of m)) t)))) (defun vm-vs-more-chars-than (m arg) (> (string-to-number (vm-su-byte-count m)) arg)) (defun vm-vs-less-chars-than (m arg) (< (string-to-number (vm-su-byte-count m)) arg)) (defun vm-vs-more-lines-than (m arg) (> (string-to-number (vm-su-line-count m)) arg)) (defun vm-vs-less-lines-than (m arg) (< (string-to-number (vm-su-line-count m)) arg)) (defun vm-vs-virtual-folder-member (m) (vm-virtual-messages-of m)) (defun vm-vs-new (m) (vm-new-flag m)) (fset 'vm-vs-recent 'vm-vs-new) (defun vm-vs-unread (m) (vm-unread-flag m)) (fset 'vm-vs-unseen 'vm-vs-unread) (defun vm-vs-read (m) (not (or (vm-new-flag m) (vm-unread-flag m)))) (defun vm-vs-flagged (m) (vm-flagged-flag m)) (defun vm-vs-unflagged (m) (not (vm-flagged-flag m))) (defun vm-vs-deleted (m) (vm-deleted-flag m)) (defun vm-vs-replied (m) (vm-replied-flag m)) (fset 'vm-vs-answered 'vm-vs-replied) (defun vm-vs-forwarded (m) (vm-forwarded-flag m)) (defun vm-vs-redistributed (m) (vm-redistributed-flag m)) (defun vm-vs-filed (m) (vm-filed-flag m)) (defun vm-vs-written (m) (vm-written-flag m)) (defun vm-vs-marked (m) (vm-mark-of m)) (defun vm-vs-edited (m) (vm-edited-flag m)) (defun vm-vs-undeleted (m) (not (vm-deleted-flag m))) (defun vm-vs-unreplied (m) (not (vm-replied-flag m))) (fset 'vm-vs-unanswered 'vm-vs-unreplied) (defun vm-vs-unforwarded (m) (not (vm-forwarded-flag m))) (defun vm-vs-unredistributed (m) (not (vm-redistributed-flag m))) (defun vm-vs-unfiled (m) (not (vm-filed-flag m))) (defun vm-vs-unwritten (m) (not (vm-written-flag m))) (defun vm-vs-unmarked (m) (not (vm-mark-of m))) (defun vm-vs-unedited (m) (not (vm-edited-flag m))) (defun vm-vs-expanded (m) (vm-expanded-root-p m)) (defun vm-vs-collapsed (m) (vm-collapsed-root-p m)) (put 'sexp 'vm-virtual-selector-clause "matching S-expression selector") (put 'eval 'vm-virtual-selector-clause "giving true for expression") (put 'header 'vm-virtual-selector-clause "with header matching") (put 'label 'vm-virtual-selector-clause "with label of") (put 'uid 'vm-virtual-selector-clause "with IMAP UID of") (put 'uidl 'vm-virtual-selector-clause "with POP UIDL of") (put 'message-id 'vm-virtual-selector-clause "with Message ID of") (put 'text 'vm-virtual-selector-clause "with text matching") (put 'header-or-text 'vm-virtual-selector-clause "with header or text matching") (put 'recipient 'vm-virtual-selector-clause "with recipient matching") (put 'author-or-recipient 'vm-virtual-selector-clause "with author or recipient matching") (put 'author 'vm-virtual-selector-clause "with author matching") (put 'subject 'vm-virtual-selector-clause "with subject matching") (put 'sent-before 'vm-virtual-selector-clause "sent before") (put 'sent-after 'vm-virtual-selector-clause "sent after") (put 'older-than 'vm-virtual-selector-clause "days older than") (put 'newer-than 'vm-virtual-selector-clause "days newer than") (put 'more-chars-than 'vm-virtual-selector-clause "with more characters than") (put 'less-chars-than 'vm-virtual-selector-clause "with less characters than") (put 'more-lines-than 'vm-virtual-selector-clause "with more lines than") (put 'less-lines-than 'vm-virtual-selector-clause "with less lines than") (put 'sexp 'vm-virtual-selector-arg-type 'string) (put 'eval 'vm-virtual-selector-arg-type 'string) (put 'header 'vm-virtual-selector-arg-type 'string) (put 'label 'vm-virtual-selector-arg-type 'label) (put 'uid 'vm-virtual-selector-arg-type 'string) (put 'uidl 'vm-virtual-selector-arg-type 'string) (put 'message-id 'vm-virtual-selector-arg-type 'string) (put 'text 'vm-virtual-selector-arg-type 'string) (put 'header-or-text 'vm-virtual-selector-arg-type 'string) (put 'recipient 'vm-virtual-selector-arg-type 'string) (put 'author-or-recipient 'vm-virtual-selector-arg-type 'string) (put 'author 'vm-virtual-selector-arg-type 'string) (put 'subject 'vm-virtual-selector-arg-type 'string) (put 'sent-before 'vm-virtual-selector-arg-type 'string) (put 'sent-after 'vm-virtual-selector-arg-type 'string) (put 'older-than 'vm-virtual-selector-arg-type 'number) (put 'newer-than 'vm-virtual-selector-arg-type 'number) (put 'more-chars-than 'vm-virtual-selector-arg-type 'number) (put 'less-chars-than 'vm-virtual-selector-arg-type 'number) (put 'more-lines-than 'vm-virtual-selector-arg-type 'number) (put 'less-lines-than 'vm-virtual-selector-arg-type 'number) (put 'spam-score 'vm-virtual-selector-arg-type 'number) ;;;###autoload (defun vm-read-virtual-selector (prompt) (let (selector (arg nil)) (setq selector (vm-read-string prompt vm-supported-interactive-virtual-selectors) selector (intern selector)) (let ((arg-type (get selector 'vm-virtual-selector-arg-type))) (if (null arg-type) nil (setq prompt (concat (substring prompt 0 -2) " " (get selector 'vm-virtual-selector-clause) ": ")) (raise-frame (selected-frame)) (cond ((eq arg-type 'number) (setq arg (vm-read-number prompt))) ((eq arg-type 'label) (let ((vm-completion-auto-correct nil) (completion-ignore-case t)) (setq arg (downcase (vm-read-string prompt (vm-obarray-to-string-list vm-label-obarray) nil))))) (t (setq arg (read-string prompt)))))) (let ((real-arg (if (or (eq selector 'sexp) (eq selector 'eval)) (let ((read-arg (read arg))) (if (listp read-arg) read-arg (list read-arg))) arg))) (or (fboundp (intern (concat "vm-vs-" (symbol-name selector)))) (error "Invalid selector")) (list selector real-arg)))) ;;;###autoload (defun vm-virtual-quit (&optional no-expunge no-change) "Clear away links between real and virtual folders when a `vm-quit' is performed in the current folder (which could be either real or virtual)." (save-excursion (cond ((eq major-mode 'vm-virtual-mode) ;; don't trust blindly, user might have killed some of ;; these buffers. (setq vm-component-buffers (vm-delete (lambda (pair) (buffer-name (car pair))) vm-component-buffers t)) (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) (let ((b (current-buffer)) (mirrored-msg nil) (real-msg nil) ;; lock out interrupts here (inhibit-quit t)) ;; Move the message-pointer of the original buffer to the ;; current message in the virtual folder (setq mirrored-msg (and vm-message-pointer (vm-mirrored-message-of (car vm-message-pointer)))) (when (and mirrored-msg (vm-buffer-of mirrored-msg)) (with-current-buffer (vm-buffer-of mirrored-msg) (vm-record-and-change-message-pointer vm-message-pointer (vm-message-position mirrored-msg)))) (dolist (real-buf vm-real-buffers) (with-current-buffer real-buf (setq vm-virtual-buffers (delq b vm-virtual-buffers)))) (dolist (m vm-message-list) (setq real-msg (vm-real-message-of m)) (vm-set-virtual-messages-of real-msg (delq m (vm-virtual-messages-of real-msg)))) (condition-case error-data (dolist (pair vm-component-buffers) (when (cdr pair) (with-current-buffer (car pair) ;; Use dynamic non-local bindings from vm-quit (vm-quit no-expunge no-change)))) (error (vm-warn 0 2 "Unable to quit component folders: %s" (prin1-to-string error-data)))))) ((eq major-mode 'vm-mode) ;; don't trust blindly, user might have killed some of ;; these buffers. (setq vm-virtual-buffers (vm-delete 'buffer-name vm-virtual-buffers t)) (let (vmp (b (current-buffer)) ;; lock out interrupts here (inhibit-quit t)) (dolist (m vm-message-list) ;; we'll clear these messages from the virtual ;; folder by looking for messages that have a "Q" ;; id number associated with them. (when (vm-virtual-messages-of m) (dolist (v-m (vm-virtual-messages-of m)) (vm-set-message-id-number-of v-m "Q")) (vm-unthread-message-and-mirrors m :message-changing nil) (vm-set-virtual-messages-of m nil))) (dolist (virtual-buf vm-virtual-buffers) (set-buffer virtual-buf) (setq vm-real-buffers (delq b vm-real-buffers)) ;; set the message pointer to a new value if it is ;; now invalid. (when (and vm-message-pointer (equal "Q" (vm-message-id-number-of (car vm-message-pointer)))) (vm-garbage-collect-message) (setq vmp vm-message-pointer) (while (and vm-message-pointer (equal "Q" (vm-message-id-number-of (car vm-message-pointer)))) (setq vm-message-pointer (cdr vm-message-pointer))) ;; if there were no good messages ahead, try going ;; backward. (unless vm-message-pointer (setq vm-message-pointer vmp) (while (and vm-message-pointer (equal "Q" (vm-message-id-number-of (car vm-message-pointer)))) (setq vm-message-pointer (vm-reverse-link-of (car vm-message-pointer)))))) ;; expunge the virtual messages associated with ;; real messages that are going away. (setq vm-message-list (vm-delete (function (lambda (m) (equal "Q" (vm-message-id-number-of m)))) vm-message-list nil)) (if (null vm-message-pointer) (setq vm-message-pointer vm-message-list)) ;; same for vm-last-message-pointer (if (null vm-last-message-pointer) (setq vm-last-message-pointer nil)) (vm-clear-virtual-quit-invalidated-undos) (vm-reverse-link-messages) (vm-set-numbering-redo-start-point t) (vm-set-summary-redo-start-point t) (if vm-message-pointer (vm-present-current-message) (vm-update-summary-and-mode-line)))))))) ;;;###autoload (defun vm-virtual-save-folder (prefix) (save-excursion ;; don't trust blindly, user might have killed some of ;; these buffers. (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) (dolist (real-buf vm-real-buffers) (set-buffer real-buf) (vm-save-folder prefix))) (vm-unmark-folder-modified-p (current-buffer)) (vm-clear-modification-flag-undos) (vm-update-summary-and-mode-line)) ;;;###autoload (defun vm-virtual-get-new-mail () (save-excursion ;; don't trust blindly, user might have killed some of ;; these buffers. (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) (dolist (real-buf vm-real-buffers) (set-buffer real-buf) (condition-case error-data (vm-get-new-mail) ;; handlers (folder-read-only (vm-warn 0 1 "Folder is read only: %s" (or buffer-file-name (buffer-name)))) (unrecognized-folder-type (vm-warn 0 1 "Folder type is unrecognized: %s" (or buffer-file-name (buffer-name))))))) (vm-emit-totals-blurb)) ;;;###autoload (defun vm-make-virtual-copy (m) "Copy of the real message of the virtual message M in the current folder buffer (which should be the virtual folder in which M occurs)." (widen) (let ((virtual-buffer (current-buffer)) (real-m (vm-real-message-of m)) (buffer-read-only nil) (modified (buffer-modified-p))) (unwind-protect (save-excursion (set-buffer (vm-buffer-of real-m)) (save-restriction (widen) ;; must reference this now so that headers will be in ;; their final position before the message is copied. ;; otherwise the vheader offset computed below will be wrong. (vm-vheaders-of real-m) (copy-to-buffer virtual-buffer (vm-start-of real-m) (vm-end-of real-m)))) (set-buffer-modified-p modified)) (set-marker (vm-start-of m) (point-min)) (set-marker (vm-headers-of m) (+ (vm-start-of m) (- (vm-headers-of real-m) (vm-start-of real-m)))) (set-marker (vm-vheaders-of m) (+ (vm-start-of m) (- (vm-vheaders-of real-m) (vm-start-of real-m)))) (set-marker (vm-text-of m) (+ (vm-start-of m) (- (vm-text-of real-m) (vm-start-of real-m)))) (set-marker (vm-text-end-of m) (+ (vm-start-of m) (- (vm-text-end-of real-m) (vm-start-of real-m)))) (set-marker (vm-end-of m) (+ (vm-start-of m) (- (vm-end-of real-m) (vm-start-of real-m)))))) ;; ;; now load vm-avirtual to avoid a loading loop ;; (require 'vm-avirtual) ;;; vm-virtual.el ends here vm-8.2.0b/lisp/vm-digest.el0000755000175000017500000007664311676442160016001 0ustar srivastasrivasta;;; vm-digest.el --- Message encapsulation ;; ;; This file is part of VM ;; ;; Copyright (C) 1989, 1990, 1993, 1994, 1997, 2001 Kyle E. Jones ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Code: (provide 'vm-digest) (eval-when-compile (require 'vm-misc) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) (require 'vm-page) (require 'vm-motion) (require 'vm-mime) (require 'vm-undo) (require 'vm-delete) ) (declare-function vm-mode "vm-mode" (&optional read-only)) (declare-function vm-yank-message "vm-reply" (message)) ;;;###autoload (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp) "Encapsulate a message M for forwarding, simply. No message encapsulation standard is used. The message is inserted at point in the current buffer, surrounded by two dashed start/end separator lines. Point is not moved. M should be a message struct for a real message, not a virtual message. This is the message that will be encapsulated. KEEP-LIST should be a list of regexps matching headers to keep. DISCARD-REGEXP should be a regexp that matches headers to be discarded. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers to be forwarded. See the docs for vm-reorder-message-headers to find out how KEEP-LIST and DISCARD-REGEXP are used." (let ((target-buffer (current-buffer)) source-buffer) (save-restriction ;; narrow to a zero length region to avoid interacting ;; with anything that might have already been inserted ;; into the buffer. (narrow-to-region (point) (point)) (insert "------- start of forwarded message -------\n") (setq source-buffer (vm-buffer-of m)) (save-excursion (set-buffer source-buffer) (save-restriction (widen) (save-excursion (set-buffer target-buffer) (let ((beg (point))) ;; (insert-buffer-substring ;; source-buffer (vm-headers-of m) (vm-text-end-of m)) (let ((vm-include-mime-attachments t) ; override the defaults (vm-include-text-basic nil) (vm-include-text-from-presentation nil) (mail-citation-hook (list 'vm-cite-forwarded-message))) (vm-yank-message m)) (goto-char beg) ;; (vm-reorder-message-headers ;; nil :keep-list nil ;; :discard-regexp vm-internal-unforwarded-header-regexp) ;; (vm-reorder-message-headers ;; nil :keep-list keep-list :discard-regexp discard-regexp) (vm-decode-mime-message-headers) )))) (goto-char (point-max)) (insert "------- end of forwarded message -------\n")))) (defun vm-cite-forwarded-message () "The message citation handler for a forwarded message." (save-excursion (vm-reorder-message-headers nil :keep-list nil :discard-regexp vm-internal-unforwarded-header-regexp) (vm-reorder-message-headers nil :keep-list vm-forwarded-headers :discard-regexp vm-unforwarded-header-regexp) )) ;;;###autoload (defun* vm-mime-encapsulate-messages (message-list &key (keep-list nil) (discard-regexp "none") (always-use-digest nil)) "Encapsulate the messages in MESSAGE-LIST as per the MIME spec. The resulting digest is inserted at point in the current buffer. Point is not moved. MESSAGE-LIST should be a list of message structs (real or virtual). These are the messages that will be encapsulated. KEEP-LIST should be a list of regexps matching headers to keep. DISCARD-REGEXP should be a regexp that matches headers to be discarded. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers to be forwarded. See the docs for vm-reorder-message-headers to find out how KEEP-LIST and DISCARD-REGEXP are used. If ALWAYS-USE-DIGEST is non-nil, always encapsulate for a multipart/digest. Otherwise if there is only one message to be encapsulated leave off the multipart boundary strings. The caller is assumed to be using message/rfc822 or message/news encoding instead. If multipart/digest encapsulation is done, the function returns the multipart boundary parameter (string) that should be used in the Content-Type header. Otherwise nil is returned." (if message-list (let ((target-buffer (current-buffer)) (boundary-positions nil) (mlist message-list) (boundary nil) source-buffer m start n beg) (save-restriction ;; narrow to a zero length region to avoid interacting ;; with anything that might have already been inserted ;; into the buffer. (narrow-to-region (point) (point)) (setq start (point)) (while mlist (setq boundary-positions (cons (point-marker) boundary-positions)) (setq m (vm-real-message-of (car mlist)) source-buffer (vm-buffer-of m)) (setq beg (point)) (vm-insert-region-from-buffer source-buffer (vm-headers-of m) (vm-text-end-of m)) (goto-char beg) ;; remove the Berkeley and VM status headers and sort ;; the MIME headers to the top of the message. (vm-reorder-message-headers nil :keep-list vm-mime-header-list :discard-regexp vm-internal-unforwarded-header-regexp) ;; skip past the MIME headers so that when the ;; user's header filters are applied they won't ;; remove the MIME headers. (while (and (vm-match-header) (looking-at vm-mime-header-regexp)) (goto-char (vm-matched-header-end))) ;; apply the user's header filters. (vm-reorder-message-headers nil :keep-list keep-list :discard-regexp discard-regexp) (goto-char (point-max)) (setq mlist (cdr mlist))) (if (and (< (length message-list) 2) (not always-use-digest)) nil (goto-char start) (setq boundary (vm-mime-make-multipart-boundary)) (while (re-search-forward (concat "^--" (regexp-quote boundary) "\\(--\\)?$") nil t) (setq boundary (vm-mime-make-multipart-boundary)) (goto-char start)) (goto-char (point-max)) (insert "\n--" boundary "--\n") (while boundary-positions (goto-char (car boundary-positions)) (insert "\n--" boundary "\n") (insert "Content-Type: message/rfc822\n\n") (setq boundary-positions (cdr boundary-positions))) (goto-char start) (setq n (length message-list)) (insert (format "This is a digest, %d message%s, MIME encapsulation.\n" n (if (= n 1) "" "s")))) (goto-char start)) boundary ))) (defun vm-mime-burst-message (m) "Burst messages from the digest message M. M should be a message struct for a real message. MIME encoding is expected. Somewhere within the MIME layout there must be at least one part of type message/news, message/rfc822 or multipart/digest. If there are multiple parts matching those types, all of them will be burst." (let ((ident-header nil) (did-burst nil) (list (vm-mime-find-digests-in-layout (vm-mm-layout m)))) (if vm-digest-identifier-header-format (setq ident-header (vm-summary-sprintf vm-digest-identifier-header-format m))) (while list (setq did-burst (or (vm-mime-burst-layout (car list) ident-header) did-burst)) (setq list (cdr list))) did-burst)) ;;;###autoload (defun vm-mime-burst-layout (layout ident-header) (let ((work-buffer nil) (folder-buffer (current-buffer)) start part-list (folder-type vm-folder-type)) (unwind-protect (vm-save-restriction (save-excursion (widen) (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (cond ((not (vectorp layout)) (error "Not a MIME message")) ((vm-mime-types-match "message" (car (vm-mm-layout-type layout))) (insert (vm-leading-message-separator folder-type)) (and ident-header (insert ident-header)) (setq start (point)) (vm-mime-insert-mime-body layout) (vm-munge-message-separators folder-type start (point)) ;; remove any leading newlines as they will ;; make vm-reorder-message-headers think the ;; header section has ended. (save-excursion (goto-char start) (while (= (following-char) ?\n) (delete-char 1))) (insert ?\n) (insert (vm-trailing-message-separator folder-type))) ((vm-mime-types-match "multipart/digest" (car (vm-mm-layout-type layout))) (setq part-list (vm-mm-layout-parts layout)) (while part-list ;; Maybe we should verify that each part is ;; of type message/rfc822 or message/news in ;; here. But it seems more useful to just ;; copy whatever the contents are and let the ;; user see the goop, whatever type it really ;; is. (insert (vm-leading-message-separator folder-type)) (and ident-header (insert ident-header)) (setq start (point)) (vm-mime-insert-mime-body (car part-list)) (vm-munge-message-separators folder-type start (point)) ;; remove any leading newlines as they will ;; make vm-reorder-message-headers think the ;; header section has ended. (save-excursion (goto-char start) (while (= (following-char) ?\n) (delete-char 1))) (insert ?\n) (insert (vm-trailing-message-separator folder-type)) (setq part-list (cdr part-list)))) (t (error "MIME type is not multipart/digest or message/rfc822 or message/news"))) ;; do header conversions. (let ((vm-folder-type folder-type)) (goto-char (point-min)) (while (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (vm-convert-folder-type-headers folder-type folder-type) (vm-find-trailing-message-separator) (vm-skip-past-trailing-message-separator))) ;; now insert the messages into the folder buffer (cond ((not (zerop (buffer-size))) (set-buffer folder-buffer) (let ((old-buffer-modified-p (buffer-modified-p)) (buffer-read-only nil) (inhibit-quit t)) (goto-char (point-max)) (insert-buffer-substring work-buffer) (vm-restore-buffer-modified-p old-buffer-modified-p folder-buffer) ;; return non-nil so caller knows we found some messages t )) ;; return nil so the caller knows we didn't find anything (t nil)))) (and work-buffer (kill-buffer work-buffer))))) (defun vm-rfc934-char-stuff-region (start end) "Quote RFC 934 message separators between START and END. START and END are buffer positions in the current buffer. Lines beginning with `-' in the region have `- ' prepended to them." (setq end (vm-marker end)) (save-excursion (goto-char start) (while (and (< (point) end) (re-search-forward "^-" end t)) (replace-match "- -" t t))) (set-marker end nil)) (defun vm-rfc934-char-unstuff-region (start end) "Unquote lines in between START and END as per RFC 934. START and END are buffer positions in the current buffer. Lines beginning with `- ' in the region have that string stripped from them." (setq end (vm-marker end)) (save-excursion (goto-char start) (while (and (< (point) end) (re-search-forward "^- " end t)) (replace-match "" t t) (forward-char))) (set-marker end nil)) ;;;###autoload (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp) "Encapsulate the messages in MESSAGE-LIST as per RFC 934. The resulting digest is inserted at point in the current buffer. Point is not moved. MESSAGE-LIST should be a list of message structs (real or virtual). These are the messages that will be encapsulated. KEEP-LIST should be a list of regexps matching headers to keep. DISCARD-REGEXP should be a regexp that matches headers to be discarded. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers to be forwarded. See the docs for vm-reorder-message-headers to find out how KEEP-LIST and DISCARD-REGEXP are used." (if message-list (let ((target-buffer (current-buffer)) (mlist message-list) source-buffer m start n) (save-restriction ;; narrow to a zero length region to avoid interacting ;; with anything that might have already been inserted ;; into the buffer. (narrow-to-region (point) (point)) (setq start (point)) (while mlist (insert "---------------\n") (setq m (vm-real-message-of (car mlist)) source-buffer (vm-buffer-of m)) (save-excursion (set-buffer source-buffer) (save-restriction (widen) (save-excursion (set-buffer target-buffer) (let ((beg (point))) (insert-buffer-substring source-buffer (vm-headers-of m) (vm-text-end-of m)) (goto-char beg) ;; remove the Berkeley and VM status headers and sort ;; the MIME headers to the top of the message. (vm-reorder-message-headers nil :keep-list vm-mime-header-list :discard-regexp vm-internal-unforwarded-header-regexp) ;; skip past the MIME headers so that when the ;; user's header filters are applied they won't ;; remove the MIME headers. (while (and (vm-match-header) (looking-at vm-mime-header-regexp)) (goto-char (vm-matched-header-end))) ;; apply the user's header filters. (vm-reorder-message-headers nil :keep-list keep-list :discard-regexp discard-regexp) (vm-rfc934-char-stuff-region beg (point-max)))))) (goto-char (point-max)) (insert "---------------") (setq mlist (cdr mlist))) (delete-region (point) (progn (beginning-of-line) (point))) (insert "------- end -------\n") (goto-char start) (delete-region (point) (progn (forward-line 1) (point))) (setq n (length message-list)) (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n" (if (cdr message-list) "digest " "forwarded message ") (if (cdr message-list) (format "(%d messages) " n) ""))) (goto-char start))))) (defun vm-rfc1153-char-stuff-region (start end) "Quote RFC 1153 message separators between START and END. START and END are buffer positions in the current buffer. Lines consisting only of 30 hyphens have the first hyphen converted to a space." (setq end (vm-marker end)) (save-excursion (goto-char start) (while (and (< (point) end) (re-search-forward "^------------------------------$" end t)) (replace-match " -----------------------------" t t))) (set-marker end nil)) (defun vm-rfc1153-char-unstuff-region (start end) "Unquote lines in between START and END as per RFC 1153. START and END are buffer positions in the current buffer. Lines consisting only of a space following by 29 hyphens have the space converted to a hyphen." (setq end (vm-marker end)) (save-excursion (goto-char start) (while (and (< (point) end) (re-search-forward "^ -----------------------------$" end t)) (replace-match "------------------------------" t t))) (set-marker end nil)) ;;;###autoload (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp) "Encapsulate the messages in MESSAGE-LIST as per RFC 1153. The resulting digest is inserted at point in the current buffer. Point is not moved. MESSAGE-LIST should be a list of message structs (real or virtual). These are the messages that will be encapsulated. KEEP-LIST should be a list of regexps matching headers to keep. DISCARD-REGEXP should be a regexp that matches headers to be discarded. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers to be forwarded. See the docs for vm-reorder-message-headers to find out how KEEP-LIST and DISCARD-REGEXP are used." (if message-list (let ((target-buffer (current-buffer)) (mlist message-list) source-buffer m start) (save-restriction ;; narrow to a zero length region to avoid interacting ;; with anything that might have already been inserted ;; into the buffer. (narrow-to-region (point) (point)) (setq start (point)) (while mlist (insert "---------------\n\n") (setq m (vm-real-message-of (car mlist)) source-buffer (vm-buffer-of m)) (save-excursion (set-buffer source-buffer) (save-restriction (widen) (save-excursion (set-buffer target-buffer) (let ((beg (point))) (insert-buffer-substring source-buffer (vm-headers-of m) (vm-text-end-of m)) (goto-char beg) ;; remove the Berkeley and VM status headers and sort ;; the MIME headers to the top of the message. (vm-reorder-message-headers nil :keep-list vm-mime-header-list :discard-regexp vm-internal-unforwarded-header-regexp) ;; skip past the MIME headers so that when the ;; user's header filters are applied they won't ;; remove the MIME headers. (while (and (vm-match-header) (looking-at vm-mime-header-regexp)) (goto-char (vm-matched-header-end))) ;; apply the user's header filters. (vm-reorder-message-headers nil :keep-list keep-list :discard-regexp discard-regexp) (vm-rfc1153-char-stuff-region beg (point-max)))))) (goto-char (point-max)) (insert "\n---------------") (setq mlist (cdr mlist))) (insert "---------------\n\nEnd of this Digest\n******************\n") (goto-char start) (delete-region (point) (progn (forward-line 1) (point))) (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" ""))) (goto-char start))))) (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153) "Burst messages from the digest message M. M should be a message struct for a real message. If RFC1153 is non-nil, assume the digest is of the form specified by RFC 1153. Otherwise assume RFC 934 digests." (let ((work-buffer nil) (match t) (prev-sep nil) (ident-header nil) after-prev-sep prologue-separator-regexp separator-regexp temp-marker (folder-buffer (current-buffer)) (folder-type vm-folder-type)) (if vm-digest-identifier-header-format (setq ident-header (vm-summary-sprintf vm-digest-identifier-header-format m))) (if rfc1153 (setq prologue-separator-regexp "^----------------------------------------------------------------------\n" separator-regexp "^------------------------------\n") (setq prologue-separator-regexp "\\(^-[^ ].*\n+\\)+" separator-regexp "\\(^-[^ ].*\n+\\)+")) (vm-save-restriction (save-excursion (widen) (unwind-protect (catch 'done (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (setq temp-marker (vm-marker (point))) (vm-insert-region-from-buffer (vm-buffer-of m) (vm-text-of m) (vm-text-end-of m)) (goto-char (point-min)) (if (not (re-search-forward prologue-separator-regexp nil t)) (throw 'done nil)) ;; think of this as a do-while loop. (while match (cond ((null prev-sep) ;; from (point-min) to end of match ;; is the digest prologue, devour it and ;; carry on. (delete-region (point-min) (match-end 0))) (t ;; save value as mark so that it will move ;; with the text. (set-marker temp-marker (match-beginning 0)) (let ((md (match-data))) (unwind-protect (progn ;; Undo the quoting of the embedded message ;; separators. (if rfc1153 (vm-rfc1153-char-unstuff-region after-prev-sep temp-marker) (vm-rfc934-char-unstuff-region after-prev-sep temp-marker)) ;; munge previous messages' message separators (vm-munge-message-separators folder-type after-prev-sep temp-marker)) (store-match-data md))))) ;; there should be at least one valid header at ;; the beginning of an encapsulated message. If ;; there isn't a valid header, then assume that ;; the digest was packed improperly and that this ;; isn't a real boundary. (if (not (save-excursion (save-match-data ;; People who roll digests often think ;; any old format will do. Adding blank ;; lines after the message separator is ;; common. Spaces in such lines are an ;; added delight. (skip-chars-forward " \n") (or (and (vm-match-header) (vm-digest-get-header-contents "From")) (not (re-search-forward separator-regexp nil t)))))) (setq prev-sep (point) after-prev-sep (point)) ;; if this isn't the first message, delete the ;; digest separator goop and insert a trailing message ;; separator of the proper type. (if prev-sep (progn ;; eat preceding newlines (while (= (preceding-char) ?\n) (delete-char -1)) ;; put one back (insert ?\n) ;; delete the digest separator (delete-region (match-beginning 0) (point)) ;; insert a trailing message separator (insert (vm-trailing-message-separator folder-type)))) (setq prev-sep (point)) ;; insert the leading separator (insert (vm-leading-message-separator folder-type)) (setq after-prev-sep (point)) ;; eat trailing newlines (while (= (following-char) ?\n) (delete-char 1)) (insert ident-header)) ;; try to match message separator and repeat. (setq match (re-search-forward separator-regexp nil t))) ;; from the last separator to eof is the digest epilogue. ;; discard it. (delete-region (or prev-sep (point-min)) (point-max)) ;; do header conversions. (let ((vm-folder-type folder-type)) (goto-char (point-min)) (while (vm-find-leading-message-separator) (vm-skip-past-leading-message-separator) (vm-convert-folder-type-headers folder-type folder-type) (vm-find-trailing-message-separator) (vm-skip-past-trailing-message-separator))) ;; now insert the messages into the folder buffer (cond ((not (zerop (buffer-size))) (set-buffer folder-buffer) (let ((old-buffer-modified-p (buffer-modified-p)) (buffer-read-only nil) (inhibit-quit t)) (goto-char (point-max)) (insert-buffer-substring work-buffer) (vm-restore-buffer-modified-p old-buffer-modified-p folder-buffer) ;; return non-nil so caller knows we found some messages t )) ;; return nil so the caller knows we didn't find anything (t nil))) (when work-buffer (kill-buffer work-buffer))))))) (defun vm-rfc934-burst-message (m) "Burst messages from the RFC 934 digest message M. M should be a message struct for a real message." (vm-rfc1153-or-rfc934-burst-message m nil)) (defun vm-rfc1153-burst-message (m) "Burst messages from the RFC 1153 digest message M. M should be a message struct for a real message." (vm-rfc1153-or-rfc934-burst-message m t)) ;;;###autoload (defun vm-burst-digest (&optional digest-type) "Burst the current message (a digest) into its individual messages. The digest's messages are assimilated into the folder as new mail would be. Optional argument DIGEST-TYPE is a string that tells VM what kind of digest the current message is. If it is not given the value defaults to the value of vm-digest-burst-type. When called interactively DIGEST-TYPE will be read from the minibuffer. If invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages will be burst. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are burst." (interactive (list (let ((type nil) (this-command this-command) (last-command last-command)) (setq type (completing-read (format "Digest type: (default %s) " vm-digest-burst-type) (append vm-digest-type-alist (list '("guess"))) 'identity nil)) (if (string= type "") vm-digest-burst-type type )))) (or digest-type (setq digest-type vm-digest-burst-type)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((start-buffer (current-buffer)) m totals-blurb (mlist (vm-select-operable-messages 1 (vm-interactive-p) "Burst digest of"))) (vm-retrieve-operable-messages 1 mlist) (while mlist (if (vm-virtual-message-p (car mlist)) (progn (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m))) (setq m (car mlist))) (vm-error-if-folder-read-only) (if (equal digest-type "guess") (progn (setq digest-type (vm-guess-digest-type m)) (if (null digest-type) (error "Couldn't guess digest type.")))) (vm-inform 5 "Bursting %s digest..." digest-type) (cond ((cond ((equal digest-type "mime") (vm-mime-burst-message m)) ((equal digest-type "rfc934") (vm-rfc934-burst-message m)) ((equal digest-type "rfc1153") (vm-rfc1153-burst-message m)) (t (error "Unknown digest type: %s" digest-type))) (vm-inform 5 "Bursting %s digest... done" digest-type) (vm-clear-modification-flag-undos) (vm-mark-folder-modified-p (current-buffer)) (vm-increment vm-modification-counter) (when vm-delete-after-bursting ;; if start folder was virtual, we're now in the wrong ;; buffer. switch back. (save-excursion (set-buffer start-buffer) ;; don't move message pointer when deleting the message (let ((vm-move-after-deleting nil)) (vm-delete-message 1)))) (vm-assimilate-new-messages :read-attributes nil :labels (vm-labels-of (car mlist))) ;; do this now so if we error later in another iteration ;; of the loop the summary and mode line will be correct. (vm-update-summary-and-mode-line))) (setq mlist (cdr mlist))) ;; collect this data NOW, before the non-previewers read a ;; message, alter the new message count and confuse ;; themselves. (setq totals-blurb (vm-emit-totals-blurb)) (vm-display nil nil '(vm-burst-digest vm-burst-mime-digest vm-burst-rfc934-digest vm-burst-rfc1153-digest) (list this-command)) (if (vm-thoughtfully-select-message) (vm-present-current-message) (vm-update-summary-and-mode-line)) (vm-inform 5 totals-blurb))) ;;;###autoload (defun vm-burst-rfc934-digest () "Burst an RFC 934 style digest" (interactive) (vm-burst-digest "rfc934")) ;;;###autoload (defun vm-burst-rfc1153-digest () "Burst an RFC 1153 style digest" (interactive) (vm-burst-digest "rfc1153")) ;;;###autoload (defun vm-burst-mime-digest () "Burst a MIME digest" (interactive) (vm-burst-digest "mime")) ;;;###autoload (defun vm-burst-digest-to-temp-folder (&optional digest-type) "Burst the current message (a digest) into a temporary folder. The digest's messages are copied to a buffer and vm-mode is invoked on the buffer. There is no file associated with this buffer. You can use `vm-write-file' to save the buffer, or `vm-save-message' to save individual messages to a real folder. Optional argument DIGEST-TYPE is a string that tells VM what kind of digest the current message is. If it is not given the value defaults to the value of vm-digest-burst-type. When called interactively DIGEST-TYPE will be read from the minibuffer. If invoked on marked messages (via `vm-next-command-uses-marks'), all marked messages will be burst. If applied to collapsed threads in summary and thread operations are enabled via `vm-enable-thread-operations' then all messages in the thread are burst." (interactive (list (let ((type nil) (this-command this-command) (last-command last-command)) (setq type (completing-read (format "Digest type: (default %s) " vm-digest-burst-type) (append vm-digest-type-alist (list '("guess"))) 'identity nil)) (if (string= type "") vm-digest-burst-type type )))) (or digest-type (setq digest-type vm-digest-burst-type)) (vm-follow-summary-cursor) (vm-select-folder-buffer-and-validate 1 (vm-interactive-p)) (let ((start-buffer (current-buffer)) m totals-blurb (mlist (vm-select-operable-messages 1 (vm-interactive-p) "Burst digest of")) (work-buffer nil)) (vm-retrieve-operable-messages 1 mlist) (unwind-protect (save-excursion ; to go to work-buffer (setq work-buffer (generate-new-buffer (format "digest from %s/%s%s" (current-buffer) (vm-number-of (car vm-message-pointer)) (if (cdr mlist) " ..." "")))) (buffer-disable-undo work-buffer) (set-buffer work-buffer) (setq vm-folder-type vm-default-folder-type) (while mlist (if (vm-virtual-message-p (car mlist)) (setq m (vm-real-message-of (car mlist))) (setq m (car mlist))) (if (equal digest-type "guess") (progn (setq digest-type (vm-guess-digest-type m)) (if (null digest-type) (error "Couldn't guess digest type.")))) (vm-inform 5 "Bursting %s digest to folder..." digest-type) (cond ((equal digest-type "mime") (vm-mime-burst-message m)) ((equal digest-type "rfc934") (vm-rfc934-burst-message m)) ((equal digest-type "rfc1153") (vm-rfc1153-burst-message m)) (t (error "Unknown digest type: %s" digest-type))) (vm-inform 5 "Bursting %s digest... done" digest-type) (and vm-delete-after-bursting (yes-or-no-p (format "Delete message %s? " (vm-number-of m))) (save-excursion (set-buffer start-buffer) ;; don't move message pointer when deleting the message (let ((vm-move-after-deleting nil)) (vm-delete-message 1)))) (setq mlist (cdr mlist))) (set-buffer-modified-p nil) ; work-buffer (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode) (if (vm-should-generate-summary) (progn (vm-goto-new-folder-frame-maybe 'summary) (vm-summarize)))) ;; temp buffer, don't offer to save it. (setq buffer-offer-save nil) (vm-display (or vm-presentation-buffer (current-buffer)) t (list this-command) '(vm-mode startup)) (setq work-buffer nil)) (when work-buffer (kill-buffer work-buffer))))) (defun vm-guess-digest-type (m) "Guess the digest type of the message M. M should be the message struct of a real message. Returns either \"rfc934\", \"rfc1153\" or \"mime\"." (catch 'return-value (save-excursion (set-buffer (vm-buffer-of m)) (let ((layout (vm-mm-layout m))) (if (and (vectorp layout) (or (vm-mime-layout-contains-type layout "multipart/digest") (vm-mime-layout-contains-type layout "message/rfc822") (vm-mime-layout-contains-type layout "message/news"))) (throw 'return-value "mime")))) (save-excursion (save-restriction (widen) (goto-char (vm-text-of m)) (cond ((and (search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t) (search-forward "\n------------------------------\n" (vm-text-end-of m) t)) "rfc1153") (t "rfc934")))))) (defun vm-digest-get-header-contents (header-name-regexp) (let ((contents nil) regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)")) (save-excursion (let ((case-fold-search t)) (if (and (re-search-forward regexp nil t) (match-beginning 1) (progn (goto-char (match-beginning 0)) (vm-match-header))) (vm-matched-header-contents) nil ))))) ;;; vm-digest.el ends here vm-8.2.0b/info/0002755000175000017500000000000011676442161013524 5ustar srivastasrivastavm-8.2.0b/info/vm-pcrisis.texinfo0000755000175000017500000014701411676442160017225 0ustar srivastasrivasta\input texinfo @setfilename vm-pcrisis.info @settitle Personality Crisis for VM @dircategory Emacs @direntry * VM-pcrisis: (vm-pcrisis). Personality profiles control for VM @end direntry @iftex @finalout @end iftex @c @setchapternewpage odd % For book style double sided manual. @c @smallbook @tex \overfullrule=0pt %\global\baselineskip 30pt % For printing in double spaces @end tex @ifinfo This is the documentation for Personality Crisis, an add-on for the mail reader VM which allows you to manage personality profiles automatically when you compose new mail messages or replies. @table @asis @item Copyright (C) 1999 Rob Hodges @item Copyright (C) 2006-2008 Robert Widhopf-Fenk @item Copyright (C) 2011 Uday S. Reddy @end table Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @ignore Permission is granted to process this file through TeX and print the results, provided the printed document carries copying permission notice identical to this one except for the removal of this paragraph (this paragraph not being relevant to the printed manual). @end ignore @end ifinfo @c @include version.texinfo @titlepage @sp 6 @center @titlefont{Personality Crisis for VM} @sp 4 @center VM Version @value{VERSION} @sp 5 @page @vskip 0pt plus 1filll Copyright @copyright{} 1999 Rob Hodges Copyright @copyright{} 2006-2008 Robert Widhopf-Fenk Copyright @copyright{} 2011 Uday S. Reddy Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @end titlepage @page @ifnottex @node Top, Introduction, , (DIR) This is the documentation for VM Personality Crisis, an add-on for the VM mail reader allowing you to control personality profiles used in composing messages. It was originally written by Rob Hodges. This manual corresponds to VM version @value{VERSION}. @menu * Introduction:: * Setting Up:: * Miscellaneous Variables:: * Debugging:: * Version History:: * Variable Index:: * Function Index:: @end menu @end ifnottex The incompete list of Roberts who have been involved in vm-pcrisis: @itemize @bullet @item Rob Hodges @item Robert Widhopf-Fenk @item Robert P. Goldman @item Robert Marshall @end itemize @node Introduction, Setting Up, Top, Top @chapter Introduction The @strong{Personality Crisis} package is designed to manage multiple ``profiles'' (mail identities or mail accounts) during mail-sending. It is based on a programmable system of condition-action rules, which is in fact a lot more general than the management of profiles. Other applications of this technology may be developed in future. Personality Crisis can look at the headers of a message you are replying to or forwarding, or a message you are composing, and use that information to customize the message composition. Common customizations include inserting particular ``From:'' or ``Reply-To:'' headers, inserting signatures or boilerplate text in the message composition and choosing a MIME character set for the outgoing message. See @ref{Common Uses} below for further ideas. The Personality Crisis package is not automatically loaded as part of VM. To use it, place the following line in your @code{vm-init-file}. @lisp (require 'vm-pcrisis) @end lisp As a quick start, you can also add a line similar to the following: @lisp (vmpc-my-identities "me@@company1.nil" "me@@home.nil" "me@@alterego.nil") @end lisp with your own email addresses. VM-Pcrisis will set up each email address with a standard action for using it as the ``From'' header. Every time you write message to an unknown recipient, it will prompt you for the action to use, which is nothing but the ``From'' address to use. This is a completely manual method of choosing mail profiles. You obtain automation by using the customization features described in the rest of the manual. @menu * Description:: @end menu @node Description, , Introduction , Introduction @section Description Personality Crisis can look at the headers of a message you are replying to or forwarding, or a message you are composing, and use that information to customize the message composition. You can also use it to explicitly choose a profile when composing new messages. @c *************************************************************************** @c @node Functionality, Common Uses, Description, Introduction @unnumberedsubsec Functionality @anchor{Functionality} Based on the headers of a message you are replying to, you can get vm-pcrisis to perform these actions: @itemize @bullet @item Change or insert any headers you like in your reply. @item Change or insert a signature in your reply. @item Insert some text in the body of your reply. @item Change any header in your reply to the value of some header in the message you are replying to. @item Call a specified lisp function before VM creates the reply. @item Call a specified lisp function in the reply buffer. @item Prompt you for a personality profile to use, and optionally, remember to use that profile when sending messages to the same recipient in the future. @end itemize Similar functionality is available when forwarding messages. Based on the headers of a message you are composing, it can perform these actions: @itemize @bullet @item Change or insert any headers of your choice. @item Change or insert a signature. @item Insert specified text in the message body. @item Call some functions in the message buffer. @item Prompt you for a personality profile to use, and optionally, remember to use that profile when sending messages to the same recipient in the future. @end itemize If you wish, you can also have vm-pcrisis prompt you for a profile when composing new mail, which is useful if you need to set up VM variables for the composition. If you wish to write your own functions to perform actions beyond the built-in functionality, vm-pcrisis provides primitive functions for accessing the contents of headers in the message you are replying to as well as the message you are composing. @c *************************************************************************** @c @node Common Uses, Overview, Specific Abilities, Introduction @unnumberedsubsec Common Uses @anchor{Common Uses} Here are some of the common uses of vm-pcrisis. @itemize @bullet @item People with multiple e-mail addresses can automatically set up headers such as ``From:'' and ``Reply-To:'', so that, for example, their work email keeps going to their work account, and their private email to their private account. @item People who like to have different nicknames and signatures for different lists can do so. (Well, uh, that's why it is called Personality Crisis...) You can select your personality for new mail messages as well as replies. @item When people send you html-formatted email, you can have your reply automatically include a form letter explaining why they shouldn't, and how to turn it off. (Such a letter is not included with this package; you'll have to write it yourself.) @item People who email in multiple languages can set up the encoding for the reply, along with the keymap, ispell dictionary, attribution line for citations, etc, in the reply buffer. @item When you get email from a mailing list that has the ``Reply-To:'' header set for the whole list, automatically change the ``To:'' header in your reply to point to the original sender instead. (You can do the reverse as well.) VM allows you to do this, but only if the correct reply address is in the "From" field. @item Automatically change the signature and various headers, etc, in a new mail message after typing in the ``To:'' address. @item Automatically remember which personality to use when sending to a particular address. @item If you put your imagination to work while reading through this manual, you'll probably think of other ways that vm-pcrisis can help you. Have fun! @end itemize @c *************************************************************************** @node Setting Up, Miscellaneous Variables, Introduction, Top @chapter Setting Up When setting up variables for Personality Crisis, you begin by thinking about what you want it to do when a certain condition occurs, either when you are replying to or forwarding a message, or in the midst of writing a message. You define the condition in @code{vmpc-conditions}, and the action you want vm-pcrisis to take in @code{vmpc-actions}, giving a name to each. You then associate the condition with the action in @code{vmpc-reply-alist} if it's one that relies on the headers of a message you are replying to, @code{vmpc-forward-alist} if it's a message you are forwarding, or @code{vmpc-automorph-alist} if it's based on the headers of your own message. You may also use @code{vmpc-newmail-alist} to associate conditions with actions for new messages, and @code{vmpc-resend-alist} for resending (bounced) messages. If you want to use the @code{vmpc-automorph} function, which takes actions based on the headers of a message you are composing, @ref{Automorph} to decide where you want to hook it in. The remainder of this manual will provide more information about how to do all of these things. @menu * Conditions:: Defining conditions that fire actions * Actions:: Defining actions to be run * Rules:: Associating conditions with actions * Automorph:: Running automatic actions for new mail @end menu @node Conditions, Actions, Setting Up, Setting Up @c node-name, next, previous, up @section Conditions @c @menu @c * The vmpc-conditions variable:: @c * vmpc-conditions examples:: @c @end menu @c @node The vmpc-conditions variable, vmpc-conditions examples, vmpc-conditions, vmpc-conditions @unnumberedsubsec The vmpc-conditions variable @anchor{vmpc-conditions} The @code{vmpc-conditions} variable is a list of conditions, each of which can cause Personality Crisis to take a different action. You give each condition a unique, descriptive name. The format of the list is something like this: @lisp '( ("condition name" (lisp-expression-1) ) ("another condition name" (lisp-expression-2) ) ) @end lisp The condition names are descriptive names for conditions that you define. We use strings as names in this manual, but you can also use lisp symbols. The lisp-expression can be any expression in lisp that will evaluate to nil if the condition is to be considered false, and non-nil if true. (Don't be afraid, non-lispers, examples are coming...) Personality Crisis provides some functions which can be used there, in combination with @code{and}, @code{or}, and @code{vmpc-xor} to produce a fine-grained control over when your actions will trigger. @itemize @bullet @findex vmpc-folder-match @item @code{vmpc-folder-match} When doing replies, forwards and resends, this matches against the name of the folder where the original message is located. @findex vmpc-folder-account-match @item @code{vmpc-folder-account-match} When doing replies, forwards and resends, this matches against POP/IMAP account name of the folder where the original message is located. (These are the account names defined via the variables @code{vm-pop-folder-alist} and @code{vm-imap-account-alist}.) @findex vmpc-header-match @item @code{vmpc-header-match} When doing replies, forwards and resends, this matches against the contents of a header in the original message; when using the @code{vmpc-automorph} function, it matches against a header in the message you are composing. @findex vmpc-only-from-match @item @code{vmpc-only-from-match} When doing replies, forwards and resends, this matches against the contents of the given headers in the original message; it is true only when @emph{all} email adresses match the given regexp. @findex vmpc-body-match @item @code{vmpc-body-match} is just like @code{vmpc-header-match} but allows you to match against the text in the body of the message. @findex vmpc-hceck-virtual-selector @item @code{vmpc-check-virtual-selector}. If you are using @code{vm-avirtual.el} you can also use this to check a virtual folder selector. @findex vmpc-other-cond @item @code{vmpc-other-cond} returns true when a specified condition earlier in the list has been found true. It's essentially a shortcut for building more complex conditions from basic ones. @findex vmpc-none-true-yet @item @code{vmpc-none-true-yet} returns true if none of the conditions that come before it in @code{vmpc-conditions} have returned true. You can optionally specify exceptions, so that it can act as a "none-true-yet-except..." condition. This is a very useful shortcut to place last in the list, in order to trigger an action prompting you for a profile to use. @end itemize You can also use @code{y-or-n-p} for interactive querying, if you always want to have a choice in what to do when a certain condition occurs. We will cover all of these in the examples that follow. @c *************************************************************************** @c @node vmpc-conditions examples, , The vmpc-conditions variable, vmpc-conditions @c node-name, next, previous, up @subsection vmpc-conditions examples @anchor{vmpc-conditions examples} Suppose you wanted to set up a condition that triggered when you replied to messages that came from a particular mailing list. Looking at the headers of these messages, (exposing all of them with @code{t} in VM), you see that they always have a header like this: Resent-Sender: foo-list-maintainer@@bar.baz.com Then, in your ~/.vm file, you would have something like this: @lisp (setq vmpc-conditions '( ("foo-list messages" (vmpc-header-match "Resent-Sender" "foo-list-maintainer@@bar.baz.com")) )) @end lisp This gives you a condition called "foo-list messages" which returns true when the contents of the "Resent-Sender" header include a match for the regular expression "foo-list-maintainer@@bar.baz.com". ----------------------------------------------------------------- @subheading Regexp Aside #1: Usually this will be perfectly adequate. Of course, since the second string is a regexp, this will also match "foo-list-maintainer@@barybaz.com", but the odds that you'll come across that are pretty low. However, if the header contents had included another regexp special character, it might not match at all. The easiest way to deal with both these problems is to wrap the string up in a call to @code{regexp-quote}. Like this: @lisp (setq vmpc-conditions '( ("foo-list messages" (vmpc-header-match "Resent-Sender" (regexp-quote "foo-list-maintainer@@bar.baz.com"))) )) @end lisp @subheading Regexp Aside #2: The @code{regexp-opt} function provides a convenient way of producing a regexp to match against any number of strings. Suppose the "Resent-Sender" field could contain either "foo-list-maintainer@@bar.baz.com" or "foo-list-bot@@bar.baz.com". Then you could use @code{regexp-opt} like this: @lisp (setq vmpc-conditions '( ("foo-list messages" (vmpc-header-match "Resent-Sender" (regexp-opt '("foo-list-maintainer@@bar.baz.com" "foo-list-bot@@bar.baz.com")))) )) @end lisp @subheading Regexp Aside #3: If you write your own regular expressions instead of using @code{regexp-quote} and @code{regexp-opt}, you should keep in mind that they must be in lisp syntax. In short, this means that you should use two backslashes wherever you would usually use one, and if you use a double-quote (") it should be escaped with a backslash to avoid prematurely ending the string. You can learn more about regexps from your Emacs documentation. @subheading Regexp Aside #4: The behaviour of vmpc-header-match is to return true if a match for the regular expression occurs anywhere in the contents of the header. If you want your regexp to only match the entire header contents, it should begin with a caret (^) and end with a dollar sign ($). ----------------------------------------------------------------- Alright, enough about regexps! Let's get on with the example. Suppose the next thing you want to do is set up a condition that triggers when somebody sends you one of those blasted HTML emails. (When we look at @code{vmpc-actions} you'll see how you can automatically include a form letter asking them not to do this in your reply.) Your setup might now expand to this: @lisp (setq vmpc-conditions '( ("foo-list messages" (vmpc-header-match "Resent-Sender" (regexp-quote "foo-list-maintainer@@bar.baz.com"))) ("html messages" (vmpc-header-match "Content-type" "multipart/alternative\\|html")) )) @end lisp Let's further suppose that foo-list is set up so that replies go to the entire list, and that you haven't over-ridden this with @code{vm-reply-ignored-reply-tos} because it's usually what you want. But when somebody sends an html message to the list, you now have a setup which results in your anti-html form letter being included in a message to the whole list. You'd rather it went to them personally. Okay, let's set up some more refined conditions: @lisp (setq vmpc-conditions '( ("foo-list messages" (vmpc-header-match "Resent-Sender" (regexp-quote "foo-list-maintainer@@bar.baz.com"))) ("html messages" (vmpc-header-match "Content-type" "multipart/alternative\\|html")) ("plaintext messages from foo-list" (and (vmpc-other-cond "foo-list messages") (not (vmpc-other-cond "html messages")))) ("html messages from foo-list" (and (vmpc-other-cond "foo-list-messages") (vmpc-other-cond "html messages"))) ("html messages not from foo-list" (and (vmpc-other-cond "html messages") (not (vmpc-other-cond "foo-list messages")))) )) @end lisp All of a sudden you have five conditions, but you'll only associate the last three of them with actions. The first two are just building blocks for the others. So now you can associate different actions with each condition: For html messages from foo-list, you can change the To: address in your reply to point to the original sender, as well as including your anti-html form letter; for html messages not from foo-list, just include the form letter; and for plaintext messages from foo-list, set up your desired personality for a normal reply to the list. What if you want a condition that always returns true, so you can associate it with an action that you want performed every time? It would look like this: @lisp ("condition that's always true" 't) @end lisp ----------------------------------------------------------------- @subheading Aside: If you want one that always triggers for replies, but not when using @code{vmpc-automorph}, it would look like this: @lisp ("condition that's always true for replies" (eq vmpc-current-state 'reply)) @end lisp Similarly, for one that always triggers with automorph, but not for replies, you'd have: @lisp ("condition that's always true for automorph" (eq vmpc-current-state 'automorph)) @end lisp ----------------------------------------------------------------- If you add that condition, and more to deal with other mailing lists and situations, you might want to be prompted about what action to take when none of the conditions match (except, of course, the one that's always true). This simplest way to produce such a condition (which you can then associate with a prompting action) is to use @code{vmpc-none-true-yet}. So you'd end up with something like: @lisp (setq vmpc-conditions '( ("condition that's always true" 't) ("foo-list messages" (vmpc-header-match "Resent-Sender" (regexp-quote "foo-list-maintainer@@bar.baz.com"))) ("html messages" (vmpc-header-match "Content-type" "multipart/alternative\\|html")) ("plaintext messages from foo-list" (and (vmpc-other-cond "foo-list messages") (not (vmpc-other-cond "html messages")))) ("html messages from foo-list" (and (vmpc-other-cond "foo-list-messages") (vmpc-other-cond "html messages"))) ("html messages not from foo-list" (and (vmpc-other-cond "html messages") (not (vmpc-other-cond "foo-list messages")))) ;; any number of other conditions could go here ("unknown sender" (vmpc-none-true-yet "condition that's always true")) )) @end lisp It's also possible to match against the text in the body of a message you are replying to, forwarding or composing. If you wanted to check whether the phrase "make money fast" appeared in a message, you'd have a condition like this: @lisp ("message from an idiot" (vmpc-body-match "make[\n ]+money[\n ]+fast")) @end lisp Note how the regexp is constructed in order to take account of the fact that the phrase may be split over more than one line. Both @code{vmpc-header-match} and @code{vmpc-body-match} are affected by your default value of @code{case-fold-search}. If you wanted to force a case-sensitive search in the previous example, you'd re-write it like this: @lisp ("message from an idiot using all-caps" (let ((case-fold-search nil)) (vmpc-body-match "MAKE[\n ]+MONEY[\n ]+FAST"))) @end lisp Similarly, if you wanted to force it to be case-insensitive, you'd do this: @lisp ("message from an idiot using any case" (let ((case-fold-search t)) (vmpc-body-match "make[\n ]+money[\n ]+fast"))) @end lisp You can use @code{vmpc-header-match} to test if a regexp appears in any header field matching another regexp. For example, to find out if the regexp "fire\\|water" appears in any header, you would use something like @lisp (vmpc-header-match "[^ \t\n:]+:" "fire\\|water" ", ") @end lisp Essentially what this does is to take the contents of every header in the message, put them all together in a gigantic string -- separated from each other by a comma and a space -- and run @lisp (string-match "fire\\|water" gigantic-string-of-all-headers) @end lisp In the event that you want to look for a regexp that includes ", " you can use a different string as the separator to ensure that a match doesn't span the contents of different headers. The above header field regexp checks every single header -- even the X-VM-v5-Data header. You could use a more restrictive regular expression for the header name if you prefer. For example, to check only the From: and Apparently-To: headers, you could use @lisp (vmpc-header-match "From:\\|Apparently-To:" "fire\\|water" ", ") @end lisp What if you have an action that you only want to perform if the message is from foo-list and doesn't have "bar" in the subject, or the message is not from foo-list and does have "bar" in the subject, or if the message has "quux" in the subject, regardless of whether it's from foo-list or not? And what if, even then, you only want the action performed if you answer yes to a prompt? Here's what the condition would look like: @lisp ("a complex condition" (and (or (vmpc-xor (vmpc-other-cond "foo-list-messages") (vmpc-header-match "bar")) (vmpc-header-match "quux")) (y-or-n-p "Perform action for complex condition? "))) @end lisp It will only prompt you if the @code{or} part is true, because that's how the @code{and} form works in elisp --- it stops evaluating its arguments after the first false one it finds. Okay, I believe I've gone into much more depth here than the average user will ever need; the point is that with a little lisp knowledge you can have as fine a control over the automated actions of vm-pcrisis as you need. Even without real lisp knowledge, I hope that you can figure out enough from these examples to achieve such control. @c *************************************************************************** @node Actions, Rules, Conditions, Setting Up @c node-name, next, previous, up @section Actions @c @menu @c * The vmpc-actions variable:: @c * vmpc-actions examples:: @c @end menu @c @node The vmpc-actions variable, vmpc-actions examples, vmpc-actions, vmpc-actions @unnumberedsubsec The vmpc-actions variable @anchor{vmpc-actions} The @code{vmpc-actions} variable is a list of actions, which can equally be referred to as "profiles". You will set up some of them for replies, some for @code{vmpc-automorph} (if you use it), and some for when you are prompted for a profile (if you have an action that uses @code{vmpc-prompt-for-profile}). Many will be equally applicable in all three cases, which is why they are all kept in the same place. Each action is given a unique, descriptive name, and consists of one or more function calls, so that the format of the list looks something like this: @lisp '( ("foo" (function-1 arg1 arg2) (function-2) (function-3 arg1)) ("bar" (function-4)) ) @end lisp This will start making sense with the real examples in the next section. But first, we'll look at what functions are available here: @itemize @bullet @findex vmpc-signature @item (vmpc-signature "signature-file") will replace the signature in your message with the contents of the specified file, if it exists; otherwise the string itself will be used as the signature. @findex vmpc-pre-signature @item (vmpc-pre-signature "pre-signature-file") works in the same way, but specifies a "pre-signature" --- text that is inserted in your message above the signature. @findex vmpc-substitute-header @item (vmpc-substitute-header "Header-Field" "new header contents") will replace the contents of the specified header-field in your message with the new contents, creating the header field if necessary. @findex vmpc-substitute-replied-header @item (vmpc-substitute-replied-header "Dest-Header" "Src-Header") takes the contents of the Src-Header field in the message you are replying to, and inserts them as the contents of the Dest-Header field in your reply, creating the Dest-Header field if necessary. (If it's contained in an action which is called when you are not replying to a message, it does nothing. The same is true of all of these functions: when they are called in an inappropriate context, they only do as much as they can.) @findex vmpc-pre-function @item (vmpc-pre-function (foo-function args)) evaluates the lisp expression @lisp (foo-function args) @end lisp before VM creates a mail composition buffer. (This is useful for setting VM variables which need to be set at this stage, such as the message encoding.) It therefore does nothing in automorph mode. @findex vmpc-composition-buffer @item (vmpc-composition-buffer (foo-function args)) does the same, but in the composition buffer. @findex vmpc-prompt-for-profile @item (vmpc-prompt-for-profile arg) prompts the user for a profile (action) to run. (The user would be well advised not to choose one which itself contains this function!) If ARG is present, it should be set to 'prompt or t. The presence of ARG indicates that you want it to check who your message is destined for, and remember to apply the profile you choose now to messages sent to that person in the future, instead of prompting you for a profile the next time. If set to 'prompt, it will ask whether it should remember; if set to t, it will always remember. If ARG is not present, it does not remember. @end itemize Do not include your own functions in actions directly; call them with @code{vmpc-pre-function} or @code{vmpc-composition-buffer} instead -- otherwise they will be called twice, both before and after the composition buffer is created. @c *************************************************************************** @c @node vmpc-actions examples, , The vmpc-actions variable, vmpc-actions @c node-name, next, previous, up @unnumberedsubsec vmpc-actions examples @anchor{vmpc-actions examples} In your ~/.vm you'll have something like this: @lisp (setq vmpc-actions '( ;; actions go here )) @end lisp Okay, here come some example actions which you can adapt and place, one after the other, in the place of the comment above. Say you wanted two personality profiles from which you could choose when prompted, and to automatically apply when certain conditions were met with replies or in automorph mode. One thing to bear in mind is that when you are prompted, there will be auto-completion available --- you'll only need to type enough to uniquely identify a profile (you won't even need to hit TAB). Also, the first profile in @code{vmpc-actions} will be the default at the prompt, so you can just hit RET to use it. Therefore, the first profile you place in @code{vmpc-actions} should be the one you expect to use most often, and you should choose names for profiles which uniquely distinguish themselves at the first or second character. Okay, here are a couple of profiles which show how to insert signatures and change the contents of a header field. @lisp ("foo on the hill" (vmpc-substitute-header "From" "\"The Foo On The Hill\" ") (vmpc-signature "~/.foo-sig")) ("david" (vmpc-substitute-header "From" "\"David Foo\" ") (vmpc-signature "")) @end lisp When an empty string is given as the signature, as in the second profile, vm-pcrisis will actually remove any signature that has been placed there by other actions. Also note that by including a From: header, we override the values of @code{user-full-name} and @code{user-mail-address}. We could equally well have chosen to override those values directly using composition-buffer-functions, like this: @lisp ("foo on the hill" (vmpc-composition-buffer (setq user-full-name "The Foo On The Hill") (setq user-mail-address "foo@@hill.com")) (vmpc-signature "~/.foo-sig")) ("david" (vmpc-composition-buffer (setq user-full-name "David Foo")) (setq user-mail-address "foo@@hill.com")) (vmpc-signature "")) @end lisp If we had two different mailboxes and wanted to direct replies back into the right one, we would want to also set @code{mail-default-reply-to}, or use @code{vmpc-substitute-header} to insert a Reply-To: header. ----------------------------------------------------------------- @subheading Aside: Why did we use @code{vmpc-composition-buffer} rather than @code{vmpc-pre-function} to set those variables? Well, their values are only examined when you actually send your message, so you could equally well set them with either, but the @code{vmpc-automorph} function does not run pre-functions, so if we want these profiles to work properly for automorph, we need to use composition-buffer-functions. In other cases, such as setting VM's charset variables, you have no option but to use pre-functions, because they have to be set to appropriate values before the composition buffer is created. If anyone finds a workaround for this, please let me know so I can include it here. ----------------------------------------------------------------- Pre-signatures can be specified in the same way as signatures: @lisp ("insert anti-html form letter" (vmpc-pre-signature "~/stuff/formletters/why_html_is_bad.txt")) @end lisp Alright, suppose that messages from foo-list have their Reply-To: header set to point back to the list, with the address of the real sender in the From: field. We could override it with @code{vm-reply-ignored-reply-tos}, but usually we prefer this behaviour. Only under certain conditions do we want to set our To: field to the contents of the From: field in the replied message. The action to do this would look like this: @lisp ("set To to From" (vmpc-substitute-replied-header "To" "From")) @end lisp Let's say we also want an action that can prompt us for a profile, so we can associate it with an "unknown sender" condition. Here we go: @lisp ("prompt for a profile" (vmpc-prompt-for-profile)) @end lisp If we want vm-pcrisis to figure out who our message is destined for and to remember to use the profile we choose the next time we send to that address instead of prompting, we would do it like this: @lisp ("prompt for a profile, and remember it automatically" (vmpc-prompt-for-profile t)) @end lisp The associations between addresses and profiles will be stored in the file named by @code{vmpc-auto-profiles-file} --- by default, this is "~/.vmpc-auto-profiles". If your OS has a shonky filesystem that can not deal with filenames like that, you might have to change this value. Keep in mind that the associations stored in this file are only used by @code{vmpc-prompt-for-profile}. They do not have the effect of adding new associations between addresses and profiles in the general operation of vm-pcrisis; they are simply used by @code{vmpc-prompt-for-profile} instead of prompting you in the future. IMPORTANT: When vm-pcrisis decides who your message is destined for, it does so on the basis of the Reply-To: or From: field of the message being replied (or in the case of automorph, the To: field of your message). This takes account of @code{vm-reply-ignored-reply-tos}, but DOES NOT take account of any other actions which might change the To: address in your message. There is, therefore, a possibility that when using this feature in both automorph and reply mode, an association made in one mode may not be properly suited to the other. The best way to avoid this problem is to set up your conditions so that the above action is not run in conjunction with other actions that change the To: field. This is not really limiting, because the situations in which you are changing the To: field will generally be ones in which you know which profile you want to use anyway. You can also set it up so that after prompting you for a profile, it will tell you which address it has decided your message is going to, and prompt you whether to save an association between that profile and that address. Like this: @lisp ("prompt for a profile, and remember it if I say so" (vmpc-prompt-for-profile 'prompt)) @end lisp @c *************************************************************************** @node Rules, Automorph, Actions, Setting Up @section Associating Conditions with Actions @c @menu @c * vmpc-action-alist:: @c * vmpc-reply-alist:: @c * vmpc-automorph-alist:: @c * vmpc-forward-alist:: @c * vmpc-resend-alist:: @c * vmpc-newmail-alist:: @c @end menu @c *************************************************************************** @unnumberedsubsec vmpc-action-alist @vindex vmpc-action-alist The @code{vmpc-action-alist} variable controls which actions are performed if various conditions are met when creating a reply. Its format is something like this: @lisp '( ("condition 1" "action 1" "action 2") ("condition 2" "action 3") ... ) @end lisp If you do not want to set all the other alists then sent this one as it will be used as a fall back. @c *************************************************************************** @unnumberedsubsec vmpc-reply-alist @vindex vmpc-reply-alist @anchor{vmpc-reply-alist} The @code{vmpc-reply-alist} variable controls which actions are performed if various conditions are met when creating a reply. Its format is something like this: @lisp '( ("condition 1" "action 1" "action 2") ("condition 2" "action 3") ... ) @end lisp If we follow on from our examples in the previous sections, we might have this in our ~/.vm file: @lisp (setq vmpc-reply-alist '( ("condition that's always true" "david") ("plaintext messages from foo-list" "foo on the hill") ("html messages from foo-list" "set To to From" "insert anti-html form letter") ("html messages not from foo-list" "insert anti-html form letter") ("unknown sender" "prompt for a profile, and remember it if I say so") )) @end lisp @c *************************************************************************** @unnumberedsubsec vmpc-automorph-alist @vindex vmpc-automorph-alist @anchor{vmpc-automorph-alist} The @code{vmpc-automorph-alist} variable has the same syntax as @code{vmpc-reply-alist} and follows the same principles. (See @ref{vmpc-reply-alist}.) The only difference is that it controls which actions are associated with which conditions when the @code{vmpc-automorph} function is called. @c *************************************************************************** @unnumberedsubsec vmpc-forward-alist @vindex vmpc-forward-alist The @code{vmpc-forward-alist} variable has the same syntax as @code{vmpc-reply-alist} and follows the same principles. (See @ref{vmpc-reply-alist}.) The only difference is that it controls which actions are associated with which conditions when forwarding messages. @c *************************************************************************** @unnumberedsubsec vmpc-resend-alist @vindex vmpc-resend-alist The @code{vmpc-resend-alist} variable has the same syntax as @code{vmpc-reply-alist} and follows the same principles. (See @ref{vmpc-reply-alist}.) The only difference is that it controls which actions are associated with which conditions when resending messages with @code{vm-resend-message}. @c *************************************************************************** @unnumberedsubsec vmpc-newmail-alist @vindex vmpc-newmail-alist @anchor{vmpc-newmail-alist} The @code{vmpc-newmail-alist} variable has the same syntax as @code{vmpc-reply-alist} and follows the same principles. (See @ref{vmpc-reply-alist}.) The only difference is that it controls which actions are associated with which conditions when creating new messages with vm-mail. One strategy for this is to have conditions based on the folder from which you are sending mail. You might like to set things this up for some folders, and have vm-pcrisis prompt you for an action in the other folders. Here's how you might do that... In @code{vmpc-conditions}, you'd have a couple of conditions like this: @lisp ("mail to foo-list" (string-match "^foo" (buffer-name (current-buffer)))) ("no cond" (vmpc-none-true-yet)) @end lisp Then in @code{vmpc-actions}, you'd set up an action for your mail to foo-list, and another one to prompt you for a profile: @lisp ("foo profile" (vmpc-substitute-header "From" "\"The Foo King\" ") (vmpc-signature "~/.foo-sig")) ("prompt" (vmpc-prompt-for-profile)) @end lisp Finally, you'd set up @code{vmpc-newmail-alist} like this: @lisp (setq vmpc-newmail-alist '( ("mail to foo-list" "foo profile") ("no cond" "prompt") )) @end lisp @c *************************************************************************** @node Automorph, , Rules, Setting Up @section Calling Automorph The @code{vmpc-automorph} function automatically sets various things in a mail message based on what's already present in its headers. Obviously, you'll need to have entered those headers before it is called. You'll have to set up what this function does --- for which, see @ref{vmpc-conditions}, @ref{vmpc-actions} and @ref{vmpc-automorph-alist} --- but you'll also have to consider when you want it called. Most people would prefer never to have to call it explicitly; it's generally nicer to just have it called automatically when you do one of the other things that you have to do in the course of composing a message. Here are a couple of ideas: @itemize @bullet @item Hitching a ride on the mail-text function: automorph with C-c C-t.@* A very good idea if you are in the habit of using this to move from your headers to the body of your message. @item Let vm-pcrisis help you: tab between headers.@* See below for more about this. @item Pre-empting vm-mail-send-and-exit: automorph with C-c C-c.@* A rather foolish idea, in my opinion. You'll never get to see the results of what automorph does. If there should happen to be a bug in Personality Crisis that fails to take into account, say, multi-line headers, you might end up sending a mail to your boss with an inappropriate signature that, say, mentions his wife in an unflattering way, and find yourself all-too-suddenly unemployed. How likely is this? Well, in a previous version, such a bug existed. I fixed it, but there could be more like it; I wouldn't risk it. @item Calling it explicitly with some key combo.@* Boring but easy. @end itemize The last of these is the easiest --- just bind it to a key in mail mode. For example, to bind it to the F7 key, you might put this in your ~/.vm file: @lisp (define-key vm-mail-mode-map [f7] 'vmpc-automorph) @end lisp Attaching to other functions is also fairly straightforward. Just use a wrapper function. For example: @lisp (defun mail-text-and-automorph () (interactive) (mail-text) (vmpc-automorph)) @end lisp Then bind this function to C-c C-t (or whatever keystroke you like to use). But what's this thing about tabbing between headers? Well, if you just want to hit TAB to go from the To: field to the Subject: field, and TAB again to then go to the start of the message body, calling @code{vmpc-automorph} along the way, you can add this in your ~/.vm file: @lisp (define-key vm-mail-mode-map [tab] 'vmpc-tab-header-or-tab-stop) @end lisp If you also want shift-tab to take you back to the previous header, you should check what keysym is produced by shift-tab on your system, by doing @code{Ctrl-h k Shift-TAB} -- for me, it produces @code{iso-left-tab}. So I add this to my ~/.vm: @lisp (define-key vm-mail-mode-map [iso-left-tab] 'vmpc-backward-tab-header-or-tab-stop) @end lisp You can use any one or more of these ideas, calling the automorph function as often as you like. Because its actions depend on the headers, and those actions can include the changing of headers, calling it twice may not have the same effect as calling it once. It may pay to bear this in mind when you set up the profiles! @c *************************************************************************** @node Miscellaneous Variables, Debugging, Setting Up, Top @c node-name, next, previous, up @chapter Miscellaneous Variables @c @menu @c * vmpc-auto-profiles-file:: @c * vmpc-auto-profiles-expunge-days:: @c * vmpc-sig-face:: @c * vmpc-pre-sig-face:: @c * vmpc-intangible-sig:: @c * vmpc-intangible-pre-sig:: @c * vmpc-expect-default-signature:: @c @end menu @c *************************************************************************** @unnumberedsubsec vmpc-auto-profiles-file @vindex vmpc-auto-profiles-file The variable @code{vmpc-auto-profiles-file} contains the name of the file used for saving profiles when @code{vmpc-prompt-for-profile} is used with a non-nil argument (see @ref{vmpc-actions} and @ref{vmpc-actions examples}). By default it is set to "~/.vmpc-auto-profiles". @c *************************************************************************** @unnumberedsubsec vmpc-auto-profiles-expunge-days @vindex vmpc-auto-profiles-expunge-days In order to keep vmpc-auto-profiles-file from becoming massive, Personality Crisis will check the age of profile associations in that file each time it adds a new one. Associations that have not been used in the last number of days given by @code{vmpc-auto-profiles-expunge-days} will be removed. This variable is set to 100 by default. @c *************************************************************************** @unnumberedsubsec vmpc-sig-face @vindex vmpc-sig-face This is the face used to highlight the signature. You can use @code{set-face-foreground}, @code{set-face-background} and @code{set-face-font} to change the colours and font. @c *************************************************************************** @unnumberedsubsec vmpc-pre-sig-face @vindex vmpc-pre-sig-face This is the face used to highlight the pre-signature. You can use @code{set-face-foreground}, @code{set-face-background} and @code{set-face-font} to change the colours and font. @c *************************************************************************** @unnumberedsubsec vmpc-intangible-sig @vindex vmpc-intangible-sig @anchor{vmpc-intangible-sig} If @code{vmpc-intangible-sig} is non-nil, movement and mouse commands will cause your cursor to slide to one side or the other of the signature, preventing you from actually writing text inside the area that Personality Crisis calls the signature. This is somewhat useful because if automorph replaces the signature, you probably won't want any text you added to be replaced along with it. To activate this feature, just add the following to your ~/.vm file: @lisp (setq vmpc-intangible-sig t) @end lisp @c *************************************************************************** @unnumberedsubsec vmpc-intangible-pre-sig @vindex vmpc-intangible-pre-sig The @code{vmpc-intangible-pre-sig} variable works just like @code{vmpc-intangible-sig}, but affects the pre-signature. See @ref{vmpc-intangible-sig}. @c *************************************************************************** @unnumberedsubsec vmpc-expect-default-signature @vindex vmpc-expect-default-signature Traditionally, signatures are added to new mail messages using a signature-insertion function bound to @code{mail-mode-hook} or similar, so that every message you wrote started off containing a signature. If you use the vm-pcrisis signature functions in addition to such a setup, you should add the following to your ~/.vm file: (setq vmpc-expect-default-signature t) This will allow Personality Crisis to properly take account of your setup, provided that your signature-insertion function uses the standard @samp{\n-- \n} signature delimiter. @c *************************************************************************** @node Debugging, Version History, Miscellaneous Variables, Top @c node-name, next, previous, up @chapter Debugging With a complex setup it can be come hard to understand why vm-pcrisis is doing a specific thing. In order to understand what is going on you should check the value of the following variables: @itemize @bullet @item @code{vmpc-true-conditions} is the list of true conditions. @item @code{vmpc-actions-to-run} is the list of actions to run, i.e. those actions mapped by a @code{vmpc-*-alist}. @item @code{vmpc-saved-headers-alist} the value of headers saved for substitution. @end itemize If you want to check new contions you can run @code{vmpc-build-true-conditions-list} interactively. If you want to check which true conditions are mapped to actions you can run @code{vmpc-build-actions-to-run-list} interactively. True conditions which are not mapped to an action are silently ignored. If you want to run new actions you can run @code{vmpc-read-actions} and @code{vmpc-run-actions} interactively. @c *************************************************************************** @node Version History, Variable Index , Debugging, Top @c node-name, next, previous, up @chapter Version History Version 0.11: @itemize @bullet @item Profiles can now be stored in the BBDB instead of the file @code{vmpc-auto-profiles-file}. To enable this and migrate your old profiles you should call @code{vmpc-migrate-profiles-to-BBDB} once. A backup of your BBDB will be created first as @file{~/.bbdb-vmpc-profile-migration-backup} and your old profiles-file will be moved to @file{~/.vmpc-auto-profiles-migrated-to-BBDB}. @item Added @code{vmpc-add-header} which allows to create a header multiple times. This is useful when having more than one FCC header. @item @code{vmpc-prompt-for-profile} finds now all profiles, i.e. before it stopped at the first match, now it will check all email addresses. @end itemize Version 0.10: @itemize @bullet @item Added support for a list of actions in @code{vmpc-prompt-for-profile}. Before it was only possible to specify a single action. @end itemize Version 0.9: @itemize @bullet @item The new maintainer is: Robert Widhopf-Fenk @item All variables of pcrisis can be customized now. @item Added new function @code{vmpc-toggle-no-automorph} to disable automorph for the current buffer. @item @code{vmpc-prompt-for-profile} checks all relevant headers now and will only prompt for a profile if no matches were found. It also can be called interactively to correct a existing profile association. @item Renamed @code{vmpc-composition-buffer-function} to @code{vmpc-composition-buffer}. @item @code{vmpc-pre-function} and @code{vmpc-composition-buffer} handle forms now, not only a single function which must be quoted. @item Renamed @code{vmpc-replies-alist} to @code{vmpc-reply-alist} and @code{vmpc-forwards-alist} to @code{vmpc-forward-alist} for consistency. @item New function @code{vmpc-true-conditions} to test conditions without actually running some actions. @item New function @code{vmpc-read-actions} to set actions by hand. @item @code{vmpc-build-actions-to-run-list} and @code{vmpc-run-actions} are interactive now. @item @code{vmpc-prompt-for-profile} will search all headers for a recipient with an associated profile before prompting for one. @item When calling @code{vmpc-prompt-for-profile} interactively form a composition buffer one will get prompted again for a profile. This allows to easily fix a bad association. @item The state variables become buffer-local now, which should prevent some bugs, i.e. for saved headers. @item Rewrite of unlispish code. @item @code{M-x checkdoc RET} @item Several bug fixes and enhancements from Robert P. Goldman. @item Fixes and updates of the info file. @end itemize Version 0.85: @itemize @bullet @item This version adds @code{vmpc-resend-alist}, which should be especially useful for mailing list maintainers who receive bounced non-member posts, and anyone else who frequently uses @code{vm-resend-message}. @end itemize Version 0.84: @itemize @bullet @item There is now a @code{vmpc-newmail-alist} in recognition of the fact that you @strong{can} actually test for useful criteria (such as what folder you are in when you invoke vm-mail) when creating a brand new message. @item Due to the above, the @code{vmpc-newmail-prompt-for-profile} variable is now obsoleted. Its effect can be duplicated easily enough; see @ref{vmpc-newmail-alist} for details. @end itemize Older versions: @itemize @bullet @item Pre-signatures and signatures are now dealt with in a more sensible manner. You might not notice the difference, except that you can now have them highlighted in @code{vmpc-pre-sig-face} and @code{vmpc-sig-face}, and you can set up either so that your cursor skips across them with @code{vmpc-intangible-pre-sig} and @code{vmpc-intangible-sig}. However, if you use another signature package to insert a signature in every mail buffer, you should look at setting @code{vmpc-expect-default-signature}. @item You can now use vm-pcrisis in conjunction with the forwarding functions of VM. Just set up @code{vmpc-forwards-alist}, which has an identical format to @code{vmpc-replies-alist}. @item There is now a @code{vmpc-body-match} function which matches text in the body of a message you are composing, replying to or forwarding. See @ref{vmpc-conditions examples} for more about that. @item You can now use @code{vmpc-header-match} to test if a regexp appears in any header field matching another regexp. For example, to find out if the regexp "fire\\|water" appears in any header, you would use something like @lisp (vmpc-header-match "[^ \t\n:]+:" "fire\\|water" ", ") @end lisp For further details, again see @ref{vmpc-conditions examples}. @item @code{vmpc-auto-profiles-expunge-days} can now be set to nil if you want to never expunge old profile associations. Associations are now "touched" each time they are used, so that as long as they are used more often than @code{vmpc-auto-profiles-expunge-days} they will never be expunged. @end itemize @node Variable Index, Function Index, Version History, Top @unnumbered Variable Index @printindex vr @node Function Index, , Variable Index, Top @unnumbered Function Index @printindex fn @bye vm-8.2.0b/info/Makefile.in0000755000175000017500000000506311676442161015576 0ustar srivastasrivasta@SET_MAKE@ # no csh please SHELL = /bin/sh # the version of this package PACKAGE_VERSION = @PACKAGE_VERSION@ ############################################################################## # location of required programms prefix = @prefix@ MKDIR = @MKDIR@ RM = @RM@ LS = @LS@ XARGS = @XARGS@ INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_DATA = @INSTALL_DATA@ top_srcdir = @top_srcdir@ srcdir = @srcdir@ datadir= @datadir@ datarootdir= @datarootdir@ info_dir = @info_dir@ EMACS_PROG = @EMACS_PROG@ EMACS_FLAVOR = @EMACS_FLAVOR@ FLAGS = @FLAGS@ SYMLINKS = @SYMLINKS@ LINKPATH = @LINKPATH@ ############################################################################## all: info version.texinfo: echo @set VERSION $(PACKAGE_VERSION) > $@ vm.info:: version.texinfo vm-pcrisis.info:: version.texinfo info: vm.info vm-pcrisis.info Makefile: @srcdir@/Makefile.in cd @srcdir@/..; ./config.status install: install-pkg install-pkg: uninstall-pkg info @mkdir -p -m 0755 "$(DESTDIR)$(info_dir)"; \ if test "x$(SYMLINKS)" = "xno" ; then \ for i in `${LS} *.info* ` ; do \ echo "Installing $$i in $(DESTDIR)$(info_dir)" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(info_dir)" ; \ done ; \ else \ if test "x$(LINKPATH)" = "x" ; then \ for i in `${LS} *.info* ` ; do \ echo "Linking $$i in $(DESTDIR)$(info_dir)" ; \ $(LN_S) "`pwd`/$$i" "$(DESTDIR)$(info_dir)/$$i" ; \ done ; \ else \ for i in `${LS} *.info* ` ; do \ echo "Linking $(LINKPATH)/texinfo/$$i in $(DESTDIR)$(info_dir)" ; \ $(LN_S) "$(LINKPATH)/texinfo/$$i" "$(DESTDIR)$(info_dir)/$$i" ; \ done ; \ fi ; \ fi @echo VM INFO files successfully installed\! uninstall-pkg: -$(RM) "$(DESTDIR)$(info_dir)"/vm*.info* ############################################################################## clean: -$(RM) -f version.texinfo *.info *.info-[0-9] distclean: clean -$(RM) -f Makefile vm-8.2.0b/info/vm.texinfo0000755000175000017500000131245411676442160015556 0ustar srivastasrivasta\input texinfo @setfilename vm.info @settitle VM User's Manual @dircategory Emacs @direntry * VM: (vm). A mail reader. @end direntry @defindex in @iftex @finalout @end iftex @c @setchapternewpage odd % For book style double sided manual. @c @smallbook @tex \overfullrule=0pt %\global\baselineskip 30pt % For printing in double spaces @end tex @ifinfo This file documents the VM mail reader. @table @asis @item Copyright (C) 1989, 1991, 1999 Kyle E. Jones @item Copyright (C) 2003 - 2008 Robert Widhopf-Fenk @item Copyright (C) 2008 - 2012 Uday S. Reddy @end table Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @ignore Permission is granted to process this file through TeX and print the results, provided the printed document carries copying permission notice identical to this one except for the removal of this paragraph (this paragraph not being relevant to the printed manual). @end ignore @end ifinfo @c @include version.texinfo @titlepage @sp 6 @center @titlefont{VM User's Manual} @sp 4 @center VM Version @value{VERSION} @sp 5 @page @vskip 0pt plus 1filll Copyright @copyright{} 1989, 1991, 1999, 2002, 2003 Kyle E. Jones Copyright @copyright{} 2003 - 2008 Robert Widhopf-Fenk Copyright @copyright{} 2008 - 2009 Uday S. Reddy Permission is granted to make and distribute verbatim copies of this manual provided the copyright notice and this permission notice are preserved on all copies. @end titlepage @page @ifnottex @node Top, Preface,, (DIR) This manual documents the VM mail reader, a Lisp program which runs as a subsystem under Emacs. The manual is divided into the following chapters. This manual corresponds to VM version @value{VERSION}. @menu * Preface:: What is VM? * Introduction:: Overview of the VM interface. * Starting Up:: What happens when you start VM. * Selecting Messages:: How to select messages for reading. * Reading Messages:: Previewing and paging through a message. * Sending Messages:: How to send messages from within VM. * Saving Messages:: How to save messages. * Deleting Messages:: How to delete, undelete and expunge messages. * Editing Messages:: How to alter the text and headers of a message. * Marking Messages:: Running VM commands on arbitrary sets of messages. * Message Attributes:: How to change and undo changes to message attributes. * Sorting Messages:: How to make VM present similar messages together. * Digests:: How to read digests under VM. * Summaries:: How to view and customize the summary of a folder. * Virtual Folders:: Blurring the boundaries of different physical folders. * @acronym{IMAP} Server Folders:: Working with IMAP server folders. * Frames and Windows:: How to customize VM's use of windows and frames. * Toolbar:: How to configure VM's toolbar. * Menus:: How to configure VM's menus. * Faces:: How to configure VM's use of faces. * Using the Mouse:: Understanding the VM mouse interface. * Hooks:: How you can make VM run your code at certain times. Add-ons and Customizations: * Preface to Add-ons:: What are these? * Customizations:: Making VM behave the way you might want. * Add-ons:: Contributed packages adding functionality to VM. About VM: * History and Administration:: Information about VM * Highlights:: Most valuable features of VM, as per the users. * Future Plans:: Planned extensions of VM for the future * Bugs:: How to report VM bugs For developers: * Internals:: Information on VM internals for developers Indices: * Concept Index:: Menus of key concepts * Key Index:: Menus of command keys and their references. * Command Index:: Menus of commands and their references. * Variable Index:: Menus of variables and their references. * Internals Index:: Menus of concepts in VM Internals Rights: * License:: Copying and distribution terms for VM. @end menu @end ifnottex @node Preface, Introduction, Top, Top @unnumbered What is VM? @cindex Rmail @cindex Gnus @cindex Gnu Emacs @cindex XEmacs @cindex Emacs VM, short for ``View Mail,'' is a mail reader that runs within the Emacs editor. If you are already an Emacs-user, you will be working in a familiar environment. You might have even used other Emacs-based mail readers such as Rmail and Gnus. If you are new to Emacs, you can start using VM via the menubar and toolbar until you become familiar with it. Then you can move on to keyboard shortcuts and advanced features. You should be aware that there are two major strands of Emacs versions, called ``Gnu Emacs'' and ``XEmacs.'' VM works in both of them. XEmacs might be a bit easier for new users due to its advanced support for menus and other interactive features. Please be sure to try both of them before deciding on your choice. Emacs provides a powerful text-based user interface for VM users, with facilities for quick navigation, incremental searching , sophisticated customization and powerful add-on functions. You also have all the editing features of Emacs available for composing mail, without having to switch environments. @cindex virtual folders @cindex archiving @cindex address book @cindex @acronym{MIME} @cindex encryption @cindex @acronym{BBDB} @cindex Org mode @cindex @acronym{GPG} VM was developed by Kyle Jones starting in 1989. It was a leader in mail-reading functionality by introducing features like thread management, virtual folders, automatic archiving of messages and a full treatment of @acronym{MIME}. VM can interface to other packages available in Emacs, for remote file access, @acronym{BBDB} address book, @acronym{GPG} encryption and Org mode task management etc. It can also invoke external utilities available on your system such as mail filtering tools and html rendering tools. @cindex @acronym{POP} @cindex @acronym{IMAP} @cindex mail servers @cindex mbox @cindex Thunderbird VM can read and store mail on your file system (both local and remote). It can also handle mail stored in remote file servers running @acronym{POP} and @acronym{IMAP} protocols. The local folders are stored in a Unix-standard @code{mbox} format, which is also used by most other mail readers including Thunderbird. In fact, VM can seamlessly operate on Thunderbird folders and, if you use a remote mail server, you can view the same folders in VM and Thunderbird concurrently. In addition, VM can also store mail in the @code{Babyl} format used by Emacs Rmail. So, it is also possible to inter-operate with Rmail if you have archived mail in that format. @cindex maildir @cindex newsgroups @cindex @acronym{RSS} feeds @cindex @acronym{S/MIME} There are also a few things that VM cannot (yet) do. It does not have the ability to deal with maildir folders. It cannot be used to read newsgroups and @acronym{RSS} feeds. It does not have its own mail filtering tools. It does not have support for the Secure @acronym{MIME} (@acronym{S/MIME}) protocol. However, active development of VM is continuing. It may acquire some of these features before long. VM has been found most useful by professional users who must deal with large quantities of email in the course of their work, and deal with it efficiently and reliably. We enjoy using VM and find that it is better than any other mail tool in its flexibility and efficiency. We hope you will too! -- VM Development Team @node Introduction, Starting Up, Preface, Top @unnumbered Overview VM (View Mail) is an Emacs subsystem that allows UNIX mail to be read and disposed of within Emacs. Commands exist to do the normal things expected of a mail user agent, such as generating replies, saving messages to folders, deleting messages and so on. There are other more advanced commands that do tasks like bursting and creating digests, message forwarding, and organizing message presentation according to various criteria. You can make VM your default mail user agent by setting @code{mail-user-agent} to @code{vm-user-agent}, e.g. by @kbd{M-x} @code{customize-variable} @key{RET} @code{mail-user-agent} @key{RET}. To invoke VM, type @kbd{M-x vm}. VM gathers any mail that has arrived in your system mailbox and appends it to a mail folder known as your @dfn{primary inbox}, and visits that folder for reading. @xref{Starting Up}. Depending on how you have configured VM, the primary inbox might be a file on your file system (in a format understood by VM) or it could be a folder on a remote mail server. If you type @kbd{?} in a VM folder buffer you will get some help, i.e. @code{vm-help} is called. @findex vm-scroll-forward @findex vm-scroll-backward @kindex SPC @kindex DEL If there are any messages in the primary inbox, VM selects the first new or unread message, and previews it. @dfn{Previewing} is VM's way of showing you part of a message and allowing you to decide whether you want to read it. @xref{Previewing}. By default VM shows you the message's sender, recipient, subject and date headers. Typing @key{SPC} (@code{vm-scroll-forward}) exposes the body of the message and flags the message as read. Subsequent @key{SPC}'s scroll forward through the message, @key{DEL} scrolls backward. When you reach the end of a message, typing @key{SPC} or @kbd{n} moves you forward to preview the next message. @xref{Paging}. If you do not want to read a message that's being previewed, type @kbd{n} and VM will move to the next message (if there is one). @xref{Selecting Messages}. To save a message to a mail folder use @kbd{s} (@code{vm-save-message}). VM will prompt you for the folder name in the minibuffer. @xref{Saving Messages}. Messages are deleted by typing @kbd{d} (@code{vm-delete-message}) while previewing or reading them. The message is not removed right away; VM makes a note that you want the message to be removed later. If you change your mind about deleting a message, select it and type @kbd{u} (@code{vm-undelete-message}), and the message will be undeleted. @xref{Deleting Messages}. The actual removal of deleted messages from the current folder is called @dfn{expunging} and it is accomplished by typing @kbd{###} (@code{vm-expunge-folder}). The message is still present in the on-disk version of the folder until the folder is saved. Typing @kbd{h} (@code{vm-summarize}) causes VM to display a window containing a summary of the contents of the current folder. The summary is presented one line per message, by message number, listing each message's author, date sent, line and byte count, and subject. Also, various letters appear beside the message number to indicate that a message is new, unread, flagged for deletion, etc. An arrow @samp{->} appears to the left of the line summarizing the current message. The summary format is user configurable, @pxref{Summaries}. @findex vm-save-folder @kindex S When you are finished reading mail the current folder must be saved, so that the next time the folder is visited VM will know which messages have been already read, replied to and so on. Typing @kbd{S} (@code{vm-save-folder}) saves the folder. The default behavior is that deleted messages are @emph{not} expunged automatically when you save a folder. The next time you visit the folder any deleted messages will still be flagged for deletion. @pxref{Deleting Messages}. @vindex vm-folder-file-precious-flag When a folder is first visited, the value of the variable @code{vm-folder-file-precious-flag} is used to initialize a buffer-local instance of @code{file-precious-flag}, which determines how folders are saved. A non-nil value causes folders to be saved by writing to a temporary file and then replacing the folder with that file. A nil value causes folders to be saved by writing directly to the folder without the use of a temporary file. @vindex vm-delete-empty-folders If the folder is empty at the time you save it and the variable @code{vm-delete-empty-folders} is non-@code{nil}, VM will remove the zero length folder after saving it. @findex vm-quit @findex vm-quit-no-change @kindex q @kindex x To quit visiting a folder you can type @kbd{q} (@code{vm-quit}) or @kbd{x} (@code{vm-quit-no-change}). Typing @kbd{q} saves the current folder before quitting. Also, any messages flagged new are changed to be flagged as old and unread, before saving. The @kbd{x} command quits a folder without changing the status of new messages, saving or otherwise modifying the current folder. @vindex vm-confirm-quit If the variable @code{vm-confirm-quit} is set to @code{t} VM will always ask for confirmation before ending a VM visit of a folder. A @code{nil} value means VM will ask only when messages will be lost unwittingly by quitting, i.e. not removed by intentional delete and expunge. A value that is neither @code{nil} nor @code{t} causes VM to ask only when there are unsaved changes to message attributes or when messages will be lost. @findex vm-quit-just-bury @findex vm-switch-to-folder You do not have to quit a folder to continue using Emacs for other purposes. @code{M-x vm-quit-just-bury} buries the buffers associated with the current folder deep in Emacs' stack of buffers, but otherwise leaves the folder visited so that you can resume reading messages quickly. You can return to the folder using @code{M-x vm-switch-to-folder}. Or, you can locate the folder's buffers again by using @code{list-buffers}, which is normally bound to @kbd{C-x C-b}. @findex vm-quit-just-iconify Another command you can use if you are using a window system like X Windows is @code{vm-quit-just-iconify}. This command buries the folder's buffers like @code{vm-quit-just-bury} and also iconifies the current frame. @findex vm-get-new-mail @kindex g At any time while reading mail in any folder you can type @kbd{g} (@code{vm-get-new-mail}) to check to see if new mail for that folder has arrived. If new mail has arrived it will be moved from the spool files or maildrops associated with the current folder and merged into the folder. If you are not in the middle of another message, VM will also move to the first new or unread message. If @code{vm-get-new-mail} is given a prefix argument, it will prompt for another file from which to gather messages instead of the usual spool files. In this case the source folder is copied but no messages are deleted from it as they would be for a spool file. By default your primary inbox has your system mailbox associated with it, e.g. @file{/var/spool/mail/kyle}, and so typing @kbd{g} will retrieve mail from this file. Your system mailbox is one example of a @dfn{spool file}, a file that the mail transport system delivers messages into. You can associate other spool files with your primary inbox and spool files with other folders by setting the variable @code{vm-spool-files}. @xref{Spool Files}. @node Starting Up, Selecting Messages, Introduction, Top @chapter Starting Up @findex vm-load-init-file @vindex vm-init-file @cindex .vm The first time VM is started in an Emacs session, it attempts to load the file specified by the variable @code{vm-init-file}, normally @file{~/.vm}. If present this file should contain Lisp code, much like the @file{.emacs} file. It should contain the ``configuration settings'' for VM, i.e., variables that define where the mail folders are stored, where the incoming mail is to be found, the various directories that VM needs to use for its operation and the external applications that VM can invoke. You can reload this file by typing @code{M-x vm-load-init-file} from within VM. @vindex vm-preferences-file @cindex .vm.preferences In addition, VM also attempts to load a file specified by the variable @code{vm-preferences-file}, normally @file{~/.vm.preferences}. This file should contain your preferential settings for various VM variables affecting how VM works. Since VM has well over one hundred configuration variables, use of the @file{~/.vm.preferences} can considerably reduce clutter in the @file{.vm} file. Invoking @code{vm-load-init-file} with a prefix argument (e.g., @kbd{C-u}) causes the @code{vm-init-file} to be loaded without the @code{vm-preferences-file}. VM will work with all its default settings for the variables. This is similar to invoking emacs via @code{emacs -Q}. If you ever find a problem with VM's behavior, it is a good idea to run it without the @code{vm-preferences-file} in order to check if the problem might have been caused by the preferences settings. @findex vm @vindex vm-primary-inbox @vindex vm-auto-get-new-mail @cindex primary inbox @kbd{M-x vm} causes VM to visit a folder known as your @dfn{primary inbox}, specified by the variable @code{vm-primary-inbox}. If the variable @code{vm-auto-get-new-mail} is set non-@code{nil}, VM will gather any new mail that has arrived and integrate it into your primary inbox. The default setting for your primary inbox is the local file @file{~/Mail/inbox}, but a variety of other options are available. VM can work with mail folders saved on the local file system. @xref{Local Folders}. It can also work with mail folders stored on remote mail servers, such as @acronym{POP} and @acronym{IMAP} servers. @xref{@acronym{POP} and @acronym{IMAP} Folders}. Server folders have the advantage that they can be accessed from multiple locations on the internet. VM might appear to have a bias towards local folders due to its history of development. But it treats server folders with equal facility. @findex vm-visit-folder @findex vm-visit-pop-folder @findex vm-visit-imap-folder @kindex v @kbd{M-x vm-visit-folder} (@kbd{v} from within VM) allows you to visit any local mail folder. The folder name will be prompted for in the minibuffer. @kbd{M-x vm-visit-pop-folder} and @kbd{M-x vm-visit-imap-folder} perform similar function for server folders. Once VM has read the folder and assimilated any new mail, the first new or unread message will be selected, if any. If there is no such message, VM will select whatever the selected message was when this folder was last saved. If this folder has never been visited and saved by VM, then the first message in the folder is selected. @findex vm-mode @kbd{M-x vm-mode} can be used on a buffer already loaded into Emacs to put it into the VM major mode so that VM commands can be executed on it. This command is suitable for use in Lisp programs, and for inclusion in @code{auto-mode-alist} to automatically start VM on a file based on a particular filename suffix. @code{vm-mode} skips some of VM's start-up procedures (e.g. starting up a summary) to make non-interactive use easier. @vindex vm-startup-with-summary The variable @code{vm-startup-with-summary} controls whether VM automatically displays a summary of the folder's contents at startup. A value of @code{nil} gives no summary; a value of @code{t} always gives a summary. A value that is a positive integer @var{n} means that VM should generate a summary if there are @var{n} or more messages in the folder. A negative value @var{-n} means generate a summary only if there are @var{n} or fewer messages. The default value of @code{vm-startup-with-summary} is @code{t}. @menu * Local Folders:: Working with folders on the local file system * @acronym{POP} and @acronym{IMAP} Folders:: Working with folders on mail servers * Thunderbird Folders:: Working with folders managed by Thunderbird * External Messages:: Working with messages stored externally. * Getting New Mail:: Retrieving mail from spool files. * Crash Recovery:: Recovering changes after Emacs or your system dies. @end menu @node Local Folders, @acronym{POP} and @acronym{IMAP} Folders, Starting Up, Starting Up @section Local Folders @cindex mbox @cindex Babyl @cindex Rmail @vindex vm-default-folder-type A local mail folder is simply a file that can be stored on the local file system. VM works with the Unix @dfn{mbox} format to store messages in folders. It can also work with the @dfn{Babyl} format used by the Emacs Rmail package. The subtypes of mboxes handled by VM are listed under @b{Folder types} below. @vindex vm-folder-directory It is a good idea to create directory, e.g., @code{~/Mail}, where all of VM's local folders will be kept. If you create such a directory, you should set the variable @code{vm-folder-directory} to point to it. @cindex spool file @vindex vm-spool-files @cindex file locking A @dfn{spool file} is a file where the mail transport system delivers messages intended for you. On Unix systems, a program called @file{/bin/mail} or @file{/bin/mail.local} does this delivery. It is also possible for agents such as @file{procmail}, @file{filter} and @file{slocal} to be invoked from a user's @file{~/.forward} or @file{~/.qmail} files, sorting the incoming mail into separate spool files. On other systems, incoming mail may be delivered to mailboxes on remote mail servers, from where it can be retrieved through protocols like @acronym{POP} and @acronym{IMAP}. No matter what the delivery agent, what all spool files have in common is that mail is delivered into them by one or more entities apart from VM and that all access to spool files must therefore be accompanied by the use of some file locking protocol. @vindex vm-movemail-program @vindex vm-movemail-program-switches When spool files are on the local file system, VM uses the program @file{movemail}, a program distributed with Emacs to extract mail from a spool file. The variable @code{vm-movemail-program} specifies the name of the movemail program and defaults to @samp{"movemail"}. The variable @code{vm-movemail-program-switches} lets you specify some initial command line argument to pass to the movemail program. @cindex crash box @vindex vm-crash-box VM transfers the mail from a spool file to a folder via a temporary file known as the @dfn{crash box}. The variable @code{vm-crash-box} names the crash box file for the primary inbox. Or a crash-box name may be created from @code{vm-crash-box-suffix} described below. (@pxref{Spool Files}.) VM first copies the mail to the crash box, truncates the spool file to zero messages, merges the crash box contents into the primary inbox, and then deletes the crash box. If the system or Emacs should crash in the midst of this activity, any message not present in the primary inbox will be either in the spool file or the crash box. Some messages may be duplicated but no mail will be lost. If the file named by @code{vm-crash-box} already exists when VM is started up, VM will merge that file with the primary inbox before retrieving any new messages from the system mailbox. @menu * Spool Files:: Specifying where mail comes from * @acronym{POP} Spool Files:: How to use a @acronym{POP} mailbox as a spool file * @acronym{IMAP} Spool Files:: How to use an @acronym{IMAP} mailbox as a spool file * Index Files:: Using an index to speed up VM starting * Folder types:: About the mail folder formats handled by VM @end menu @node Spool Files, @acronym{POP} Spool Files, Local Folders, Local Folders @unnumberedsubsec Spool Files Every folder, including the primary inbox, can have one or more spool files associated with it. You make these associations known to VM by setting the variable @code{vm-spool-files}. If you only want to associate spool files with your primary inbox, you can set @code{vm-spool-files} to a list of strings. By default, the location of your system mailbox (the spool file that is associated with your primary inbox) is determined heuristically based on what type of system you're using. VM can be told explicitly where the system mailbox is by setting @code{vm-spool-files} like this: @example (setq vm-spool-files '("/var/spool/mail/kyle" "~/Mailbox")) @end example @noindent With this setting, VM will retrieve mail for the primary inbox from first @file{/var/spool/mail/kyle} and then @file{~/Mailbox}. If the value of @code{vm-spool-files} is @code{nil}, a default value for @code{vm-spool-files} will be inherited from the shell environmental variables MAILPATH or MAIL if either of these variables are defined. This inheritance happens before your init file is loaded, so setting @code{vm-spool-files} in your init file will override any environmental variables. If you want to associate spool files with folders other than or in addition to the primary inbox, the value of @code{vm-spool-files} must be a list of lists. Each sublist specifies three entities, a folder, a spool file and a crash box. When retrieving mail for a particular folder, VM will scan @code{vm-spool-files} for folder names that match the current folder's name. The spool file and crash box found in any matching entries will be used to gather mail for that folder. For example, you can set @code{vm-spool-files} like this @example @group (setq vm-spool-files '( ("~/INBOX" "/var/spool/mail/kyle" "~/INBOX.CRASH") ("~/INBOX" "~/Mailbox" "~/INBOX.CRASH") ("~/Mail/bugs" "/var/spool/mail/answerman" "~/Mail/bugs.crash") ) ) @end group @end example @noindent The folder @file{~/INBOX} has two spool files associated with it in this example, @file{/var/spool/mail/kyle} and @file{~/Mailbox}. Another folder, @file{"~/Mail/bugs"} has one spool file @file{/var/spool/mail/answerman} associated with it. Note that both of the @file{~/INBOX} entries used the same crash box. The crash box can be the same if the folder name is the same. Different folders should use different crashboxes. @vindex vm-crash-box-suffix @vindex vm-spool-file-suffixes An alternate way of specifying folder/spool file associations is to use the variables @code{vm-spool-file-suffixes} and @code{vm-crash-box-suffix}. The value of @code{vm-spool-file-suffixes} should be a list of string suffixes to be used to create possible spool file names for folders. Example: @example @group (setq vm-spool-file-suffixes '(".spool" "-")) @end group @end example @noindent With @code{vm-spool-file-suffixes} set this way, if you visit a folder @file{~/mail/beekeeping}, when VM attempts to retrieve new mail for that folder it will look for mail in @file{~/mail/beekeeping.spool} and @file{~/mail/beekeeping-} in addition to scanning @code{vm-spool-files} for matches. The value of @code{vm-spool-files-suffixes} will not be used unless @code{vm-crash-box-suffix} is also defined, since a crash box is required for all mail retrieval from spool files. The value of @code{vm-crash-box-suffix} should be a string suffix used to create possible crash box file names for folders. When VM uses @code{vm-spool-file-suffixes} to create a spool file name, it will append the value of @code{vm-crash-box-suffix} to the folder's file name to create a crash box name. If the value of @code{vm-spool-files-suffixes} is @code{nil}, then the value of @code{vm-crash-box-suffix} is not used by VM. @vindex vm-make-crash-box-name @vindex vm-make-spool-file-name The idea behind @code{vm-spool-file-suffixes} and @code{vm-crash-box-suffix} is to give you a way to have many folders with individual spool files associated with them, without having to list them all in @code{vm-spool-files}. If you need even more control of spool file and crash box names, use @code{vm-make-spool-file-name} and @code{vm-make-crash-box-name}. The value of both of these should be a function or the name of a function. When VM visits a folder, it will call the function with the name of the folder as an argument, and the function should return the spool file name or crash box name to be used for that folder. If your spool file is on another host, VM supports accessing spool files on remote hosts using the @acronym{POP} and @acronym{IMAP} protocols. @node @acronym{POP} Spool Files,@acronym{IMAP} Spool Files,Spool Files,Local Folders @unnumberedsubsec @acronym{POP} Spool Files @cindex @acronym{POP} spool files VM can access spool files on mail servers via the @dfn{Post Office Protocol} (@dfn{@acronym{POP}}). To use a @acronym{POP} mailbox as a spool file, you need to use a @acronym{POP} maildrop specification (@ref{maildrop specification}, @ref{@acronym{POP} and @acronym{IMAP} Folders}). Once this is done, VM will retrieve new mail from the @acronym{POP} mailbox in the same way as it retrieves it from system mailbox. The retrieved messages can be automatically removed from the @acronym{POP} mailbox or retained until a later expunge operation. @vindex vm-pop-max-message-size @findex vm-get-new-mail @vindex vm-auto-get-new-mail By default VM will retrieve all the messages from a @acronym{POP} mailbox before returning control of Emacs to you. If the mailbox is large, the wait could be considerable. If you set @code{vm-pop-max-message-size} to a positive numeric value, VM will not automatically retrieve messages larger than this size. If VM is retrieving messages because you invoked @code{vm-get-new-mail} interactively, then VM will ask whether it should retrieve the large message. If VM is retrieving messages automatically (e.g. @code{vm-auto-get-new-mail} is set non-@code{nil}) then VM will skip the large message and you can retrieve it later. @vindex vm-pop-bytes-per-session @vindex vm-pop-messages-per-session The variable @code{vm-pop-messages-per-session} controls how many messages VM will retrieve from a @acronym{POP} mailbox before returning control to you. Similarly, the variable @code{vm-pop-bytes-per-session} limits the number of bytes VM will retrieve from a @acronym{POP} mailbox before returning control to you. By default, the value of both variables is nil, which tells VM to retrieve all the messages in the @acronym{POP} mailbox regardless of how many messages there are and how large the mailbox is. @findex vm-expunge-pop-messages After VM retrieves messages from the mailbox, the default action is to leave the original messages on the server unchanged. They can be expunged from the server by running @code{vm-expunge-pop-messages}; only those messages that VM has retrieved into the current folder will be expunged. @vindex vm-pop-expunge-after-retrieving @vindex vm-pop-auto-expunge-alist If you want VM to expunge the messages automatically after retrieving them, you can set @code{vm-pop-expunge-after-retrieving} to @code{t}. But a better method is to set the variable @code{vm-pop-auto-expunge-alist}, which gives you a way to specify, on a per-mailbox basis, which @acronym{POP} mailboxes should have messages automatically removed after retrieving and which ones should leave the messages on the @acronym{POP} server. The value of @code{vm-pop-auto-expunge-alist} should be a list of @acronym{POP} mailboxes and values specifying whether messages should be automatically deleted from the mailbox after retrieval. The format of the list is: @example ((@var{MAILDROP} . @var{VAL}) (@var{MAILDROP} . @var{VAL}) ...) @end example @var{MAILDROP} should be a @acronym{POP} mailbox specification as described in the documentation for the variable @code{vm-spool-files}. If you have the @acronym{POP} password specified in the @code{vm-spool-files} entry, you do not have to specify it here as well. Use @samp{*} instead; VM will still understand that this mailbox is the same as the one in @code{vm-spool-files} that contains the password. @var{VAL} should be @code{nil} if retrieved messages should be left in the corresponding @acronym{POP} mailbox, @code{t} if retrieved messages should be removed from the mailbox immediately after retrieval. Here is an example: @example (setq vm-pop-auto-expunge-alist '( ("odin.croc.net:110:pass:kyle:*" . nil) ;; leave message on the server ("hilo.harkie.org:110:pass:kyle:*" . t) ;; expunge immediately ) ) @end example @node @acronym{IMAP} Spool Files, Index Files, @acronym{POP} Spool Files, Local Folders @unnumberedsubsec @acronym{IMAP} Spool Files @cindex @acronym{IMAP} spool files @cindex maildrop specification VM can also use @dfn{@acronym{IMAP}} (@dfn{Internet Message Access Protocol}) to retrieve mail from a mail server. As with @acronym{POP}, instead of specifying a local file name in the @code{vm-spool-files} definition, you would give an @acronym{IMAP} maildrop specification (@ref{maildrop specification}, @ref{@acronym{POP} and @acronym{IMAP} Folders}). Once this is done, VM will retrieve new mail from the @acronym{IMAP} mailbox in the same way as it retrieves it from system mailbox. The retrieved messages can be automatically removed from the @acronym{IMAP} mailbox or retained until a later expunge operation. @vindex vm-imap-bytes-per-session @vindex vm-imap-messages-per-session The variable @code{vm-imap-messages-per-session} controls how many messages VM will retrieve from an @acronym{IMAP} mailbox before returning control to you. Similarly, the variable @code{vm-imap-bytes-per-session} limits the number of bytes VM will retrieve from an @acronym{IMAP} mailbox before returning control to you. By default, the value of both variables is nil, which tells VM to retrieve all the messages in the @acronym{IMAP} mailbox regardless of how many messages there are and how large the mailbox is. @cindex expunging, @acronym{IMAP} messages @findex vm-expunge-imap-messages After VM retrieves messages from the mailbox, the default action is to leave the original messages on the server unchanged. They can be @dfn{expunged} from the server by running @code{vm-expunge-imap-messages}; only those messages that VM has retrieved into the current folder will be expunged. @vindex vm-imap-expunge-after-retrieving @vindex vm-imap-auto-expunge-alist If you want VM to expunge the messages automatically after retrieving them, you can set @code{vm-imap-expunge-after-retrieving} to @code{t}. But a better method is to set the variable @code{vm-imap-auto-expunge-alist}, which gives you a way to specify, on a per-mailbox basis, which @acronym{IMAP} mailboxes should have messages automatically removed after retrieving and which ones should leave the messages on the @acronym{IMAP} server. The value of @code{vm-imap-auto-expunge-alist} should be a list of @acronym{IMAP} mailboxes and values specifying whether messages should be automatically deleted from the mailbox after retrieval. The format of the list is: @example ((@var{MAILDROP} . @var{VAL}) (@var{MAILDROP} . @var{VAL}) ...) @end example @var{MAILDROP} should be an @acronym{IMAP} maildrop specification as described in the documentation for the variable @code{vm-spool-files}. If you have the @acronym{IMAP} password specified in the @code{vm-spool-files} entry, you do not have to specify it here as well. Use @samp{*} instead; VM will still understand that this mailbox is the same as the one in @code{vm-spool-files} that contains the password. @var{VAL} should be @code{nil} if retrieved messages should be left in the corresponding @acronym{IMAP} mailbox, @code{t} if retrieved messages should be removed from the mailbox immediately after retrieval. Here is an example: @example (setq vm-imap-auto-expunge-alist '( ;; leave message on the server ("imap:odin.croc.net:143:inbox:login:kyle:*" . nil) ;; expunge immediately ("imap:hilo.harkie.org:143:inbox:login:kyle:*" . t) ) ) @end example @unnumberedsubsubsec Multiple access to @acronym{IMAP} spool files A principal idea behind the @acronym{IMAP} protocol is that messages can be retained on the server so that you can read them from multiple locations, e.g., from office and home, or from other places on the Internet while you travel. If you access your @acronym{IMAP} mailbox from multiple locations then you would need to plan your strategy for expunging messages carefully. For instance, if you access your work mailbox from home, and both your office machine and home machine expunge messages after retrieving them, then some of your mail will end up on your office machine and some on your home machine. That is unlikely to be a successful strategy. The best way to access @acronym{IMAP} mailboxes from multiple locations is to use the facility of @acronym{IMAP} folders. (@xref{@acronym{POP} and @acronym{IMAP} Folders}.) However, if you prefer to download all mail to local folders, then your best bet is to designate one of your machines as the principal location for downloading mail and treat the other machines as temporary mail reading sites. In that case, you should set the principal downloading location to expunge messages on the server and set the other reading sites to leave the messages on the server intact. You can also manually run @code{vm-expunge-imap-messages} if you are careful to remember which site should expunge messages and which site should retain them. @cindex X-VM-@acronym{IMAP}-Retrieved header VM remembers the messages you have downloaded from an @acronym{IMAP} spool file so that it can avoid downloading them again on your next visit. The list of these messages is written into a special mail header titled @code{X-VM-@acronym{IMAP}-Retrieved} in your mail folder. When you expunge @acronym{IMAP} messages, their entries are deleted from the list. However, when you designate one of your machines as a reading site and never expunge messages from there, then the @code{X-VM-IMAP-Retrieved} header on that machine will only grow over time. When the list gets excessively long, it will slow down the saving of folders. @findex vm-prune-imap-retrieved-list To avoid the problem, you should prediodically run the command @code{vm-prune-imap-retrieved-list}. It will examine the @acronym{IMAP} server to see which messages still exist and retain only their information in the @code{X-VM-IMAP-Retrieved} header. @node Index Files, Folder types,@acronym{IMAP} Spool Files, Local Folders @unnumberedsubsec Index Files @cindex index file VM can create an @dfn{index} file, which describes the messages contained in a folder. If such an index file exists and is up to date, then VM will read the contents of the index file first while starting up in order to quickly form the summary of the folder. @vindex vm-index-file-suffix To use this feature, set the variable @code{vm-index-file-suffix} to a file name extension, e.g., @example (setq vm-index-file-suffix "idx") @end example @node Folder types,,Index Files, Local Folders @unnumberedsubsec Folder types @cindex folder types @vindex vm-default-folder-type VM can handle a variety of formats for mail folders, which differ in details. The variable @code{vm-default-folder-type} can be used to set the default format that is suitable for your environment. This setting is used when VM creates new folders. When VM reads a folder from the file system, it examines contents of the folder to determine what format it is stored in and decodes it appropriately. (However, such inference is not fully automatic. See below.) @findex vm-change-folder-type After a folder is loaded into VM, you can convert it to a different format using the command @code{vm-change-folder-type}. It is a good idea to keep all your mail folders in a single format in order to avoid incompatibilities. The system default format is referred to as @code{From_}. It is the Unix mbox format described RFC 4155. In this format, a leading separator line and a trailing separator line are added to each message. The leading separator line starts with the string ``From ''. The trailing separator line is a blank line. VM actually adds two blank lines at the end for clarity. A variant of this format is referred to as @code{BellFrom_}. It has a leading separator line that starts with the string ``From ''. However, it does not have a trailing blank line. Since VM cannot reliably infer whether a mail folder is of type @code{From_} or @code{BellFrom_}, you must tell VM which one your system uses by setting the variable @code{vm-default-From_-folder-type}. Some of the old folders created by VM prior to 2000 were in the @code{BellFrom_} format. If you will be using both @code{From_} and @code{BellFrom_} style folders, it is not possible to choose an appropriate setting for this variable. It is recommended that you convert all the old @code{BellFrom_} folders to the @code{From_} format using the command @code{vm-change-folder-type}. Solaris, System V and AIX operating systems use another variant of the mbox format where the content-length is specified in the ``From '' line. VM refers to this format as @code{From_-with-Content-Length}. Since the content lengths may be unreliable, you must also set the variable @code{vm-trust-From_-with-Content-Length} to a non-Nil value in order to convince VM that you really want to use this format. Two additional formats are @code{mmdf} used by @acronym{MMDF} systems and @code{babyl} used by the Emacs Rmail mode. These formats are recognized automatically when read from the file system. @node @acronym{POP} and @acronym{IMAP} Folders, Thunderbird Folders, Local Folders, Starting Up @section @acronym{POP} and @acronym{IMAP} Folders @cindex primary inbox @cindex maildrop specification @vindex vm-primary-inbox VM supports accessing remote mailboxes on mail servers via the Post Office Protocol (@acronym{POP}) and the Internet Message Access Protocol (@acronym{IMAP}). Instead of a local file name, you can set the @code{vm-primary-inbox} to a string that tells VM how to access a server mailbox. Called a @dfn{maildrop specification}, the string is of one of the following formats: @example ``pop:@var{HOST}:@var{PORT}:@var{AUTH}:@var{USER}:@var{PASSWORD}'' ``imap:@var{HOST}:@var{PORT}:@var{MAILBOX}:@var{AUTH}:@var{USER}:@var{PASSWORD}''@end example @noindent Remote mailboxes accessed by VM in this fashion are referred to as @dfn{server folders} (and @dfn{@acronym{POP} folders} or @dfn{@acronym{IMAP} folders}, more specifically). @cindex cache folders VM retrieves mail from the server folders into internal Emacs buffers for its normal operation. It also saves copies of the folders on the local file system for speed of operation. These are referred to as @dfn{cache folders}. However, the @emph{only} permanent copies of the folders are on the mail server. This should be contrasted with using server mailboxes as spool files (@pxref{@acronym{POP} Spool Files} and @pxref{@acronym{IMAP} Spool Files}), where the permanent folders are on the @emph{local} file system and only the incoming mail is held on the servers. Server folders have the advantage that they can be transparently accessed from multiple locations on the internet. However, you must ensure that you have access to enough storage on the mail server to store all your email. @anchor{maildrop specification} @unnumberedsubsec Maildrop specification The format of a @acronym{POP} or @acronym{IMAP} maildrop specification is as follows: @example ``pop:@var{HOST}:@var{PORT}:@var{AUTH}:@var{USER}:@var{PASSWORD}'' ``imap:@var{HOST}:@var{PORT}:@var{MAILBOX}:@var{AUTH}:@var{USER}:@var{PASSWORD}'' @end example @noindent Replace @samp{pop} in the example with @samp{pop-ssl} to have VM speak @acronym{POP} over an @acronym{SSL} connection. Use @samp{pop-ssh} to use @acronym{POP} over an SSH connection. Similarly, replace @samp{imap} with @samp{imap-ssl} or @samp{imap-ssh}, as needed. @cindex @acronym{SSL} @cindex @acronym{TLS} @dfn{@acronym{SSL}} refers to a protocol called @dfn{secure sockets layer}, which allows you to securely communicate with a mail server using encryption technology. A newer version of the same protocol is called @dfn{@acronym{TLS}} (@dfn{transport layer security}). We refer to both of them as ``@acronym{SSL}'' in this manual. @cindex stunnel @vindex vm-stunnel-program For @acronym{SSL}, you must either be using a version of Emacs that has @acronym{SSL} capability or have the @command{stunnel} program installed and the variable @code{vm-stunnel-program} naming it. The default value of this variable, @samp{"stunnel"}, should be sufficient if the program is installed in your normal command search path. In order to use the built-in @acronym{SSL} capability of your Emacs version, set @code{vm-stunnel-program} to @code{nil}. @cindex SSH @vindex vm-ssh-program @vindex vm-ssh-remote-command For SSH, you must have the @command{ssh} program installed and the variable @code{vm-ssh-program} must name it in order for @acronym{POP}/@acronym{IMAP} over SSH to work. When VM makes the SSH connection it must run a command on the remote server so that the SSH session is maintained long enough for the @acronym{POP}/@acronym{IMAP} connection to be established. By default that command is @samp{"echo ready; sleep 10"}, but you can specify another command by setting @code{vm-ssh-remote-command}. Whatever command you use must produce some output and hold the connection open long enough for VM to establish a port-forwarded connection to the mail server. (SSH must be able to authenticate without a password, which means you must be using .shosts authentication or RSA.) @var{HOST} is the host name of the mail server. @cindex port, TCP @var{PORT} is the TCP port number to connect to. The normal port numbers are: @multitable @columnfractions 0.20 0.80 @item 110 @tab for @acronym{POP} @item 995 @tab for @acronym{POP} over @acronym{SSL} @item 143 @tab for @acronym{IMAP} @item 993 @tab for @acronym{IMAP} over @acronym{SSL} @end multitable @var{MAILBOX} is the name of the mailbox on the @acronym{IMAP} server. This should be @samp{"inbox"}, to access your default @acronym{IMAP} mailbox on the server. No @var{MAILBOX} component is needed for @acronym{POP} maildrops because @acronym{POP} does not support multiple mailboxes. @vindex vm-pop-md5-program @var{AUTH} is the authentication method used to convince the server you should have access to the mailbox. Acceptable values for @acronym{POP} are @samp{pass}, @samp{rpop} and @samp{apop}. For @samp{pass}, the @var{PASSWORD} is sent to the server with the @acronym{POP} PASS command. For @samp{rpop}, the @var{PASSWORD} should be the string to be sent to the server via the @acronym{RPOP} command. In this case the string is not really a secret; authentication is done by other means. For @samp{apop}, an MD5 digest of the @var{PASSWORD} appended to the server time-stamp will be sent to the server with the @acronym{APOP} command. If Emacs does not have built in MD5 support, you will have to set the value of @code{vm-pop-md5-program} appropriately to point at the program that will generate the MD5 digest that VM needs. @cindex CRAM-MD5 @vindex vm-imap-session-preauth-hook Acceptable values of @var{AUTH} for @acronym{IMAP} are @samp{"preauth"}, @samp{"cram-md5"}, and @samp{"login"}. @samp{"preauth"} causes VM to skip the authentication stage of the protocol with the assumption that the session was authenticated in some way external to VM. The hook @code{vm-imap-session-preauth-hook} is run, and it is expected to return a process connected to an authenticated @acronym{IMAP} session. @samp{"cram-md5} tells VM to use the CRAM-MD5 authentication method as specified in RFC 2195. The advantage of this method over the @samp{"login"} method is that it avoids sending your password over the net unencrypted. Not all @acronym{IMAP} servers support @samp{"cram-md5"}; if you're not sure, ask your mail administrator or just try it. The other value, @samp{"login"}, tells VM to use the @acronym{IMAP} LOGIN command for authentication, which sends your user name and password in clear text to the server. @var{USER} is the user name used in authentication methods that require such an identifier. @samp{"login"} and @samp{"cram-md5"} use it currently. @var{PASSWORD} is the secret shared by you and the server for authentication purposes. How it is used depends on the value of the @var{AUTH} parameter. If the @var{PASSWORD} is @samp{*}, VM will prompt you for the password the first time you try to retrieve mail from the mailbox. If the password is valid, VM will not ask you for the password again during this Emacs session. @cindex EasyPG @cindex epa-file library @cindex auth-source library @cindex authinfo @cindex passwords, storing If your environment has the @dfn{EasyPG} utility and your version of Emacs supports it, i.e., has the @samp{epa-file} and @samp{auth-source} libraries, then you can store password information in a file such as @file{.authinfo.gpg}. The @samp{EasyPG} protocol allows you to store this information in an encrypted form so that it cannot be read by third parties. Each line in the @file{.authinfo.gpg} file should be of the form @example machine HOST login USER password PASSWORD port PORT @end example @noindent where HOST, USER, PASSWORD and PORT are as detailed above. Ensure that the variable @code{auth-sources} is customized to refer to your authinfo file. @xref{Help for users,, Help for users, auth , Emacs auth-source}. Then VM will read passwords from the file and you don't need to type them in when accessing mail servers. If you have multiple login accounts on the same HOST then VM will only use the first login listed in the authinfo file. To allow for multiple logins, the HOST entry in the authinfo line can be replaced by an account name as defined internally in VM. These account names are defined via the variables @code{vm-pop-folder-alist} and @code{vm-imap-account-alist}, described below. @anchor{troubleshooting mail servers} @unnumberedsubsec Troubleshooting mail servers Since a number of components have to be brought together to establish connections to mail servers, it is not uncommon for problems to arise. @cindex stunnel To find out what could be going wrong, you can look at the Emacs buffer that store a trace of the session with mail server. Such buffers have names beginning with ``trace of @acronym{POP} session'' or ``trace of @acronym{IMAP} session''. There could be multiple buffers of this kind for different servers and multiple sessions. In the trace buffer, you will find the commands that VM sent to the server and the responses it has received. Typical problems are protocol mismatches between VM and the mail server, or malfunctions in other components such as the @code{stunnel} program. @vindex vm-pop-keep-trace-buffer @vindex vm-imap-keep-trace-buffer The variables @code{vm-pop-keep-trace-buffer} and @code{vm-imap-keep-trace-buffer} specify how many trace buffers to keep for such server sessions. The default is 1. Setting these variables to nil will have the effect that no trace buffers are kept. @menu * @acronym{POP} Folders:: How to use mailboxes on @acronym{POP} servers * @acronym{IMAP} Folders:: How to use mail folders on @acronym{IMAP} servers @end menu @node @acronym{POP} Folders, @acronym{IMAP} Folders, @acronym{POP} and @acronym{IMAP} Folders, @acronym{POP} and @acronym{IMAP} Folders @unnumberedsubsec @acronym{POP} Folders @cindex @acronym{POP} @cindex message attributes @findex vm-visit-pop-folder @findex vm-save-folder @vindex vm-folder-directory @vindex vm-pop-folder-cache-directory The command @code{vm-visit-pop-folder} allows you to visit a @acronym{POP} mailbox as a folder. When you visit a @acronym{POP} folder, VM will download copies of the messages that it finds there for you to read. These messages are saved locally in cache folders, in the directory specified by @code{vm-pop-folder-cache-directory} (or @code{vm-folder-directory} if the former is not defined). @vindex vm-pop-folder-cache-directory If you delete and expunge messages in the folder, the corresponding messages on the @acronym{POP} server will be removed when you save the changes with @code{vm-save-folder}. @dfn{Message attributes} (new, replied, filed, etc.) and labels cannot be stored on the @acronym{POP} server but they will be maintained in the cache folder. This means that if you access the same @acronym{POP} mailbox from multiple locations on the internet, you will see different attributes at different locations. To be able to store message attributes and labels on the server, you should use @acronym{IMAP} folders (@ref{@acronym{IMAP} Folders}) resident on an @acronym{IMAP} server. @vindex vm-pop-folder-alist In order for VM to know about @acronym{POP} folders that you can access, you must declare them by setting the variable @code{vm-pop-folder-alist}. The variable's value should be an associative list of the form: @example ((@var{POPDROP} @var{NAME}) ...) @end example @var{POPDROP} is a @acronym{POP} maildrop specification (@ref{maildrop specification}). @var{NAME} is a string that should give a less cumbersome name that you will use to refer to this maildrop when using @code{vm-visit-pop-folder}. For example: @example (setq vm-pop-folder-alist '( ("pop:pop.mail.yahoo.com:110:pass:someuser:*" "Yahoo! mail") ("pop:localhost:110:pass:someuser:*" "local mail") ) ) @end example @samp{Yahoo! mail} and @samp{local mail} are what you would type when @code{vm-visit-pop-folder} asks for a folder name. There is no need to specify the password for @acronym{POP} accounts in this definition. @node @acronym{IMAP} Folders,, @acronym{POP} Folders, @acronym{POP} and @acronym{IMAP} Folders @unnumberedsubsec @acronym{IMAP} Folders @cindex @acronym{IMAP} @cindex message attributes @cindex message labels @findex vm-visit-imap-folder The command @code{vm-visit-imap-folder} allows you to visit an @acronym{IMAP} mailbox as a folder. The name of the @acronym{IMAP} mailbox should be input via the minibuffer in the format account-name:folder-name. Here, ``account-name'' is the name of an @acronym{IMAP} account declared in @code{vm-imap-account-alist} and ``folder-name'' is the name of an @acronym{IMAP} mailbox in this account. @findex vm-save-folder @vindex vm-folder-directory @vindex vm-imap-folder-cache-directory When you visit an @acronym{IMAP} folder, VM will download copies of the messages that it finds there for you to read. These messages are saved locally in a cache folder on the disk, in the directory specified by @code{vm-imap-folder-cache-directory} (or @code{vm-folder-directory} if the former is not defined). @vindex vm-imap-folder-cache-directory If you delete and expunge messages, these changes are made to both the cache folder and the folder on the @acronym{IMAP} server when saved with @code{vm-save-folder}. Message attributes (new, replied, filed, etc.) are stored on the @acronym{IMAP} server and are also cached locally. Message labels are also stored on the @acronym{IMAP} server as user-defined permanent flags. (This assumes that the @acronym{IMAP} server has the ability to store user-defined permanent flags.) @vindex vm-imap-account-alist In order for VM to know about @acronym{IMAP} accounts that you can access, you must declare them by setting the variable @code{vm-imap-account-alist}. The variable's value should be an associative list of the form: @example ((@var{IMAPDROP} @var{NAME}) ...) @end example @var{IMAPDROP} is an @acronym{IMAP} maildrop specification (@ref{maildrop specification}). @var{NAME} is a string that should give a less cumbersome name that you will use to refer to this maildrop when using @code{vm-visit-imap-folder}. For example: @example (setq vm-imap-account-alist '( ("imap-ssl:mail.foocorp.com:993:*:login:becky:*" "becky") ("imap:crickle.lex.ky.us:143:*:login:becky:*" "crickle") ) ) @end example @noindent The mailbox and password fields (@samp{*} in the example) are ignored. When @code{vm-visit-imap-folder} asks for a folder name, you enter an account name followed by ``:'' and a folder name. Any folder that is accessible to you on the @acronym{IMAP} server can be specified. For example, @code{becky:inbox} or @code{crickle:drafts}. @vindex vm-imap-refer-to-inbox-by-account-name When you visit an @acronym{IMAP} folder inside VM, the folder is referred to by its folder name as it exists on the server. For example, visiting @code{becky:INBOX} creates a folder called @code{INBOX} inside VM. If you visit multiple @acronym{IMAP} accounts within a VM session, then you would end up with multiple folder buffers all named @code{INBOX}. To avoid this problem, you can set the variable @code{vm-imap-refer-to-inbox-by-account-name} to t, which causes the @code{INBOX} folder buffers to be named by their @acronym{IMAP} account names instead. For example, visiting @code{becky:INBOX} would create a VM folder named @code{becky} and visiting @code{crickle:INBOX} would create a VM folder named @code{crickle}. @vindex vm-imap-server-list The customization variable @code{vm-imap-server-list}, used in older versions of VM, is deprecated. Please use @code{vm-imap-account-alist} instead. @anchor{@acronym{IMAP} Synchronization} @unnumberedsubsec @acronym{IMAP} Synchronization @vindex vm-get-new-mail The cache folder and the folder on the @acronym{IMAP} server are partially synchronized every time @code{vm-get-new-mail} is invoked. This involves (i) writing the changed attributes and labels to the server, (ii) updating the attributes and labels in the cache folder based on the server data, (iii) expunging messages in the cache folder that have been expunged on the server, and finally, (iv) retrieving any new messages on the server. @vindex vm-imap-sync-on-get The variable @code{vm-imap-sync-on-get} specifies whether such synchronization should be done as part of @code{vm-get-new-mail}. If the variable is set to nil then @code{vm-get-new-mail} simply retrieves any new messages. @findex vm-save-folder The cache folder and the folder on the @acronym{IMAP} server are also synchronized every time @code{vm-save-folder} is invoked. This involves (i) writing the changed attributes and labels to the server, (ii) updating the attributes and labels in the cache folder based on the server data, (iii) expunging messages in the cache folder that have been expunged on the server, (iv) deleting and expunging the locally expunged messages on the server folder, and finally, (v) saving a copy of the folder on the file system. @findex vm-imap-synchronize The command @code{vm-imap-synchronize} can always be used to perform full synchronization with the server. @node Thunderbird Folders, External Messages, @acronym{POP} and @acronym{IMAP} Folders, Starting Up @section Thunderbird Folders @cindex Thunderbird VM can work with local folders managed by Mozilla Thunderbird. You can find the location of Thunderbird's folders by examining the Account Settings for ``Local Folders'' inside Thunderbird. Thunderbird stores the folders in the @samp{From_} folder type. @xref{Folder types}. Within such folders, Thunderbird stores the message status flags (message attributes such as whether a message is read, replied to, deleted etc.) under special header fields called @code{X-Mozilla-Status} and @code{X-Mozilla-Status2}. In addition to these headers, Thunderbird also stores a quick copy of the message status flags in a separate file with the extension @code{.msf}. When you visit a Thunderbird folder, VM reads the status flags stored in the special headers and uses them for processing. As you make changes to the folder by reading messages, replying to them or deleting them, the changes are propagated to the Thunderbird status flags and written to the disk when saved. VM also deletes the @code{.msf} file maintained by Thunderbird so that Thunderbird will recompute the status information from the headers. Thus, the changes made to the Thunderbird folders will be visible inside Thunderbird. @vindex vm-sync-thunderbird-status The variable @code{vm-sync-thunderbird-status} controls how VM deals with Thunderbird folders. The default value @code{t} gives the behavior described above. You can also set it to @code{'read-only}, in which case VM reads the Thunderbird status flags, but makes no changes to them. So, the changes made to the folders will be lost after you quit VM. If you set it to @code{nil}, then VM refrains from reading and writing the Thunderbird status flags. In this case, the changes made to the folders are visible inside VM even after revisiting, but they will have no effect for Thunderbird. WARNING: Keep in mind that all this applies to changes to message attributes only. If you @i{expunge} a folder, then the deleted messages are physically purged from the folder. They will be lost both inside VM as well as Thunderbird. The variable @code{vm-sync-thunderbird-status} is a buffer-local variable. You may set its default value in your @code{.vm} file. To change it in a running Emacs session, you must use @code{setq-default}. @xref{Locals,, Local Variables, emacs, Gnu Emacs manual}. @findex vm-visit-thunderbird-folder @vindex vm-thunderbird-folder-directory A new experimental feature allows you to visit Thunderbird's local folders using the command @code{M-x vm-visit-thunderbird-folder}. This works the same way as @code{vm-visit-folder} except for the difference that the default directory for visiting folders as well as saving messages will be taken from the variable @code{vm-thunderbird-folder-directory}. You should set this variable to the directory where Thunderbird stores its folders. The folders visited using @code{M-x vm-visit-folder} will continue to be found in @code{vm-folder-directory}, thus allowing you to manage the two spaces separately. If, on the other hand, you want to maintain a single space where VM and Thunderbird can jointly operate, then you should set the variable @code{vm-folder-directory} to point to that place and leave @code{vm-thunderbird-folder-directory} with its default value of @code{nil}. @node External Messages, Getting New Mail, Thunderbird Folders, Starting Up @section External Messages Under certain circumstances, it is possible to maintain VM folders in which only the headers of messages are loaded into the Folder buffer. The message bodies are retained in external sources (file system or remote servers) and fetched on demand when the messages are viewed or other operations are performed on them. Using external messages results in a smaller folder size and allows a faster operation on machines with limited resources. However, the fetching of message bodies on demand can introduce short delays when messages are viewed. It is also not possible to search in the message bodies of external messages. @vindex vm-enable-external-messages To enable external messages, set the variable @code{vm-enable-external-messages} to a list of contexts in which external messages may be maintained by VM. @vindex vm-imap-max-message-size As of version 8.2.0, the only context in which external messages are implemented is that of @acronym{IMAP} folders. Setting @code{vm-enable-external-messages} to @code{(imap)} enables @acronym{IMAP} messages to be maintained externally. When new messages are retrieved, this causes all messages with size below @code{vm-imap-max-message-size} to be loaded immediately, and larger messages will be left on the server to be fetched on demand. To treat all messages as external messages, you can set @code{vm-imap-max-message-size} to 0. @vindex vm-fetched-message-limit After fetching the bodies of external messages, VM stores them in the Folder buffer temporarily, so that repeated fetching is avoided. The variable @code{vm-fetched-message-limit} controls how many message bodies are stored in this way. You can set it to an integer (10 is the default), or to @code{nil}, signifying that there is no limit. All the fetched message bodies are flushed before folders are saved to disk. @findex vm-load-message @findex vm-unload-message @findex vm-refresh-message @kindex o @kindex O You can manually load message bodies into the Folder using the command @kbd{o} (@code{vm-load-message}). The command @kbd{O} (@code{vm-unload-message}) unloads a previously loaded message body. Both the commands can take numerical prefix arguments or operate on marked messages. Note that ``loading'' a message body is different from on demand ``fetching''. Loaded messages are permanently stored in the Folder buffer and written to disk when the folder is saved. In contrast, fetched message bodies are always discarded before writing to disk. The command @code{vm-refresh-message} reloads an already loaded message with a fresh copy retrieved from the server. @node Getting New Mail, Crash Recovery, External Messages, Starting Up @section Getting New Mail @findex vm-get-new-mail @kindex g Pressing @kbd{g} runs @code{vm-get-new-mail}, which will retrieve mail from all the spool files associated with the current folder. @xref{Local Folders}. For @acronym{POP} and @acronym{IMAP} folders, any newly arrived messages at the mail server will be incorporated into the local copy of the folders. @vindex vm-auto-get-new-mail If the value of the variable @code{vm-auto-get-new-mail} is non-@code{nil} VM will retrieve mail for a folder whenever the folder is visited. If the value is a positive integer @var{n}, VM will also check for new mail every @var{n} seconds for all folders currently being visited. If new mail is present, VM will retrieve it. @vindex vm-mail-check-interval @vindex vm-mail-check-always If the value of the variable @code{vm-mail-check-interval} is a positive integer @var{n}, VM will check for new mail every @var{n} seconds, but instead of retrieving mail, the word ``Mail'' will appear on the Emacs mode line of folders that have mail waiting. Normally, once VM finds new mail, it will turn on the ``Mail'' indicator and refrain from checking again until you retrieve the new mail. However, if multiple mail clients are trying to retrieve mail from the same spool, it is possible that the new mail might get retrieved into another mail client and your ``Mail'' indicator won't reflect the situation. If you need to be particular about new mail in such a situation, then you should set the variable @code{vm-mail-check-always}. @node Crash Recovery,, Getting New Mail, Starting Up @section Crash Recovery @cindex crash reovery @cindex message attributes @cindex message labels @cindex auto-save When Emacs crashes, its last action before dying is to try to write out an @dfn{auto-save} file that contains changes to files that you were editing. VM folders are file buffers inside Emacs, so folders are auto-saved also. For VM folders, @dfn{changes} means attribute changes, label additions and deletions, message edits, and expunges. VM keeps track of whether a message is new or old, whether it has been replied to, whether it is flagged for deletion and so on, by writing special headers into the folder buffer. These headers are saved to disk when you save the folder. If Emacs crashes before the folder has been saved, VM may forget some attribute changes unless they were written to the auto-save file. Note that when VM retrieves mail from spool files it @emph{always} writes them to disk immediately and at least one copy of the message is on disk at all times. So while you can lose attribute changes from crashes, you should not lose messages unless the disk itself is compromised. @unnumberedsubsec Recovering Folders When you visit a folder, VM checks for the existence of an auto-save file that has been modified more recently than the folder file. If such an auto-save file exists, there is a good chance that Emacs or your operating system crashed while VM was visiting a folder. VM will then write a message to the echo area informing you of the existence of the auto-save file and visit the folder in @emph{read-only} mode. Visiting the folder in read-only mode prevents you from modifying the folder, which in turn prevents Emacs from wanting to write new changes to the auto-save file. VM will not retrieve new mail for a folder that is in read-only mode. VM also skips summary generation and @acronym{MIME} decoding to help catch your attention. @findex vm-recover-folder @findex recover-file If you want to recover the lost changes, run @kbd{M-x vm-recover-folder} or use the Recover Folder entry in Folder menu. At the @samp{Recover File:} prompt press @key{RET}. Emacs's built-in @kbd{recover-file} command is @emph{not recommended} for this purpose because VM is unable to obtain reliable data regarding mail folders from Emacs. In response to @code{vm-recover-folder}, Emacs will display a detailed directory listing showing the folder file and the auto-save file and ask you whether you want to recover from the auto-save file. A good rule of thumb is to answer ``yes'' if the auto-save file is larger than the folder file. If the auto-save file is significantly smaller, Emacs might not have completed writing the auto-save file during the previous crash. Or it could be that the smaller auto-save file reflects the results of an expunge that you had not yet committed to disk before the crash. If so, answering ``no'' means you might have to do that expunge again, but this is better than not knowing whether the auto-save file was truncated. Assuming you answered ``yes'', the folder buffer's contents will be replaced by the contents of the auto-save file and VM will re-parse the folder. At this point the contents of the folder buffer and the disk copy of the folder are different. Therefore VM will not get new mail for this folder until the two copies of the folder are synchronized. When you are satisfied that the recovered folder is whole and intact, type @kbd{S} to save it to disk. After you do this, VM will allow you to use @kbd{g} to retrieve any new mail that has arrived in the spool files for the folder. Assuming you answered ``no'' to the recovery question, you should type @kbd{C-x C-q}, which is bound to @code{vm-toggle-read-only} in VM folder buffers. The folder will be taken out of read-only mode and you can read and retrieve your mail normally, ignoring the auto-save file that is still on disk. If you are visiting a @acronym{POP} or @acronym{IMAP} folder (rather than a local folder) that was modified during a previous crash, the process of recovery is similar. However, there will be less useful information in the auto-save file in this case. When you synchronize an @acronym{IMAP} folder with the server, only the changes made during the current VM session are saved to the server. Changes stored in the auto-save file were made in a previous session of VM and, so, cannot be saved to the server. So, saying ``no'' to the recovery question and toggling the read-only status (@kbd{C-x C-q}) is a better option in the case of server folders. @unnumberedsubsec Recovering Message Compositions @vindex vm-mail-auto-save-directory @findex vm-postpone-message Any messages you were in the midst of composing when Emacs crashed, would also have auto-save files in the disk. They would be saved in the @code{vm-mail-auto-save-directory}, if you have set that variable, or @code{vm-folder-directory}, or the directory that was current when you started composing the message. You can visit the auto-save file, which would get loaded as a text file by default, and then run @kbd{M-x mail-mode}. VM's mail-mode command keys are not available in this mode. The best option is to run @kbd{M-x vm-postpone-message} to save the unfinished message composition and then continue it using @code{vm-continue-postponed-message}. @xref{Add-ons, Postponing message composition}. @unnumberedsubsec Recovering Sessions Emacs also provides a way to recover the entire Emacs session after a crash. @xref{Recover,,, emacs, the GNU Emacs Manual}. However, the Emacs @code{recover-session} command will recover VM folders as if they were ordinary files. As mentioned above, this is not a good method of recovering VM folders. You should use @code{vm-recover-folder} command instead. So, when Emacs @code{recover-session} command asks you whether to recover a VM folder, the best option is to answer ``no''. Then you should recover the folders separately, using the @code{vm-recover-folder} command. If you do answer ``yes'', then Emacs loads the auto-save file into a buffer. The auto-save file still exists on the disk, but it will get deleted when you save the buffer. So, you should examine the folder before you save it. Run @kbd{M-x vm-mode} in the buffer corresponding to the VM folder, make sure that it is not damaged, and then save the folder. If you do not believe that the auto-saved version is good, you can kill the buffer. At this point, VM asks you for confirmation whether you really want to kill the buffer and, secondly, whether you want to delete the auto-save file. If you answer ``yes'' to the last question, then the auto-saved folder will be gone for ever. @unnumberedsubsec Reverting a Folder @findex vm-revert-folder @findex revert-file If you have made changes to a mail folder which you would like to cancel and go back to the version currently on the disk, you can use the function @kbd{vm-revert-folder} or the ``Revert Folder'' entry in the Folder menu. (Emacs's built-in @kbd{revert-file} is not recommended.) @node Selecting Messages, Reading Messages, Starting Up, Top @chapter Selecting Messages @findex vm-next-message @findex vm-previous-message @kindex n @kindex p @vindex vm-skip-deleted-messages @vindex vm-skip-read-messages In order to read, delete, or do anything to a message, you need to select it. In other words, make the message the @dfn{current message}. The primary commands for selecting messages in VM are @kbd{n} (@code{vm-next-message}) and @kbd{p} (@code{vm-previous-message}). These commands move forward and backward through the current folder. By default, these commands skip messages flagged for deletion. This behavior can be disabled by setting the value of the variable @code{vm-skip-deleted-messages} to @code{nil}. These commands can also be made to skip messages that have been read; set @code{vm-skip-read-messages} to @code{t} to do this. @cindex prefix argument The commands @kbd{n} and @kbd{p} also take prefix arguments that specify the number of messages to move forward or backward. If the magnitude of the prefix argument is greater than 1, no message skipping will be done regardless of the settings of the skip variables. @vindex vm-circular-folders The variable @code{vm-circular-folders} determines whether VM folders will be considered circular by various commands. @dfn{Circular} means VM will wrap from the end of the folder to the start and vice versa when moving the message pointer, deleting, undeleting or saving messages before or after the current message. A value of @code{t} causes all VM commands to consider folders circular. A value of @code{nil} causes all VM commands to signal an error if the start or end of the folder would have to be passed to complete the command. For movement commands, this occurs after the message pointer has been moved as far as it can go. For other commands the error occurs before any part of the command has been executed, i.e. no deletions, saves, etc. will be done unless they can be done in their entirety. A value other than @code{nil} or @code{t} causes only VM's movement commands to consider folders circular. Saves, deletes and undeletes will behave as if the value is @code{nil}. The default value of @code{vm-circular-folders} is @code{nil}. @vindex vm-follow-summary-cursor You can also select messages by using the summary window. @xref{Summaries}. Move the cursor to the summary line for the message you want to select and press @key{RET}. VM will select this message. Instead of pressing @key{RET} you could run some other VM command that operates based on the notion of a `current message'. VM will select the message under the cursor in the summary window before executing such commands. Example, if you type @kbd{d}, VM will select the message under the cursor and then delete it. Note that this occurs @emph{only} when you execute a command when the cursor is in the summary buffer window and only if the variable @code{vm-follow-summary-cursor} is non-@code{nil}. @vindex vm-jump-to-unread-messages @vindex vm-jump-to-new-messages When a folder is visited or when you type @kbd{g} and VM retrieves some mail, the default action is to move to the first new or unread message in the folder. New messages are favored over old but unread messages. If you set @code{vm-jump-to-new-messages} to @code{nil}, VM will favor old, unread messages over new messages if the old, unread message appears earlier in the folder. If you set @code{vm-jump-to-unread-messages} to @code{nil} also, VM will not search for new or unread messages. @cindex searching Other commands to select messages: @table @kbd @findex vm-goto-message @kindex RET @item @key{RET} (@code{vm-goto-message}) Go to message number @var{n}. @var{n} is the prefix argument, if provided, otherwise it is prompted for in the minibuffer. @findex vm-goto-message-last-seen @kindex TAB @item TAB (@code{vm-goto-message-last-seen}) Go to message last previewed or read. @findex vm-next-message-no-skip @findex vm-previous-message-no-skip @kindex N @kindex P @item N (@code{vm-next-message-no-skip}) @itemx P (@code{vm-previous-message-no-skip}) Go to the next (previous) message, ignoring the settings of the skip control variables. @findex vm-next-unread-message @findex vm-previous-unread-message @kindex M-n @kindex M-p @item M-n (@code{vm-next-unread-message}) @itemx M-p (@code{vm-previous-unread-message}) Move forward (backward) to the nearest new or unread message. @findex vm-isearch-forward @findex vm-isearch-backward @kindex M-s @comment @kindex M-r @vindex vm-search-using-regexps @item M-s (@code{vm-isearch-forward}) @item M-x vm-isearch-backward These work just like Emacs' normal forward and backward incremental search commands, except that when the search ends, VM selects the message containing point. If the value of the variable @code{vm-search-using-regexps} is non-@code{nil}, a regular expression may be used instead of a fixed string for the search pattern; VM defaults to the fixed string search. If a prefix argument is given, the value of @code{vm-search-using-regexps} is temporarily reversed for the search. @xref{Incremental Search,,,emacs, the GNU Emacs Manual}. @end table @node Reading Messages, Sending Messages, Selecting Messages, Top @chapter Reading Messages Once a message has been selected, VM will show it to you. By default, presentation is done in two stages: @dfn{previewing} and @dfn{paging}. @menu * Previewing:: Customizing message previews. * Paging:: Viewing the current message. * @acronym{MIME} Messages:: Using VM's @acronym{MIME} display features. @end menu @node Previewing, Paging, Reading Messages, Reading Messages @section Previewing @dfn{Previewing} means showing you a small portion of a message and allowing you to decide whether you want to read it. Typing @key{SPC} exposes the body of the message, and from there you can repeatedly type @key{SPC} to page through the message. By default, the sender, recipient, subject and date headers are shown when previewing; the rest of the message is hidden. This behavior may be altered by changing the settings of three variables: @code{vm-visible-headers}, @code{vm-invisible-header-regexp} and @code{vm-preview-lines}. @vindex vm-preview-lines If the value of @code{vm-preview-lines} is a number, it tells VM how many lines of the text of the message should be visible. The default value of this variable is 0. If @code{vm-preview-lines} is @code{nil}, then previewing is not done at all; when a message is first presented it is immediately exposed in its entirety and is flagged as read. If @code{vm-preview-lines} is @code{t}, the message body is displayed fully but the message is not flagged as read until you type @key{SPC}. @vindex vm-visible-headers The value of @code{vm-visible-headers} should be a list of regular expressions matching the beginnings of headers that should be made visible when a message is presented. The regexps should be listed in the preferred presentation order of the headers they match. @vindex vm-invisible-header-regexp If non-@code{nil}, the variable @code{vm-invisible-header-regexp} specifies what headers should @emph{not} be displayed. Its value should be a string containing a regular expression that matches all headers you do not want to see. Setting this variable non-@code{nil} implies that you want to see all headers not matched by it; therefore the value of @code{vm-visible-headers} is only used to determine the order of the visible headers in this case. Headers not matched by @code{vm-invisible-header-regexp} or @code{vm-visible-headers} are displayed last. If you change the value of either @code{vm-visible-headers} or @code{vm-invisible-header-regexp} in the middle of a VM session the effects will not be immediate. You will need to use the command @code{vm-discard-cached-data} on each message (bound to @kbd{j} by default) to force VM to rearrange the message headers. A good way to do this is to mark all the messages in the folder and apply @code{vm-discard-cached-data} to the marked messages @xref{Marking Messages}. @vindex vm-highlighted-header-regexp @vindex vm-highlighted-header-face Another variable of interest is @code{vm-highlighted-header-regexp}. The value of this variable should be a single regular expression that matches the beginnings of any header that should be presented in inverse video when previewing. For example, a value of @samp{"^From\\|^Subject"} causes the From and Subject headers to be highlighted. Highlighted headers will be displayed using the face specified by @code{vm-highlighted-header-face}, which defaults to 'bold. @vindex vm-preview-read-messages By default, VM will not preview messages that are flagged as read. To have VM preview all messages, set the value of @code{vm-preview-read-messages} to @code{t}. @findex vm-expose-hidden-headers @kindex t Typing @kbd{t} (@code{vm-expose-hidden-headers}) makes VM toggle between exposing and hiding headers that would ordinarily be hidden. @node Paging, @acronym{MIME} Messages, Previewing, Reading Messages @section Paging @kindex SPC @kindex DEL @vindex vm-auto-next-message Typing @key{SPC} during a message preview exposes the body of the message. If the message was new or previously unread, it will be flagged ``read''. At this point you can use @key{SPC} to scroll forward, and @key{DEL} to scroll backward a windowful of text at a time. A prefix argument @var{n} applied to these commands causes VM to scroll forward or backward @var{n} lines. Typing space at the end of a message moves you to the next message. If the value of @code{vm-auto-next-message} is @code{nil}, @key{SPC} will not move to the next message; you must type @kbd{n} explicitly. If the value of @code{vm-honor-page-delimiters} is non-@code{nil}, VM will recognize and honor page delimiters. This means that when you scroll through a document, VM will display text only up to the next page delimiter. Text after the delimiter will be hidden until you type another @key{SPC}, at which point the text preceding the delimiter will become hidden. The Emacs variable @code{page-delimiter} determines what VM will consider to be a page delimiter. @findex vm-unread-message @findex vm-mark-message-read @findex vm-mark-message-unread @kindex U @kindex . You can ``unread'' a message (so to speak) by typing @kbd{U} (@code{vm-unread-message}, also called @code{vm-mark-message-unread}). The current message will be marked unread. Conversely, you can mark an unread message as read by typing @kbd{.} (@code{vm-mark-message-read}). @findex vm-toggle-flag-message @kindex ! As you read messages, you might want to flag important messages so that you can come back to them later. You can do so by typing @code{!} (@code{vm-toggle-flag-message}). You can also turn off the flag on a flagged message by typing @code{!} again. In the Summary display, the flagged messages are highlighted using the @code{vm-summary-high-priority-face}. (@xref{predefined summary faces}.) @cindex longlines.el @cindex filling paragraphs @cindex word wrapping @cindex visual line mode @vindex vm-paragraph-fill-column @vindex vm-fill-paragraphs-containing-long-lines @vindex vm-word-wrap-paragraphs Sometimes you will receive messages that contain lines that are too long to fit on your screen without wrapping. Setting @code{vm-word-wrap-paragraphs} to t will cause VM to use the @file{longlines.el} library by Grossjohann, Schroeder and Yidong to carry out word wrapping. You must have this library installed somewhere on your @code{load-path}. Another way to deal with the problem is to use the @code{visual-line-mode} in Emacs 23. You can activate it automatically for viewing messages by adding the function @code{turn-on-visual-line-mode} to the @code{vm-presentation-mode-hook}. If you are unable to use either of these solutions, then you can use Emacs's paragraph filling facility. If you set @code{vm-fill-paragraphs-containing-long-lines} to a positive numeric value @var{N}, VM will call @code{fill-paragraph} on all paragraphs that contain lines spanning @var{N} columns or more. You can also set this variable to the symbol @code{window-width}, in which case the width of the current window is used the limiting width beyond which paragraph filling is invoked. As with other things that VM does for presentation purposes, this does not change the message contents. VM copies the message contents to a ``presentation'' buffer before altering them. The fill column that VM uses is controlled by @code{vm-paragraph-fill-column}. Unlike the Emacs variable @code{fill-column}, this variable is not buffer-local by default. @node @acronym{MIME} Messages,, Paging, Reading Messages @section Reading @acronym{MIME} Messages @cindex @acronym{MIME} @vindex vm-display-using-mime @dfn{@acronym{MIME}} is a set of extensions to the standard Internet message format that allows reliable transmission of arbitrary data including images, audio and video, as well as ordinary text in different languages. By default, VM will recognize @acronym{MIME} encoded messages and display them as specified by the various @acronym{MIME} standards specifications. This can be turned off by setting the variable @code{vm-display-using-mime} to @code{nil} and VM will then display @acronym{MIME} messages as plain text messages. @vindex vm-mime-base64-decoder-program @vindex vm-mime-base64-encoder-program @vindex vm-mime-base64-decoder-switches @vindex vm-mime-base64-encoder-switches @vindex vm-mime-qp-decoder-program @vindex vm-mime-qp-decoder-switches @vindex vm-mime-qp-encoder-program @vindex vm-mime-qp-encoder-switches @vindex vm-mime-uuencode-decoder-program @vindex vm-mime-uuencode-decoder-switches At its most basic @acronym{MIME} is a set of transfer encodings used to ensure error free transport, and a set of content types. VM understands the two standard @acronym{MIME} transport encodings, Quoted-Printable and BASE64, and will decode messages that use them as necessary. VM also will try to recognize and decode messages using the UNIX ``uuencode'' encoding system. While this is not an official @acronym{MIME} transfer encoding and never will be, enough old mailers still use it that it is worthwhile to attempt to decode it. VM has Emacs-Lisp based Quoted-Printable and BASE64 encoders and decoders, but you can have VM use external programs to perform these tasks and the process will almost certainly be faster. The variables @code{vm-mime-qp-decoder-program}, @code{vm-mime-qp-decoder-switches}, @code{vm-mime-qp-encoder-program}, @code{vm-mime-qp-encoder-switches}, @code{vm-mime-base64-decoder-switches}, @code{vm-mime-base64-encoder-switches}, @code{vm-mime-base64-decoder-program}, @code{vm-mime-base64-encoder-program}, tell VM which programs to use and what command line switches to pass to them. There are C programs at VM's distribution sites on the Internet to handle BASE64 and Quoted-Printable. VM does not have a built-in ``uuencode'' decoder, so @code{vm-mime-uuencode-decoder-program} must be set non-@code{nil} for VM to decode uuencoded @acronym{MIME} objects. @menu * Viewing @acronym{MIME}:: Decoding @acronym{MIME} for viewing * Attachments:: Operating on @acronym{MIME} attachments * Internal display:: Viewing attachments internally in Emacs * External display:: Viewing attachments with external viewers * Displaying images:: Using Emacs facilities for images * @acronym{MIME} type conversion:: Converting external attachments to internal * Character sets:: @acronym{MIME} character sets * multipart/alternative:: @acronym{MIME} content in alternative formats * Inferring @acronym{MIME} types:: Inferring types from attachment file names @end menu @node Viewing @acronym{MIME}, Attachments,, @acronym{MIME} Messages @unnumberedsubsec Viewing @acronym{MIME} messages By default VM will display as many content types as possible within Emacs. Images and audio are also supported if support for images and audio has been compiled in. Types that cannot be displayed internally within Emacs can be converted to a type that can, or be displayed using an external viewer. @vindex vm-auto-decode-mime-messages @vindex vm-mime-decode-for-preview @kindex D The first step in displaying a @acronym{MIME} message is decoding it to determine what object types it contains. The variable @code{vm-auto-decode-mime-messages} controls when this happens. A value of @code{t} means VM should decode the message as soon as the message body is exposed, or during previewing if @code{vm-mime-decode-for-preview} is also set non-@code{nil}. A @code{nil} value means wait until decoding is explicitly requested. Type @kbd{D} (@code{vm-decode-mime-message}) to manually initiate @acronym{MIME} decoding. @vindex vm-mime-button-format-alist @cindex @acronym{MIME} button When VM does not display a @acronym{MIME} object immediately, it displays a @b{@acronym{MIME} button} or tag line in its place that describes the object and what you have to do to display it. The value of @code{vm-mime-button-format-alist} determines the format of the text in those buttons. After decoding you will see either the decoded @acronym{MIME} objects or button lines that must be activated to attempt display of the @acronym{MIME} object. @vindex vm-mime-auto-displayed-content-types @vindex vm-mime-auto-displayed-content-type-exceptions The variable @code{vm-mime-auto-displayed-content-types} specifies the types that are displayed immediately. Its value should be a list of @acronym{MIME} content types that should be displayed immediately after decoding. Other types will be displayed as a button that you must activate to display the object. The variable @code{vm-mime-auto-displayed-content-type-exceptions} can be used to specify any exceptions to the types listed in @code{vm-mime-auto-displayed-content-types}. @cindex Content-Disposition @vindex vm-mime-honor-content-disposition @cindex attachments The @acronym{MIME} objects in messages come with a header called @dfn{Content-Disposition}, which specifies whether the @acronym{MIME} object should be displayed as part of the message display (the ``inline'' disposition) or whether it should be displayed as a button that should be invoked to view the object (the @dfn{attachment} disposition). However, not all mail clients do a good job of adding this header. It is not uncommon to find mail clients that declare all @acronym{MIME} objects to be ``inline'' and others that declare all @acronym{MIME} objects to be ``attachment''. The variable @code{vm-mime-honor-content-disposition} can be customized to tell VM whether it should follow the suggestions in the Content-Disposition headers. A value of @code{t} means that they should be always honored and a value of @code{nil} means that they should be ignored. It can also be set to the symbol @code{internal-only}, which means that the Content-Disposition suggestions should be honored for only the internally displayable types. (@xref{Internal display of @acronym{MIME} attachments}.) @findex vm-next-button @findex vm-previous-button @kindex [ @kindex ] The commands @kbd{[} and @kbd{]} (@code{vm-previous-button}) and @code{vm-next-button}, respectively) can be used move to particular buttons within the message presentation. @node Attachments, Internal display, Viewing @acronym{MIME}, @acronym{MIME} Messages @unnumberedsubsec Operating on @acronym{MIME} attachments @anchor{Operating on @acronym{MIME} attachments} @cindex attachments @kindex $ | @kindex $ d @kindex $ RET @kindex $ s @kindex $ w @kindex $ p @kindex $ d @kindex $ e @findex vm-mime-reader-map-pipe-to-command @findex vm-delete-mime-object @findex vm-mime-reader-map-display-using-default @findex vm-mime-reader-map-display-object-as-type @findex vm-mime-reader-map-save-message @findex vm-mime-reader-map-save-file @findex vm-mime-reader-map-pipe-to-printer @findex vm-delete-mime-object @findex vm-mime-reader-map-display-using-external-viewer @findex vm-mime-reader-map-attach-to-composition To activate a button, either click the middle mouse button over it, or move the cursor to the line and press @key{RET}. If you are running under a window system, you can use the right mouse button over a @acronym{MIME} button to display a menu of actions you can take on the @acronym{MIME} object. If you prefer using keyboard commands, you can save the @acronym{MIME} object with @kbd{$ w}, print it with @kbd{$ p}, or pipe it to a shell command with @kbd{$ |}. Use @kbd{$ s} to append an encapsulated message or USENET news article to a folder. If you want to display the object with its characters displayed using Emacs' default face, use @kbd{$ @key{RET}}. To display the object using an external viewer, type @kbd{$ e}. @multitable @columnfractions .20 .80 @item $ w @tab @code{vm-mime-reader-map-save-file} @item $ s @tab @code{vm-mime-reader-map-save-message} @item $ p @tab @code{vm-mime-reader-map-pipe-to-printer} @item $ | @tab @code{vm-mime-reader-map-pipe-to-command} @item $ @key{RET} @tab @code{vm-mime-reader-map-display-using-default} @item $ e @tab @code{vm-mime-reader-map-display-using-external-viewer} @item $ v @tab @code{vm-mime-reader-map-display-object-as-type} @item $ d @tab @code{vm-delete-mime-object} @item $ a @tab @code{vm-mime-reader-map-attach-to-composition} @end multitable @vindex vm-mime-delete-after-saving @vindex vm-mime-attachment-save-directory @vindex vm-mime-confirm-delete The @acronym{MIME} attachments can be saved to disk with @kbd{$ w} (@code{vm-mime-reader-map-save-file}). They can be deleted at the same time by setting the variable @code{vm-mime-delete-after-saving}. In this case, the attachment is deleted and replaced by a @acronym{MIME} part that refers to the saved copy. The variable @code{vm-mime-attachment-save-directory} specifies the default directory to save the attachments in. The @acronym{MIME} attachments can also be deleted directly from the message bodies with @kbd{$ d} (@code{vm-delete-mime-object}). The variable @code{vm-mime-confirm-delete} controls whether a confirmation is asked for. It is a good idea to use @code{vm-mime-delete-after-saving} to delete saved attachments instead of deleting them manually, because with the former approach the message will have a handle to the saved copy, which can be retrieved when desired. Saving attachments to the file system and deleting them from message bodies has the beneficial effect of reducing the size of VM folders. That leads to a better utilization of the computer resources and usually a faster operation of VM. @findex vm-save-all-attachments @findex vm-delete-all-attachments @vindex vm-mime-deletable-types @vindex vm-mime-deletable-type-exceptions @vindex vm-mime-savable-types @vindex vm-mime-savable-type-exceptions The commands @code{vm-save-all-attachments} and @code{vm-delete-all-attachments} can be used to save or delete @i{all} the attachments in a message. An "attachment" in this context is any @acronym{MIME} part that has "attachment" as its content-disposition or simply has a file name. In addition, all @acronym{MIME} parts that have types matching @code{vm-mime-savable-types} or @code{vm-mime-deletable-types} (but not the corresponding @code{-exceptions}) are included. @node Internal display, External display, Attachments, @acronym{MIME} Messages @unnumberedsubsec Internal display of @acronym{MIME} attachments @anchor{Internal display of @acronym{MIME} attachments} @vindex vm-mime-auto-displayed-content-types A value of t for @code{vm-mime-auto-displayed-content-types} means that all types should be displayed immediately. A nil value means never display @acronym{MIME} objects immediately; only use buttons. If the value of @code{vm-mime-auto-displayed-content-types} is a list, it should be a list of strings, which should all be @acronym{MIME} types or type/subtype pairs. Example: @example (setq vm-mime-auto-displayed-content-types '("text" "image/jpeg")) @end example @noindent If a top-level type is listed without a subtype then all subtypes of that type are assumed to be included. The example above says that all text types should be displayed immediately, but only JPEG images should be displayed this way. @vindex vm-mime-auto-displayed-content-type-exceptions The variable @code{vm-mime-auto-displayed-content-type-exceptions} should be a list of @acronym{MIME} content types that should not be displayed immediately after decoding. This variable acts as an exception list for @code{vm-mime-auto-displayed-content-types}; all types listed there will be auto-displayed except those in the exception list. @example (setq vm-mime-auto-displayed-content-type-exceptions '("text/html")) @end example @noindent If ``code'' has been included in @code{vm-mime-auto-displayed-content-types} then the effect of this setting is to allow the auto-display of all text types @i{except} for html. @vindex vm-mime-internal-content-types The variable @code{vm-mime-internal-content-types} specifies which types should be displayed internally within Emacs. Like @code{vm-mime-auto-displayed-content-types} its value should be a list of @acronym{MIME} content types. A value of t means that VM should always display an object internally if possible. VM knows which object types can be displayed internally, so you can specify the types you want without worrying about potential errors. If the value is a list, it should be a list of strings. Example: @example (setq vm-mime-internal-content-types '("text" "message" "image/jpeg")) @end example @cindex multipart types @noindent If a top-level type is listed without a subtype then all subtypes of that type are assumed to be included. Note that multipart types are always handled internally regardless of the setting of this variable. @vindex vm-mime-internal-content-type-exceptions The variable @code{vm-mime-internal-content-type-exceptions} serves as the exception list for @code{vm-mime-internal-content-types}. Its value should be a list of types that should not be displayed internally. @cindex @acronym{HTML} @vindex vm-mime-text/html-handler The @acronym{HTML} content in text/html @acronym{MIME} parts can be displayed in Emacs using a variety of packages. VM knows about: @cindex lynx @cindex w3m @cindex w3 @multitable @columnfractions .15 .85 @item lynx @tab The @command{lynx} browser used externally to convert @acronym{HTML} to plain text @item w3m @tab The @command{w3m} browser used externally to convert @acronym{HTML} to plain text @item emacs-w3 @tab The @samp{Emacs/W3} browser used internally in Emacs @item emacs-w3m @tab The @samp{Emacs/W3M} browser used internally in Emacs @end multitable You can set the variable @code{vm-mime-text/html-handler} to one of these values to use the appropriate package. A value of @code{auto-select} causes VM to select the best package available. A value of @code{nil} asks VM not to display @acronym{HTML} content internally. The default value is @code{auto-select}, allowing VM to give you the best display possible in your environment. If you do not like the results, you may set the variable to a different value or @code{nil}. @node External display, Displaying images, Internal display, @acronym{MIME} Messages @unnumberedsubsec External display of @acronym{MIME} attachments @vindex vm-mime-external-content-types-alist For types that you want displayed externally, set the value of @code{vm-mime-external-content-types-alist} to specify external viewers for the types. The value of this variable should be an associative list of @acronym{MIME} content types and the external programs used to display them. If VM cannot display a type internally or a type is not listed in @code{vm-mime-internal-content-types} VM will try to launch an external program to display that type. The alist format is a list of lists, each sublist having the form @example (@var{TYPE} @var{FUNCTION} @var{ARG} @var{ARG} ... ) @end example @noindent or @example (@var{TYPE} @var{PROGRAM} @var{ARG} @var{ARG} ... ) @end example @noindent or @example (@var{TYPE} @var{COMMAND-LINE}) @end example @noindent @var{TYPE} is a string specifying a @acronym{MIME} type or type/subtype pair. For example ``text'' or ``image/jpeg''. If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. In the first form, @var{FUNCTION} is a lisp function that is responsible for displaying the attachment in an external application. Any @var{ARG}s will be passed to the function as arguments. The octets that compose the object will be written into a temporary file and the name of the file is passed as an additional argument. In the second form, @var{PROGRAM} is a string naming a program to run to display an object. Any @var{ARG}s will be passed to the program as arguments. The octets that compose the object will be written into a temporary file and the name of the file can be inserted into an @var{ARG} string by writing @samp{%f} in the @var{ARG} string. In earlier versions of VM the filename was always added as the last argument; as of VM 6.49 this is only done if @samp{%f} does not appear in any of the @var{ARG} strings. If the @var{COMMAND-LINE} form is used, the program and its arguments are specified as a single string and that string is passed to the shell ("sh -c" typically) for execution. Since the command line will be passed to the shell, you can use shell variables and input/output redirection if needed. As with the @var{PROGRAM/ARGS} form, the name of the temporary file that contains the @acronym{MIME} object will be appended to the command line if @samp{%f} does not appear in the command line string. In either the @var{PROGRAM/ARG} or @var{COMMAND-LINE} forms, all the program and argument strings will have any %-specifiers in them expanded as described in the documentation for the variable @code{vm-mime-button-format-alist}. The only difference is that @samp{%f} refers to the temporary file VM creates to store the object to be displayed, not the filename that the sender may have associated with the attachment. Example: @example (setq vm-mime-external-content-types-alist '( ("text/html" browse-url-of-file) ("image/gif" "xv") ("image/jpeg" "xv") ("video/mpeg" "mpeg_play") ("video" w32-shell-execute "open") ) ) @end example The first matching list element will be used. No multipart message will ever be sent to an external viewer. External viewer processes are normally killed when you select a new message in the current folder. If you want viewer processes to not be killed, set @code{vm-mime-delete-viewer-processes} to a @code{nil} value. Any type that cannot be displayed internally or externally or converted to a type that can be displayed, will be displayed as a button that allows you to save the body to a file. @vindex vm-mime-external-content-type-exceptions As with the internal type list, there is an exception list that you can use to specify types that you do not want displayed externally. When VM is considering whether it should automatically launch an external viewer, it will consult the variable @code{vm-mime-external-content-type-exceptions}. If the type to be displayed is listed, VM will not launch a viewer. This allows you to setup viewers for types that ordinarily you would not want VM to display or for types that you normally want to convert to some other type using @code{vm-mime-type-converter-alist}. You can still display such a type with an external viewer by using @kbd{$ e}. @vindex vm-mime-attachment-auto-suffix-alist When a @acronym{MIME} object is displayed using an external viewer VM must first write the object to a temporary file. The external viewer then opens and displays that file. Some viewers will not open a file unless the filename ends with some extension that it recognizes such as @samp{.html} or @samp{.jpg}. You can use the variable @code{vm-mime-attachment-auto-suffix-alist} to map @acronym{MIME} types to extensions that your external viewers will recognize. The value of this variable should be a list of type and suffix pairs. The list format is: @example ((@var{TYPE} . @var{SUFFIX}) ...) @end example @var{TYPE} is a string specifying a @acronym{MIME} top-level type or a type/subtype pair. If a top-level type is listed without a subtype, all subtypes of that type are matched. @var{SUFFIX} is a string specifying the suffix that should be used for the accompanying type. Example: @example (setq vm-mime-attachment-auto-suffix-alist '( ("image/jpeg" . ".jpg") ("image/gif" . ".gif") ("image/png" . ".png") ("text" . ".txt") ) ) @end example @noindent VM will search the list for a matching type. The suffix associated with the first type that matches will be used for the temporary filename. @node Displaying images, @acronym{MIME} type conversion, External display, @acronym{MIME} Messages @unnumberedsubsec Displaying inline images in messages @cindex images Most versions of Emacs can display images when used on graphical screens. You can verify if the Emacs version is able to do so by calling the function @code{display-images-p}. However, Emacs relies on external libraries to create graphical images, which are specified through the variable @code{image-library-alist}. Even if Emacs has the ability to display some image type, it cannot display such images unless appropriate libraries are installed and specified to Emacs. You can verify which image types are really available by calling the function @code{image-type-available-p} with an image type such as @samp{tiff} or @samp{gif} as the argument. @vindex vm-mime-internal-content-types @vindex vm-mime-auto-displayed-content-types Assuming that a particular image type, say @samp{tiff} is available, you can include its @acronym{MIME} type in @code{vm-mime-internal-content-types}, e.g., @example (add-to-list 'vm-mime-internal-content-types "image/tiff") @end example You can also add the @acronym{MIME} type to the variable @code{vm-mime-auto-displayed-content-types} so that VM will automatically display all images of the type. If the type is not included among the auto-displayed types, then the image is initially shown as a button with a thumbnail image. Clicking on the button with the middle mouse button expands the image to its full size. @cindex ImageMagick @vindex vm-imagemagick-identify-program @vindex vm-imagemagick-convert-program Once an image is displayed, you can use the right mouse button to do various image manipulations on it, such as enlarging/reducing it, rotating it etc. To do such operations, VM uses the @samp{ImageMagick} graphics manipulation software. You can install ImageMagick on your system and specify the location of its @command{identify} and @command{convert} programs to VM via the variables @code{vm-imagemagick-identify-program} and @code{vm-imagemagick-convert-program}. @vindex vm-mime-use-image-strips By default, VM displays images by slicing them into contiguous horizontal strips and displaying the strips in order. This facilitates vertical scrolling within an image. The variable @code{vm-mime-use-image-strips} controls whether VM uses strips for image display. It is @samp{t} by default. VM also uses the ImageMagick's @code{convert} program to convert between image formats, so that an image that is not displayable in Emacs is converted to another format that is displayable. You can turn off such conversion by setting the variable @code{vm-imagemagick-convert-program} to @samp{nil}. @node @acronym{MIME} type conversion, Character sets, Displaying images, @acronym{MIME} Messages @unnumberedsubsec @acronym{MIME} type conversion @vindex vm-mime-type-converter-alist Types that cannot be displayed internally or externally are checked against an associative list of types that can be converted to other types. If an object can be converted to a type that VM can display, then the conversion is done and the new object is subject to the auto-display rules which determine whether the object is displayed immediately or a button is displayed in its place. The conversion list is stored in the variable @code{vm-mime-type-converter-alist}. The alist format is @example ( (START-TYPE END-TYPE COMMAND-LINE ) ... ) @end example @var{START-TYPE} is a string specifying a @acronym{MIME} type or type/subtype pair. Example @samp{"text"} or @samp{"image/jpeg"}. If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. @var{END-TYPE} must be an exact type/subtype pair. This is the type to which @var{START-TYPE} will be converted. @var{COMMAND-LINE} is a string giving a command line to be passed to the shell. The octets that compose the object will be written to the standard input of the shell command. Example: @example (setq vm-mime-type-converter-alist '( ("image/jpeg" "image/gif" "jpeg2gif") ("text/html" "text/plain" "striptags") ) ) @end example @noindent The first matching list element will be used. @node Character sets, multipart/alternative, @acronym{MIME} type conversion, @acronym{MIME} Messages @unnumberedsubsec @acronym{MIME} character sets For text type messages, @acronym{MIME} also requires that a character set be specified, so that the recipient's mail reader knows what character glyphs to use to display each character code. To display a message properly VM needs to know how to choose a font for a given character set. @vindex vm-mime-default-face-charsets @cindex character sets @cindex Windows-1252 @cindex CP1252 @cindex GB2312 @cindex ISO-8859-1 @cindex US-ASCII The variable @code{vm-mime-default-face-charsets} tells VM what character sets your default face can display. For most American and European users using X Windows, Emacs' default face displays the ISO-8859-1 and US-ASCII characters, US-ASCII being a subset of ISO-8859-1. Additional character sets can be included if you think that the messages only contain characters that your system can display. For example, messages sent by a Chinese sender might declare the character set to be GB2312 but the message might contain only English characters that you might be able to display and read. Messages sent by Microsoft Windows users might declare the character set to be Windows-1252 or CP1252, but the majority of the characters might be in ISO-8859-1. By including such character sets in @code{vm-mime-default-face-charsets}, you might be able to view the majority of the characters even if your system cannot fully handle the character set. The value of @code{vm-mime-default-face-charsets} must be a list of strings specifying the character sets that your default face can display. Example: @example (add-to-list 'vm-mime-default-face-charsets "Windows-1251") (add-to-list 'vm-mime-default-face-charsets "Windows-1252") (add-to-list 'vm-mime-default-face-charsets "Windows-1257") @end example Note that for character sets listed in this variable, VM's @acronym{MIME} decoding is bypassed. So you should not add charsets like "UTF-8" that require additional decoding. @vindex vm-mime-charset-converter-alist @cindex UTF-8 @cindex ISO-2022-JP Sometimes a charset that VM cannot display can be converted to a one that VM can display. An example would be a message encoded using UTF-8 but in fact only contains Japanese characters. In that case the message text could probably be converted to iso-2022-jp which VM running on a MULE-enabled Emacs could display. VM offers a way to do such conversions. The variable @code{vm-mime-charset-converter-alist} is an associative list of @acronym{MIME} charsets and programs that can convert between them. If VM cannot display a particular character set, it will scan this list to see if the charset can be converted into a charset that it can display. The alist format is: @example ( ( START-CHARSET END-CHARSET COMMAND-LINE ) ... ) @end example @var{START-CHARSET} is a string specifying a @acronym{MIME} charset. Example @samp{"iso-8859-1"} or @samp{"utf-8"}. @var{END-CHARSET} is a string specifying the charset to which @var{START-CHARSET} will be converted. @var{COMMAND-LINE} is a string giving a command line to be passed to the shell. The characters in @var{START-CHARSET} will be written to the standard input of the shell command and VM expects characters encoded in @var{END-CHARSET} to appear at the standard output of the @var{COMMAND-LINE}. @var{COMMAND-LINE} is passed to the shell, so you can use pipelines, shell variables and redirections. @cindex iconv Example: @example (setq vm-mime-charset-converter-alist '( ("utf-8" "iso-2022-jp" "iconv -f utf-8 -t iso-2022-jp -c") ) ) @end example The first matching list element will be used. Be sure to include the @code{-c} option so that nonconvertible characters are ignored instead of causing error messages. @vindex vm-mime-charset-font-alist The variable @code{vm-mime-charset-font-alist} tells VM what font to use to display a character set that cannot be displayed using the default face. The value of this variable should be an assoc list of character sets and fonts that can be used to display them. The format of the list is: ( (@var{CHARSET} . @var{FONT}) ...) @var{CHARSET} is a string naming a @acronym{MIME} registered character set such as @samp{"iso-8859-5"}. @var{FONT} is a string naming a font that can be used to display @var{CHARSET}. An example setup might be: @example (setq vm-mime-charset-font-alist '( ("iso-8859-5" . "-*-*-medium-r-normal-*-16-160-72-72-c-80-iso8859-5") ) ) @end example @noindent This variable is only useful for character sets whose characters can all be encoded in single 8-bit bytes. Also multiple fonts can only be displayed if you're running under a window system e.g. X Windows. So this variable will have no effect if you're running Emacs on a tty. Note that under FSF Emacs 19 any fonts you use must be the same height as your default font. XEmacs and Emacs 21 do not have this limitation. Under Emacs 20 and beyond, and under any XEmacs version compiled with MULE support, the value of @code{vm-mime-charset-font-alist} has no effect. This is because all characters are displayed using fonts discovered by MULE and VM has no control over them. @node multipart/alternative, Inferring @acronym{MIME} types, Character sets, @acronym{MIME} Messages @unnumberedsubsec @acronym{MIME} multipart/alternative @cindex @acronym{MIME} alternatives @acronym{MIME} allows a message to be sent with its content encoded in multiple formats, simultaneously, in the same message. Such messages have a content type of @dfn{multipart/alternative}. The idea is that the sender might have different @acronym{MIME} decoding or display capabilities than some of his recipients. For instance, the sender may be able to compose a message using fancy text formatting constructs like tables, italics and equations but some of the recipients may only be able to display plain text. The @samp{multipart/alternative} type message is the solution to this dilemma. Such a message would contain at least two text subparts, one in plain text and the other in the full featured text formatting language that the sender used. @vindex vm-mime-alternative-show-method @cindex @acronym{MIME} alternative, best @cindex @acronym{MIME} alternative, best-internal To control how VM displays @samp{multipart/alternative} messages, you must set the variable @code{vm-mime-alternative-show-method}. Its value must be a symbol. A value of @code{best} tells VM to display the message using the subpart closest in appearance to what the sender used to compose the message. In the example above this would mean displaying the fully featured text subpart, if VM knows how to display that type. VM will display the type either internally or externally. A value of @code{best-internal} tells VM to use the closest subpart that it can display internally. External viewers won't be used in this case. A value of @code{all} asks VM to display all the alternatives. @cindex @acronym{MIME} alternative, favorite @cindex @acronym{MIME} alternative, favorite-internal The value can also be a list of the form @example (favorite @var{TYPE} ...) @end example @noindent with the first element of the list being the symbol @code{favorite}. The remaining elements of the list are strings specifying @acronym{MIME} types. VM will look for each TYPE in turn in the list of alternatives and choose the first matching alternative found that can be displayed. If instead of the symbol @code{favorite}, @code{favorite-internal} is used then the first @var{TYPE} that matches an alternative that can be displayed internally will be chosen. @findex vm-nuke-alternative-text/html Messages with multiple alternatives use up extra file space and slow down the operation of vm. If you would like keep the text/plain alternatives but erase the text/html alternatives, you can use the @code{vm-nuke-alternative-text/html} command. This operation may not always be safe because the @code{text/html} alternative is often the most faithful representation of the sender's message and it may include attachments that are not replicated in the other alternatives. Please use caution. @node Inferring @acronym{MIME} types, , multipart/alternative, @acronym{MIME} Messages @unnumberedsubsec Inferring @acronym{MIME} types Some mailers incorrectly use the generic @samp{application/octet-stream} type when sending files that really have a specific @acronym{MIME} type. For example, a JPEG image might be sent using @samp{application/octet-stream} type instead of @samp{image/jpeg}, which would be the correct type. In many cases the filename sent along with the mistyped file (e.g. @file{foo.jpg}) suggests the correct type. @vindex vm-infer-mime-types If the variable @code{vm-infer-mime-types} is set non-@code{nil}, VM will attempt to use the filename sent with a @acronym{MIME} attachment to guess an attachment's type if the attachment is of type @samp{application/octet-stream}. @vindex vm-infer-mime-types-for-text If the variable @code{vm-infer-mime-types-for-text} is set non-@code{nil}, VM will attempt to use filenames for attachments of type @samp{text/plain} as well. @node Sending Messages, Saving Messages, Reading Messages, Top @chapter Sending Messages When sending messages from within VM, you will be using the standard mail sending facility provided with Emacs, plus some extensions added by VM. @xref{Sending Mail,,,emacs, the GNU Emacs Manual}. Emacs comes with two versions of mail sending packages, called ``mail mode'' and ``message mode''. VM currently uses the ``mail mode'' package, which is not too dissimilar to the ``message mode'' package. Even though VM's mail composition buffers will be in ``mail mode'', they have some extra command keys. @table @kbd @findex vm-yank-message @findex vm-yank-message-other-folder @kindex C-c C-y @item C-c C-y (@code{vm-yank-message}) Copies a message from the folder that is the parent of this composition into the mail composition buffer. The message number is read from the minibuffer. By default, each line of the copy is prepended with the value of the variable @code{vm-included-text-prefix}. All message headers are yanked along with the text. Point is left before the inserted text, the mark after. Any hook functions bound to @code{mail-yank-hooks} are run, after inserting the text and setting point and mark. If a prefix argument is given, this tells VM: ignore @code{mail-yank-hooks}, don't set the mark, don't prepend the value of @code{vm-included-text-prefix} to every yanked line, and don't yank any headers other than those specified in @code{vm-visible-headers} and @code{vm-invisible-headers}. @item @code{M-x vm-yank-message-other-folder} This allows one to yank a message from a different folder than the parent of this composition. @kindex C-c C-v @item C-c C-v All VM commands may be accessed in a VM Mail mode buffer by prefixing them with C-c C-v. @kindex C-c C-a @vindex vm-send-using-mime @cindex drag and drop @item C-c C-a (@code{vm-attach-file}) or drag-and-drop a file Attaches a file to the composition. When you send the message, VM will insert the file and @acronym{MIME} encode it. The variable @code{vm-send-using-mime} must be set non-@code{nil} for this command to work. You will be asked for the file's type, and a brief description of the attachment. The description is optional. If the file's type is a text type, you will also be asked for the character set in which the text should be displayed. The new attachment will appear as a highlighted tag in the composition buffer. You can use mouse button 3 on this tag to set the default content disposition of the attachment. The content disposition gives a hint to the recipient's mailer how to treat the attachment. Specifically the disposition will indicate whether the attachment should be displayed along with the message or saved to a file. Any text in the composition that appears before the tag will appear in a @acronym{MIME} text part before the attachment when the message is encoded and sent. Similarly, any text after the tag will appear after the attachment in the encoded message. If you change your mind about using the attachment, you can remove it from the composition with @key{C-k}. If you want to move the attachment to some other part of the message, you can kill it @key{C-k} and yank it back with @key{C-y}. @kindex C-c C-m @item C-c C-m (@code{vm-attach-message}) Attaches a mail message to the composition. If invoked with a prefix argument, the name of a folder is read from the minibuffer and the message or messages to be attached are copied from that folder. You will be prompted for the message number of the message to be attached. If you invoke the command on marked messages by running @code{vm-next-command-uses-marks} first, the marked messages in the selected folder will be attached as a @acronym{MIME} digest. @kindex C-c C-b @item C-c C-b (@code{vm-attach-buffer}) Attaches an Emacs buffer to the composition. @findex vm-mime-encode-composition @kindex C-c C-e @kindex C-c C-c @item C-c C-e (@code{vm-mime-encode-composition}) Encodes the composition using @acronym{MIME}, but does not send it. This is useful if you want to use PGP to sign a message before sending it. After signing the message, you would use @kbd{C-c C-c} as usual to send the message. Emacs' @code{undo} command can be used to undo the encoding, so that you can continue composing the unencoded message. @findex vm-preview-composition @kindex C-c C-p @item C-c C-p (@code{vm-preview-composition}) Previews the current composition. The message is copied into a temporary folder and you can read the message and interact with it using normal VM mode commands to see how it might look to a recipient. Type @key{q} to quit the temporary folder and resume composing your message. @end table @findex vm-mail @kindex m The simplest command is @kbd{m} (@code{vm-mail}) which sends a mail message much as @kbd{M-x mail} does but allows the added commands described above. @code{vm-mail} can be invoked outside of VM by typing @kbd{M-x vm-mail}. However, only (@code{vm-yank-message-other-folder}) will work; all the other commands require a parent folder. If you send a message and it is returned by the mail system because it was undeliverable, you can resend the message by typing @kbd{M-r} (@code{vm-resend-bounced-message}). VM will extract the old message and its pertinent headers from the returned message, and place you in a VM Mail mode buffer. A Resent-To header will be added, which you can fill in with the corrected addresses of the recipients that bounced. You can also added a Resent-Cc header, which has the same meaning as a Cc header in a normal message. Mail will only be sent to the addresses in the Resent-To and Resent-Cc headers unless you delete both of those headers. In that case the To and Cc headers will be used. @menu * Sending Options:: Variables that control mail sending. * Sending @acronym{MIME} Messages:: Sending a message using @acronym{MIME} attachments. * Replying:: Describes the various ways to reply to a message. * Forwarding Messages:: How to forward a message to a third party. * Saving copies:: Saving copies of sent mail. @end menu @node Sending Options, Sending @acronym{MIME} Messages, Sending Messages, Sending Messages @section Mail Sending Options As already mentioned, VM uses Emacs @ref{Mail Mode,,,emacs, the Gnu Emacs Manual} for sending email. Therefore, Mail Mode options should be set to configure the mail sending. The extra options provided by VM are described below. @vindex vm-mail-auto-save-directory The variable @code{vm-mail-auto-save-directory} can be used to specify the directory in which the message composition buffers should be auto-saved. If it is nil, the @code{vm-folder-directory} is used for auto-saving. @vindex vm-mail-header-from @vindex vm-mail-mode-hidden-headers When a mail composition buffer is created, VM initializes it with header lines that you can fill in. The @code{From} header is usually standard and contains your email address. You can have VM fill it in for you automatically by setting the variable @code{vm-mail-header-from}. (It is @code{nil} by default.) @vindex vm-mail-use-sender-address The variable @code{vm-mail-use-sender-address}, if set to @code{t}, asks VM to fill in the @code{To} header from the sender's name and address of the current message. This has effect only when @code{vm-mail} is invoked from a VM folder. When it is invoked from other buffers, the @code{To} headers is unfilled. (Some people tend to use @code{vm-reply} to get this effect, but that is a bad practice because it also tags the new message as a reply to an older message.) The variable @code{vm-mail-mode-hidden-headers} can be used to hide some of the header lines from the mail composition buffer. By default, the headers ``References'' and ``X-Mailer'' are hidden. @vindex vm-mail-header-insert-date @vindex vm-mail-header-insert-message-id @vindex vm-mail-reorder-message-headers @vindex vm-mail-header-order Additional header lines are created by VM before the composed message is sent. The variable @code{vm-mail-header-insert-date} can be set to @code{t} (which is the default value) asking VM to insert a Date header into a message before it is sent. You should set it to @code{nil} if you would like to insert a Date header yourself. The variable @code{vm-mail-header-insert-message-id} asks VM to insert a Message-ID header before sending the message. The variable @code{vm-mail-reorder-message-headers} asks VM to reorder the message headers into a particular order before sending. The order is determined by the variable @code{vm-mail-header-order}. @node Sending @acronym{MIME} Messages, Replying, Sending Options, Sending Messages @section Sending @acronym{MIME} Messages @vindex vm-send-using-mime To use VM's @acronym{MIME} composition features, you must have @code{vm-send-using-mime} set to a non-@code{nil} value. With @acronym{MIME} composition enabled, VM will allow you to add file attachments to your composition and will analyze your message when you send it and @acronym{MIME} encode it as necessary. @menu * @acronym{MIME} attachments:: Sending a message using @acronym{MIME} attachments. * @acronym{MIME} characters:: Sending a message with @acronym{MIME}-encoded characters. * @acronym{MIME} headers:: Sending a message with @acronym{MIME}-encoded headers. * @acronym{MIME} preview:: Previewing a @acronym{MIME} message before sending. @end menu @node @acronym{MIME} attachments, @acronym{MIME} characters, Sending @acronym{MIME} Messages, Sending @acronym{MIME} Messages, @unnumberedsec @acronym{MIME} attachments @kindex C-c C-a @findex vm-attach-file To attach a file to your composition, use @kbd{C-c C-a} (@code{vm-attach-file}). VM will ask you for the name of the file, its type, a brief description and its character set if it is a text attachment. An attachment will be represented in the composition as a tag line like this [ATTACHMENT ~/sounds/chronophasia_scream.au, audio/basic] @noindent You can type text before and after this tag and it will appear before or after the text in the final @acronym{MIME} message when VM encodes it. You can kill the tag with @kbd{C-k} and yank it back with @kbd{C-y} to move it to another place in the message. You can yank back the tag multiple times to duplicate the attachment in the message. Or you can leave the tag killed and the attachment won't appear in the message when it is sent. @cindex Content-Disposition If you click the right mouse button on the attachment tag, a menu will appear that allows you to change the content disposition of the attachment. The @dfn{Content-Disposition} of a @acronym{MIME} object gives a mail reader a hint as to whether the object should be displayed inline or as an inert tag or button that you must activate in some fashion. @dfn{Inline} display usually means that the object will be displayed within or alongside the message text, if that is possible. @dfn{Attachment}, when used as a content disposition, means that the object will likely be displayed as a tag. By default, VM specifies an inline disposition for all @acronym{MIME} types except @samp{application} and @samp{model} types. @kindex C-c C-b @findex vm-attach-buffer To attach a buffer instead of a file, use @kbd{C-c C-b} (normally bound to @code{vm-attach-buffer}. You must not kill the buffer that you attach until after the message has been sent. @kindex C-c C-m @findex vm-attach-message You can attach a message from another folder by using @kbd{C-c C-m} (@code{vm-attach-message}). By default, the folder is the parent folder of the message composition. If there is no parent folder, then a folder name will be read from the minibuffer. The message number of the message to be attached is also read from the minibuffer. Alternatively, you can mark one or more messages in the parent folder before invoking this command. All the marked messages will be attached as a digest in the outgoing message. @unnumberedsubsubsec Point-to-point attachment operations @cindex point-to-point attachment operations A number of @dfn{point-to-point operations} allow you to attach objects from other editing contexts to a message you are composing. @findex vm-dired-attach-file @findex vm-dired-do-attach-files You can visit a directory in Emacs (@pxref{Dired,,,emacs, the GNU Emacs Manual}), and run @code{vm-dired-attach-file} on any file. The file be attached to your message composition. You can also mark a set of files in Dired and run @code{vm-dired-do-attach-files} to attach all of them. @findex vm-dnd-attach-file @cindex drag and drop You can use your Window system to drag and drop a file into a composition buffer (@code{vm-dnd-attach-file}). @kindex $ a @findex vm-mime-reader-map-attach-to-composition @findex vm-attach-message-to-composition When you visit a folder in VM, you can attach a message from the folder by running @code{vm-attach-message-to-composition}. When viewing a message that has @acronym{MIME} attachments, you can attach any of those attachments to your message composition by using the @kbd{$ a} (@code{vm-reader-map-attach-to-composition}) function. (@xref{Operating on @acronym{MIME} attachments}.) This operation is also available on the pop-menu for attachments. In all these cases, you will be prompted for the message composition buffer to which you would like to attach the objects. The default is the latest message you have been composing, as indicated by the Emacs buffer ring. @node @acronym{MIME} characters, @acronym{MIME} headers, @acronym{MIME} attachments, Sending @acronym{MIME} Messages @unnumberedsec @acronym{MIME} characters @vindex vm-mime-7bit-composition-charset By default, when you type text into a composition buffer VM assumes that if all the character codes are less than 128, you are using the US-ASCII character set and that is the character set declared in the encoding of the message when it is sent. If you are using some other character set, you must specify it by setting the variable @code{vm-mime-7bit-composition-charset}. The value of this variable should be a string specifying the character set. @vindex vm-mime-8bit-composition-charset If there are character codes in the composition greater than 128, the variable @code{vm-mime-8bit-composition-charset} tells VM what character set to assume when encoding the message. The default is @samp{iso-8859-1}. Character codes greater than 128 may not be transported reliably across the Internet in mail messages. Some machines will refuse to accept messages containing such characters and some will accept them but zero the eighth bit, garbling the message. To avoid these problems, VM transfer encodes 8-bit text by default. @acronym{MIME} has two transfer encodings that convert 8-bit data to 7-bit data for safe transport. @dfn{Quoted-printable} leaves the text mostly readable even if the recipient does not have a @acronym{MIME}-capable mail reader. @dfn{BASE64} is unreadable without a @acronym{MIME}-capable mail reader. @vindex vm-mime-8bit-text-transfer-encoding VM's text transfer encoding behavior is controlled by the variable @code{vm-mime-8bit-text-transfer-encoding}. Its value should be a symbol that specifies what kind of transfer encoding to do for 8-bit text. A value of @samp{quoted-printable}, means to use quoted-printable encoding. A value of @samp{base64} means to use BASE64 encoding. A value of @samp{8bit} means to send the message as is. Note that this variable usually only applies to textual @acronym{MIME} content types. Images, audio, video, etc. typically will have some attribute that makes VM consider them to be ``binary'', which moves them outside the scope of this variable. For example, messages with line lengths of 1000 characters or more are considered binary, as are messages that contain carriage returns (ASCII code 13) or NULs (ASCII code 0). @node @acronym{MIME} headers, @acronym{MIME} preview, @acronym{MIME} characters, Sending @acronym{MIME} Messages @unnumberedsec @acronym{MIME} headers The internet standards specify that the header lines of messages should always be in 7 bit ASCII, even if the body of a message can use an 8 bit character set. If you use other non-ASCII characters in typing the headers then VM encodes their words using the @acronym{MIME} encoded-word syntax, which is of the form @code{=?charset?encoding?encoded text?=}. @vindex vm-mime-encode-headers-regexp @vindex vm-mime-encode-headers-type The variable @code{vm-mime-encode-headers-regexp} specifies which headers should be encoded in this way. By default, @samp{Subject}, @samp{Organization}, @samp{From}, @samp{To}, @samp{CC}, @samp{Bcc} and @samp{Resent-} header lines encoded. The words are encoded using quoted-printable encoding (@kbd{Q}). You can ask VM to use the base64 encoding by setting the variable @code{vm-mime-encode-headers-type}. @vindex vm-mime-encode-words.regexp @vindex vm-mime-encode-headers-words-regexp The variables @code{vm-mime-encode-words.regexp} and @code{vm-mime-encode-headers-words-regexp} control what is meant by a ``word'' for VM for the purpose of encoding. By default, the words are those containing any 8 bit character and delimited by white space characters. @node @acronym{MIME} preview, , @acronym{MIME} headers, Sending @acronym{MIME} Messages @unnumberedsec @acronym{MIME} preview @kindex C-c C-p To preview what a @acronym{MIME} message will look like to a recipient, use @kbd{C-c C-p} (@code{vm-mime-preview-composition}). VM will encode a copy of the message and present it to you in a temporary mail folder. You can scroll through the message using normal VM mail reading commands. Typing @kbd{q} in this folder will return you to your composition where you can make further changes. @kindex C-c C-e @kindex C-c C-c To encode a @acronym{MIME} message without sending it, use @kbd{C-c C-e} (@code{vm-mime-encode-composition}). This is useful if you use PGP and want to sign a message before sending it. VM will encode the message for transport, inserting all necessary headers and boundary markers. You can then sign the message and send it with C-c C-c and be confident that VM won't invalidate the signature by making further modifications to the message. Or if you want to resume editing the message you can run the Emacs @code{undo} (normally bound to @kbd{C-x u}) command which will revert the encoded @acronym{MIME} bodies back to tags and you can continue entering your composition. @node Replying, Forwarding Messages, Sending @acronym{MIME} Messages, Sending Messages @section Replying @vindex vm-reply-subject-prefix VM has special commands that make it easy to reply to a message. When a reply command is invoked, VM fills in the subject and recipient headers for you, since it is apparent whom the message should be sent to and what the subject should be. There is an old convention of prepending the string @samp{Re: } to the subject of replies if the string isn't present already. You can customize the string to be prepended in this way by setting the variable @code{vm-reply-subject-prefix}. Its value should be a string to prepend to the subject of replies, if the string isn't present already. A @code{nil} value means don't prepend anything to the subject (this is the default). In any case you can edit any of the message headers manually, if you wish. @vindex vm-included-text-prefix VM also helps you cite material from the message to which you are replying, by providing @dfn{included text} as a feature of some of the commands. @dfn{Included text} is a copy of the message being replied to with some prefix to each line so that the included text can be distinguished from the text of the reply. By default, the prefix string is @samp{> }. This can be customized via the variable @code{vm-included-text-prefix}. The reply commands are: @table @kbd @findex vm-reply @kindex r @item r (@code{vm-reply}) Replies to the author of the current message. @findex vm-reply-include-text @kindex R @item R (@code{vm-reply-include-text}) Replies to the author of the current message and provides included text. @findex vm-followup @kindex f @item f (@code{vm-followup}) Replies to the all recipients of the current message. @findex vm-followup-include-text @kindex F @item F (@code{vm-followup-include-text}) Replies to the all recipients of the current message and provides included text. @end table These commands all accept a numeric prefix argument @var{n}, which if present, causes VM to reply to the next (or previous if the argument is negative) @var{n-1} messages as well as the current message. Also, all the reply commands set the ``replied'' attribute of the messages to which you are responding, but only when the reply is actually sent. The reply commands can also be applied to marked messages. (@pxref{Marking Messages}.) @vindex vm-reply-ignored-addresses If you are one of multiple recipients of a message and you use @kbd{f} and @kbd{F}, your address will be included in the recipients of the reply. You can avoid this by judicious use of the variable @code{vm-reply-ignored-addresses}. Its value should be a list of regular expressions that match addresses that VM should automatically remove from the recipient headers of replies. The default value is @code{nil}, which means that no addresses are removed. @vindex vm-in-reply-to-format The variable @code{vm-in-reply-to-format} specifies the format of the In-Reply-To header that is inserted into the header section of the reply buffer. Like @code{vm-included-text-attribution-format}, @code{vm-in-reply-to-format} should be a string similar to that of @code{vm-summary-format}. A @code{nil} value causes the In-Reply-To header to be omitted. If the format includes elements that can contain non-ASCII characters, then @samp{In-Reply-To} should be added to @code{vm-mime-encode-headers-regexp}. @vindex vm-strip-reply-headers The recipient headers generated for reply messages are created by copying the appropriate headers from the message to which you are replying. This includes any full name information, comments, etc. in these headers. If the variable @code{vm-strip-reply-headers} is non-@code{nil}, the recipient headers will be stripped of all information except the actual addresses. @unnumberedsubsec Included text As mentioned above, the commands @code{vm-reply-include-text} and @code{vm-followup-include-text} provide ``included text'' from the original message in your reply. In addition, you can use @kbd{C-c C-y} (@code{vm-yank-message}) inside a mail buffer to include text from any desired mail message. This is a more general mechanism for citing message text in the composed message. (The composed message does not have to be a reply. Neither do the cited messages have to be the messages you are replying to.) @cindex attachment button Citing message text is a tricky business because the original message could be a @acronym{MIME} message with encoded text or formatted text along with embedded images and attachments. By default, VM uses its @acronym{MIME} displaying mechanism to extract the included text to be cited in replies. The quoted text is then similar to what appears in the message Presentation buffer. However, the @acronym{MIME} attachments are not included by default. They are shown in the message composition buffer with @b{attachment buttons} labelled similar to: @example [DELETED ATTACHMENT mary.jpg, image/jpeg] @end example @noindent If you set the variable @code{vm-include-mime-attachments} then the attachment buttons are converted to actual attachments before the message is sent. The format of the button in this case looks like: @example [ATTACHMENT mary.jpg, image/jpeg] @end example @cindex @acronym{MIME} alternatives @vindex vm-mime-alternative-yank-method When citing a @code{multipart/alternative} @acronym{MIME} component, VM chooses the alternative specified by the variable @code{vm-mime-alternative-yank-method}. It can be defined similar to the variable @code{vm-mime-alternative-show-method}. (@pxref{multipart/alternative}.) @vindex vm-fill-paragraphs-containing-long-lines-in-reply @vindex vm-fill-long-lines-in-reply-column If the included text contains long lines, i.e., lines longer than the normal window width, you might want to fill paragraphs. You can invoke automatic filling of paragraphs by setting the variable @code{vm-fill-paragraphs-containing-long-lines-in-reply}. Like its namesake used in message presentation (@pxref{Paging}), it should be set to a positive numerical value N or the symbol @code{window-width}. Setting it to @code{nil} disables paragraph filling. If filling is used, the fill column is controlled by the variable @code{vm-fill-long-lines-in-reply-column}. Alternatively, you can fill individual paragraphs manually using @kbd{C-c C-q} (@code{mail-fill-yanked-message}). @unnumberedsubsec Alternative methods to include text The method of @acronym{MIME} decoding for included text is relatively new in VM. The older methods are the inclusion of plain text, due to Kyle Jones, and the inclusion of text from the Presentation buffer, due to Robert Fenk. @vindex vm-included-mime-types-list @vindex vm-include-text-basic The Kyle Jones method of plain text inclusion is enabled by setting the variable @code{vm-include-text-basic} to @code{t}. Setting the variable to nil returns you to the default behaviour. You can set the variable @code{vm-included-mime-types-list} to additional @acronym{MIME} type/subtype pairs that should be included in cited text. But it may not produce good results because the handling of @acronym{MIME} types is not available in the basic text inclusion method. @vindex vm-include-text-from-presentation The Robert Fenk method of text inclusion from the Presentation buffer is enabled by setting the variable @code{vm-include-text-from-presentation} to t. In this case, the text display from the Presentation buffer is copied verbatim as the quoted text. @unnumberedsubsec Options @vindex vm-included-text-attribution-format The variable @code{vm-included-text-attribution-format} specifies the format for the attribution of the included text. The @dfn{attribution} is a line of text that tells who wrote the text that is to be included; it will be inserted before the included text. If non-@code{nil}, the value of @code{vm-included-text-attribution-format} should be a string format specification similar to @code{vm-summary-format}. @xref{Summaries}. A @code{nil} value causes the attribution to be omitted. @vindex vm-included-text-headers @vindex vm-included-text-discard-header-regexp VM normally includes only the body text from the cited messages. If you wish, you can include also the message headers by customizing the variables @code{vm-included-text-headers} and @code{vm-included-text-discard-header-regexp}. @node Forwarding Messages, Saving copies, Replying, Sending Messages @section Forwarding Messages VM has four commands to forward messages: @kbd{z} (@code{vm-forward-message}), @kbd{Z} (@code{vm-forward-message-plain}), @kbd{@@} (@code{vm-send-digest}) and @kbd{B} (@code{vm-resend-message}). @unnumberedsubsec Forwarding @findex vm-forward-message @kindex z Typing @kbd{z} (@code{vm-forward-message}) puts you into a VM Mail mode buffer just like @kbd{m}, except that the current message appears as the body of the message in the VM Mail mode buffer. @vindex vm-forwarding-digest-type The forwarded message is encapsulated as specified by the variable @code{vm-forwarding-digest-type}. Recognized values are @code{nil}, "mime", "rfc934" and "rfc1153". The default is "mime". If @code{vm-forwarding-digest-type} is set to @code{nil}, the forwarded message is not encapsulated. It is included in a plain text form. Any attachments of the original message appear as attachment buttons in the composition. They will be replaced by actual attachments when the message is sent. @findex vm-forward-message-plain @kindex Z The key @kbd{Z} (@code{vm-forward-message-plain}) allows you to use plain-text forwarding directly, without needing to alter @code{vm-forwarding-digest-type}. @vindex vm-forwarded-headers @vindex vm-unforwarded-header-regexp @vindex vm-forwarded-headers-plain @vindex vm-unforwarded-header-regexp-plain You can control which header lines are included in forwarded messages via the variables @code{vm-forwarded-headers} and @code{vm-unforwarded-header-regexp} (and their counterparts @code{vm-forwarded-headers-plain} and @code{vm-unforwarded-header-regexp-plain} for plain-text forwarding). How they are used differs based on the form of forwarding used. @itemize @item For encapsulated forwarding, the default is to forward all the headers, but you can limit the forwarded headers by setting @code{vm-unforwarded-header-regexp} to a regular expression. All the headers matching the regular expression will be omitted. If this variable is set to @code{nil}, then its value is ignored and only the headers listed in @code{vm-forwarded-headers} are forwarded. @item For plain-text forwarding, done by the @kbd{Z} command, the variables @code{vm-forwarded-headers-plain} and @code{vm-unforwarded-header-regexp-plain} are used in a similar way. If the latter is set to a regular expression, then the headers matching it are omitted. Otherwise, only the headers listed in @code{vm-forwarded-headers-plain} are included. The default settings forward only the headers ``From'', ``To'', ``Cc'', ``Subject'', ``Date'' and ``In-Reply-To''. @end itemize @findex vm-forward-message-all-headers The command @code{vm-forward-message-all-headers} forwards the message with all headers intact, irrespective of the values of these variables. @vindex vm-forwarding-subject-format If the variable @code{vm-forwarding-subject-format} is non-@code{nil} it should specify the format of the Subject header of the forwarded message. A @code{nil} value causes the Subject header to be left blank. The forwarded message is flagged ``forwarded'' when the message is sent. @unnumberedsubsec Digests @findex vm-send-digest @vindex vm-digest-send-type @kindex @@ The command @kbd{@@} (@code{vm-send-digest}) works like @kbd{z} except that a digest of all the messages in the current folder is made and inserted into the VM Mail mode buffer. Also, @code{vm-send-digest} can be applied to just marked messages. @xref{Marking Messages}. When applied to marked messages, @code{vm-send-digest} will only bundle marked messages, as opposed to the usual bundling of all messages in the current folder. The message encapsulation method is specified by the variable @code{vm-digest-send-type}, which accepts the same values as @code{vm-forwarding-digest-type}. All the messages included in the digest will be flagged ``forwarded'' when the digest message is sent. @vindex vm-digest-preamble-format @vindex vm-digest-center-preamble If you give @code{vm-send-digest} a prefix argument, VM will insert a list of preamble lines at the beginning of the digest, one line per digestified message. The variable @code{vm-digest-preamble-format} determines the format of the preamble lines. If the value of @code{vm-digest-center-preamble} is non-@code{nil}, the preamble lines will be centered. @unnumberedsubsec Resending @findex vm-resend-message @kindex B @cindex resending messages @cindex Resent-To header You can forward a message ``as is'', without appearing to intervene, by @dfn{resending} it. Use the @kbd{B} (@code{vm-resend-message}) command. VM will resend the same original message and with its original headers and add a @samp{Resent-To} header that you should fill in with the new recipients. Use @kbd{C-c C-c} as usual to send the message. The resent message will be flagged as ``redistributed''. Note that a re-sent message will appear to the recipients as if it came from the original sender. They will notice that you have re-sent the message only if they are careful to look for the @code{Resent-To} header. If they reply to the message, the reply will go to the original sender. This behavior can be confusing to many users and, so, should be used with caution. @node Saving copies,, Forwarding Messages, Sending Messages @section Saving copies of sent mail @cindex FCC @cindex file CC @findex vm-imap-save-composition You can save copies of outgoing mail messages in 'sent' folders by adding an @samp{FCC:} header line to the composed message. The value of the header should be either the full path name of a mail folder on the file system or the maildrop specification of a folder on an @acronym{IMAP} server. If you use @acronym{IMAP} folders for saving sent mail, you should also add the function @code{vm-imap-save-composition} to the mail-mode's @code{mail-send-hook} variable. @cindex @acronym{IMAP}-FCC @vindex vm-imap-default-account If you have multiple @acronym{IMAP} accounts, you might wish to save copies of your replies separately in each @acronym{IMAP} account. This can be done by adding an @samp{@acronym{IMAP}-FCC:} header line. The value of the header field should be a plain folder name on the ``current'' @acronym{IMAP} account, e.g., `Sent'. The ``current'' @acronym{IMAP} account will be determined by the @acronym{IMAP} folder from which you start composing the new message (which is called the ``parent folder'' for you composition). If the parent folder is not an @acronym{IMAP} folder or if there is no parent folder, then the message copy will be saved in a folder on @code{vm-imap-default-account}. @vindex vm-do-fcc-before-mime-encode The variable @code{vm-do-fcc-before-mime-encode} allows you save the fcc copy to the sent folder @i{before} mime-encoding the message. This is useful if you want to save an unencrypted version of the message or avoid saving attachments. However, the character coding of the sent folder should be chosen carefully to allow proper storage of the messages. @node Saving Messages, Deleting Messages, Sending Messages, Top @chapter Saving Messages @cindex file locking Mail messages are normally saved to files that contain only mail messages. Such files are called @dfn{folders}. Folders are distinguished from spool files in that VM does not expect other programs to modify them while VM is visiting them. This is important to remember. VM does no locking of folders when visiting them. If the disk copy of a folder is modified behind VM's back, Emacs will complain with the dreaded ``File changed on disk'' message when you try to save the folder. @findex vm-save-message @kindex s The VM command to save a message to a folder is @kbd{s} (@code{vm-save-message}); invoking this command causes the current message to be saved to a folder whose name you specify in the minibuffer. It can be given a prefix argument @var{n} to indicate how many messages should be saved. Messages saved with @code{vm-save-message} are flagged ``filed''. @vindex vm-folder-directory @vindex vm-thunderbird-folder-directory Messages can be saved to folders on the local file system or to folders on an @acronym{IMAP} server. If @code{vm-folder-directory} is set, @code{vm-save-message} will insert this directory name into the minibuffer before prompting you for a folder name; this will save you some typing. If @code{vm-thunderbird-folder-directory} is set and you enter a Thunderbird folder using @code{vm-visit-thunderbird-folder}, then that directory will be the default place for saving messages. @vindex vm-auto-folder-alist Another aid to selecting folders in which to save mail is the variable @code{vm-auto-folder-alist}, described in detail below. Using the data given in this alist, VM can examine the headers of the message and automatically suggest an appropriate save folder where the message should be saved. @vindex vm-imap-save-to-server @cindex @acronym{IMAP} If you use an @acronym{IMAP} server and prefer to save messages on other folders on the same @acronym{IMAP} server, you can set the variable @code{vm-imap-save-to-server} to t. You will be prompted for the name of the @acronym{IMAP} folder in which to save the message. The variable @code{vm-auto-folder-alist} can also be used to suggest appropriate save folders on the @acronym{IMAP} server. @findex vm-save-message-to-local-folder @findex vm-save-message-to-imap-folder You can override the effect of @code{vm-imap-save-to-server} by using the specialized commands @code{vm-save-message-to-local-folder} and @code{vm-save-message-to-imap-folder}, which do what their names indicate. @vindex vm-confirm-new-folders If the value of the variable @code{vm-confirm-new-folders} is non-@code{nil}, VM will ask for confirmation before creating a new folder on interactive saves. @vindex vm-visit-when-saving VM can save messages to a folder in two distinct ways. The message can be appended directly to the folder on disk, or the folder can be visited as Emacs would visit any other file and the message appended to that buffer. In the latter method you must save the buffer yourself to change the on-disk copy of the folder. The variable @code{vm-visit-when-saving} controls which method is used. A value of @code{t} causes VM to always visit a folder before saving message to it. A @code{nil} value causes VM to always append directly to the folder file. In this case VM will not save messages to the disk copy of a folder that is being visited. This restriction is necessary to insure that the buffer and on-disk copies of the folder are consistent. If the value of @code{vm-visit-when-saving} is not @code{nil} and not @code{t} (e.g. 0, the default), VM will append to the folder's buffer if the buffer is currently being visited, otherwise VM will append to the file itself. @vindex vm-delete-after-saving @vindex vm-delete-after-archiving After a message is saved to a folder, the usual thing to do next is to delete it. If the variable @code{vm-delete-after-saving} is non-@code{nil}, VM will flag messages for deletion automatically after saving them. This applies only to saves to folders, not for the @kbd{w} command. There is a separate variable @code{vm-delete-after-archiving}, which works like @code{vm-delete-after-saving} but applies to the @kbd{A} (@code{vm-auto-archive-messages}) command (see below). @unnumberedsubsec vm-auto-folder-alist @vindex vm-auto-folder-alist The variable @code{vm-auto-folder-alist} is used to specify pattern-matching rules by which VM can determine an appropriate folder in which to save a message. The value of this variable should be a list of the form: @display ((@var{header-name} (@var{regexp} . @var{folder-name}) ...) ...) @end display @noindent where @var{header-name} and @var{regexp} are strings, and @var{folder-name} is a string or an s-expression that evaluates to a string. The value of @var{folder-name} can be @itemize @item the absolute path name of a local folder, @item a relative path name -- relative to @code{vm-folder-directory} or the @code{default-directory} of the currently visited folder, whichever is non-nil, or @item the maildrop specification of an @acronym{IMAP} folder. @end itemize If any part of the contents of the message header named by @var{header-name} is matched by the regular expression @var{regexp}, VM will evaluate the corresponding @var{folder-name} and use the result as the default when prompting for a folder to save the message in. When @var{folder-name} is evaluated, the current buffer will contain only the contents of the header named by @var{header-name}. It is safe to modify this buffer. You can use the match data from any @samp{\( @dots{} \)} grouping constructs in @var{regexp} along with the function @code{buffer-substring} to build a folder name based on the header information. If the result of evaluating @var{folder-name} is a list, then the list will be treated as another auto-folder-alist and will be descended recursively. @vindex vm-auto-folder-case-fold-search Whether matching is case-sensitive depends on the value of the variable @code{vm-auto-folder-case-fold-search}. A non-@code{nil} value makes matching case-insensitive. The default value is @code{t}, which means matching is case-insensitive. Note that the matching of header names is always case-insensitive because the Internet message standard RFC 822 specifies that header names are case indistinct. @unnumberedsubsec Other commands @table @kbd @findex vm-save-message-sans-headers @item M-x vm-save-message-sans-headers Saves a message or messages to a file without their headers. This command responds to a prefix argument exactly as @code{vm-save-message} does. Messages saved this way are flagged ``written''. @findex vm-auto-archive-messages @kindex A @item A (@code{vm-auto-archive-messages}) Save all unfiled messages that auto-match a folder via @code{vm-auto-folder-alist} to their appropriate folders. Messages that are flagged for deletion are not saved by this command. If invoked with a prefix argument, confirmation will be requested for each save. @findex vm-pipe-message-to-command @kindex || @item || (@code{vm-pipe-message-to-command}) Runs a shell command with some or all of the current message as input. By default, the entire message is used. However, the leading and trailing message separator lines are not included. When applied to multiple messages, the command is invoked on each message individually.@* If invoked with one @t{C-u} the text portion of the message is used.@* If invoked with two @t{C-u}'s the header portion of the message is used.@* In invoked with three @t{C-u}'s the visible headers and the text portions of the message are used.@* If the shell command generates any output, it is displayed in a @samp{*Shell Command Output*} buffer. The message itself is not altered. @findex vm-pipe-message-to-command-discard-output @kindex |d @item |d (@code{vm-pipe-message-to-command-discard-output}) Runs a shell command with some or all of the current message as input, like the above, but will not display the output. @findex vm-pipe-messages-to-command @vindex vm-pipe-messages-to-command-start @vindex vm-pipe-messages-to-command-end @kindex |s @item |s (@code{vm-pipe-messages-to-command}) Runs a shell command using as input the current message or marked messages in the mbox format. In contrast to @code{vm-pipe-message-to-command}, the leading and trailing separator lines are included. This behaviour can be altered using the variables @code{vm-pipe-messages-to-command-start} and @code{vm-pipe-messages-to-command-end}. @findex vm-pipe-messages-to-command-discard-output @kindex |n @item |n (@code{vm-pipe-messages-to-command-discard-output}) Runs a shell command using as input the current message or marked messages in the mbox format, but will not display the output. @end table @vindex vm-berkeley-mail-compatibility A non-@code{nil} value of @code{vm-berkeley-mail-compatibility} means to read and write BSD @i{Mail(1)} style Status: headers. This makes sense if you plan to use VM to read mail archives created by @i{Mail}. @node Deleting Messages, Editing Messages, Saving Messages, Top @chapter Deleting Messages In VM, messages are flagged for deletion, and then are subsequently @dfn{expunged} or removed from the folder. The messages are not removed from the on-disk copy of the folder until the folder is saved. @table @kbd @findex vm-delete-message @kindex d @item d (@code{vm-delete-message}) Flags the current message for deletion. A prefix argument @var{n} causes the current message and the next @var{n-1} messages to be flagged. A negative @var{n} causes the current message and the previous @var{n-1} messages to be flagged. @findex vm-undelete-message @kindex u @item u (@code{vm-undelete-message}) Removes the deletion flag from the current message. A prefix argument @var{n} causes the current message and the next @var{n-1} messages to be undeleted. A negative @var{n} causes the current message and the previous @var{n-1} messages to be undeleted. @findex vm-kill-subject @kindex k @item k (@code{vm-kill-subject}) Flags all messages with the same subject as the current message (ignoring ``Re:'') for deletion. @findex vm-kill-thread-subtree @kindex K @item K (@code{vm-kill-thread-subtree}) Flags all messages in the thread subtree of the current message for deletion. @findex vm-delete-duplicate-messages @item @code{vm-delete-duplicate-messages} Flags duplicate messages for deletion. The duplicate messages are detected by comparing message ID's. @findex vm-delete-duplicate-messages-by-body @item @code{vm-delete-duplicate-messages-by-body} Flags duplicate messages for deletion. The duplicate messages are detected by comparing message bodies. @findex vm-expunge-folder @kindex ### @item ### (@code{vm-expunge-folder}) Does the actual removal of messages flagged for deletion in the current folder. @end table @vindex vm-move-after-deleting @vindex vm-move-after-killing @vindex vm-move-after-undeleting Setting the variable @code{vm-move-after-deleting} non-@code{nil} causes VM to move past the messages after flagging them for deletion. Setting @code{vm-move-after-undeleting} non-@code{nil} causes similar movement after undeletes. Setting @code{vm-move-after-killing} non-@code{nil} causes VM to move after killing messages with @code{vm-kill-subject}. Note that the movement is done by calling @code{vm-next-message} which means that the value of @code{vm-circular-folders} applies to the post-command motion as for a motion command, not as for a non-motion command. @vindex vm-expunge-before-save @vindex vm-expunge-before-quit Normally, deleted messages are preserved in folders until an explicit @code{vm-expunge-folder} operation is done. This default behavior can be altered by setting the variables @code{vm-expunge-before-save} and @code{vm-expunge-before-quit}. If @code{vm-expunge-before-save} is set to non-@code{nil}, then deleted messages are expunged whenever a folder is saved. This is not an undo-able operation and no confirmation is asked for. So you should use this setting only if your normal workflow includes expunging messages as part of save. The variable @code{vm-expunge-before-quit} can be similarly set to non-@code{nil} to cause VM to expunge deleted messages whenever you quit the folder. @cindex vm-save-folder-no-expunge @cindex vm-quit-no-expunge The commands @code{vm-save-folder-no-expunge} and @code{vm-quit-no-expunge} can be used to preserve deleted messages in the saved folders, irrespective of the settings of the above variables. Giving a prefix argument to the @code{vm-quit} command has the same effect as @code{vm-quit-no-expunge}. @findex vm-delete-duplicate-messages The function @code{vm-delete-duplicate-messages} can be used to delete duplicate copies of messages that arrive through various means. For instance, if you are a member of a mailing list, every time somebody responds to one of your messages, they might send the response to you as well as the mailing list. You then receive two copies of the response. If you get a lot of such duplicate copies, you might consider invoking @code{vm-delete-duplicate-messages} automatically. For instance, the customization in your VM init file can have: @example (add-hook 'vm-arrived-messages-hook 'vm-delete-duplicate-messages) @end example @noindent This causes the duplicate-deletion function to be invoked every time new messages arrive so that you don't have to worry about the duplicate copies any further. (@xref{Hooks}.) @node Editing Messages, Marking Messages, Deleting Messages, Top @chapter Editing Messages @kindex C-c C-e @findex vm-edit-message To edit a message, type @kbd{C-c C-e} (@code{vm-edit-message}). The current message is copied into a temporary buffer, and this buffer is selected for editing. The major mode of this buffer is controlled by the variable @code{vm-edit-message-mode}. The default is Text mode. @kindex C-c ESC @findex vm-edit-message-end @kindex C-c C-] @findex vm-edit-message-abort Use @kbd{C-c ESC} (@code{vm-edit-message-end}) when you have finished editing the message. The message will be inserted into its folder, replacing the old version of the message. If you want to quit the edit without your edited version replacing the original, use @kbd{C-c C-]} (@code{vm-edit-message-abort}), or you can just kill the edit buffer with @kbd{C-x k} (@code{kill-buffer}). If you give a prefix argument to @code{vm-edit-message}, then the current message will be flagged unedited. As with VM Mail mode buffers, all VM commands can be accessed from the edit buffer through the command prefix @kbd{C-c C-v}. @node Marking Messages, Message Attributes, Editing Messages, Top @chapter Marking Messages @cindex marking @cindex searching @cindex virtual folders VM provides a way to @dfn{mark} selected messages so that subsequent operations can be applied to them. This is similar to marking in other parts of Emacs, e.g., @xref{Marks vs Flags, Dired Marks, Dired Marks, emacs}, but arguably more powerful. For example, one can mark all messages from a particular sender and save them to a folder, or mark all messages with a particular subject and print them. One can also mark messages by searching for particular strings in their text. @kindex M M To mark the current message, type @kbd{M M} (@code{vm-mark-message}). If you give a numeric prefix argument @var{n}, the next @var{n-1} messages will be marked as well. A negative prefix argument means mark the previous @var{n-1}. An asterisk (@samp{*}) will appear to the right of the message numbers of all marked messages in the summary window. @kindex M U To remove a mark from the current message, use @kbd{M U} (@code{vm-unmark-message}). Prefix arguments work as with @code{vm-mark-message}. @kindex M m @kindex M u Use @kbd{M m} to mark all messages in the current folder; @kbd{M u} removes marks from all messages. Other marking commands: @table @kbd @findex vm-mark-matching-messages @kindex M C @item M C (@code{vm-mark-matching-messages}) Mark all messages matched by a virtual folder selector. @xref{Virtual Folders}. @findex vm-unmark-matching-messages @kindex M c @item M c (@code{vm-unmark-matching-messages}) Unmark all messages matched by a virtual folder selector. @findex vm-mark-thread-subtree @kindex M T @item M T (@code{vm-mark-thread-subtree}) Mark all messages in the thread tree rooted at current message. @xref{Threading}. @findex vm-unmark-thread-subtree @kindex M t @item M t (@code{vm-unmark-thread-subtree}) Unmark all messages in the thread tree rooted at current message. @findex vm-mark-messages-same-subject @kindex M S @item M S (@code{vm-mark-same-subject}) Mark messages with the same subject as the current message. @findex vm-unmark-messages-same-subject @kindex M s @item M s (@code{vm-unmark-same-subject}) Unmark messages with the same subject as the current message. @findex vm-mark-messages-same-author @kindex M A @item M A (@code{vm-mark-same-author}) Mark messages with the same author as the current message. @findex vm-unmark-messages-same-author @kindex M a @item M a (@code{vm-unmark-same-author}) Unmark messages with the same author as the current message. @end table While the above commands can be used in any VM buffer, the following commands can be used in a Summary buffer to mark or unmark a region of message summary lines. @table @kbd @findex vm-mark-summary-region @kindex M R @item M R (@code{vm-mark-summary-region}) Mark all messages in the current region in a Summary buffer @findex vm-unmark-summary-region @kindex M r @item M r (@code{vm-unmark-summary-region}) Unmark all messages in the current region in a Summary buffer @end table To apply a VM command to all marked messages you must prefix it with the key sequence @kbd{M N} (@code{vm-next-command-uses-marks}). The next VM command will apply to all marked messages, provided the command can be applied to such messages in a meaningful and useful way. Unfortunately, as of this writing, this mechanism works only if the next command invoked is a keyboard command. Commands invoked by @kbd{M-x} are unable to access the marked messages. So, to invoke a complex command, you might temporarily bind it to an unused key, e.g., @example M-x local-set-key C vm-forward-message-all-headers M N C @end example @noindent forwards marked messages with all headers included. It is possible to use marking to execute operations on message threads. For example, the sequence of key strokes: @example MuMTMNsMu @end example @noindent saves a thread of messages. However, there are faster methods to operate on message threads. @xref{Thread Operations}. @node Message Attributes, Sorting Messages, Marking Messages, Top @chapter Message Attributes @cindex message attributes Each message in a folder has a set of attributes that VM will remember from session to session. Various VM commands set and unset these attributes. Here are the attributes maintained by VM. @table @code @item new The message was retrieved from a spool file during this visit of the current folder. @item unread The message was retrieved from a spool file during some past visit of the folder but is still unread. @item filed The message has been saved to some folder. @item written The body of the message has been saved to a file. @item edited The message has been altered (with @code{vm-edit-message}) since it arrived. @item deleted The message is deleted and will be removed from the folder at the next expunge. @item forwarded The message has been forwarded with either @code{vm-forward-message}, @code{vm-send-digest} or one of their variants. @item redistributed The message has been forwarded with the @code{vm-resend-message} command. @item replied The message has been replied to. @end table @findex vm-set-message-attributes You can set and unset these attributes directly by using @code{M-x vm-set-message-attributes}. You will be prompted in the minibuffer for names of the attributes and you can enter them with completion. Every attribute has an ``un-'' prefixed name you can use to unset the attribute, excepting ``new'' and ``unread'', which are both negated by ``read''. You can use a prefix argument with this command to affect multiple messages, and you can apply this command to marked messages with @kbd{M N}. @findex vm-undo @kindex C-x u @kindex C-_ @cindex undo VM provides a special form of undo which allows changes to message attributes to be undone. Typing @kbd{C-x u} or @key{C-_} (@code{vm-undo}) undoes the last attribute change. Consecutive @code{vm-undo}'s undo further and further back. Any intervening command breaks the undo chain, after which the undo's themselves become undoable by subsequent invocations of @code{vm-undo}. Note that expunges, saves and message edits are @emph{not} undoable. @findex vm-add-message-labels @findex vm-delete-message-labels @kindex l a @kindex l d @cindex message labels @dfn{Labels} are user-defined message attributes. They can have any name and be assigned any meaning by you. Labels are added with @kbd{l a} (@code{vm-add-message-labels} and @kbd{l e} (@code{vm-add-existing-message-labels}, and are removed by @kbd{l d} (@code{vm-delete-message-labels}). BABYL format folders use labels to store basic attributed like ``deleted'' and ``unread''. When visiting a BABYL folder VM uses these labels also in order to be compatible with other BABYL mailers. The labels used are ``recent'', ``unseen'', ``deleted'', ``answered'', ``forwarded'', ``redistributed'', ``filed'', ``edited'' and ``written''. If (and only if) you are using BABYL format folders, you should not use these label names for your own purposes. @vindex vm-flush-interval @cindex auto-save All message attributes are stored in the folder. In order for attribute changes to be saved to disk, they must be written to the folder's buffer prior to the buffer being saved. The variable @code{vm-flush-interval} controls how often that is done. A value of @code{t} means write the new attributes to the folder buffer whenever a change occurs. A value of @code{nil} means wait until just before the folder is saved before writing out the attributes. VM will work faster with this setting, but if Emacs or your system crashes, the auto-save file will contain no useful data pertaining to message attribute changes. The auto-save file will still reflect message edits and expunges. @xref{Crash Recovery}. A positive integer value @var{n} instructs VM to write out attribute changes every @var{n} seconds. The default value of this variable is @code{t}. @node Sorting Messages, Digests, Message Attributes, Top @chapter Sorting Messages @cindex sorting @findex vm-sort-messages @vindex vm-move-messages-physically @kindex G In order to make numerous related messages easier to cope with, VM provides the command @kbd{G} (@code{vm-sort-messages}), which sorts all messages in a folder using one or more sort keys. By default the actual order of the messages in the folder is not altered; that is, if you looked at the folder file outside of VM the message order would be unchanged. VM numbers and presents the messages in a different order internally. If you want the message order to be changed in the folder so that other programs can see the change, you can either invoke @code{vm-sort-messages} with a prefix argument, or you can set @code{vm-move-messages-physically} non-@code{nil} before sorting. Either way, VM will shift the actual messages around in the folder buffer, and when you save the folder, the order change will be visible to other programs. @cindex spam Valid sort keys are: @multitable @columnfractions 0.35 0.60 @item date @tab reversed-date @item activity @tab reversed-activity @item author @tab reversed-author @item subject @tab reversed-subject @item recipients @tab reversed-recipients @item line-count @tab reversed-line-count @item byte-count @tab reversed-byte-count @item physical-order @tab reversed-physical-order @item spam-score @tab reversed-spam-score @end multitable @cindex delivery date @vindex vm-sort-messages-by-delivery-date The sort key @code{date} represents the date and time of the message. Normally, this is the date when the message was sent by the sender. Note that the message could have been ``queued'' after it was sent, either on the sender's machine, on some server on the network, or in a mailing list moderator's tray. It is not uncommon for messages to arrive much later than their sent date. Setting the variable @code{vm-sort-messages-by-delivery-date} to @code{t} causes VM to use the delivery dates of messages rather than sent dates for sorting purposes. (This assumes that your own mail server records the delivery date in a @samp{Delivery-Date} header. If no such header is present, then VM uses the sent date.) The sort key @code{activity} represents the date of the most recent activity. This is the default sort order used with threads. @xref{Threading}. It allows even old threads that have recent messages to be brought to the front. @vindex vm-subject-ignored-prefix @vindex vm-subject-ignored-suffix When sorting by subject (or threading using subjects, or killing messages by subject) the subject of the message is @dfn{normalized} before comparisons are done. A @dfn{normalized} subject has uninteresting prefixes and suffixes stripped off, and multiple consecutive white space characters are collapsed to a single space. The variable @code{vm-subject-ignored-prefix} should be a regular expression that matches all strings at the beginning of a subject that you do not want to be considered when message subjects are compared. A @code{nil} value means VM should not ignore any prefixes. The analogous variable for subject suffixes is @code{vm-subject-ignored-suffix}. @vindex vm-subject-significant-chars Once the subject has been normalized, the variable @code{vm-subject-significant-chars} controls how much of what remains is considered significant for matching purposes. The first @code{vm-subject-significant-chars} will be considered significant. Characters beyond this point in the subject string will be ignored. A @code{nil} value for this variable means all characters in the subject are significant. @vindex vm-spam-score-headers @cindex spam The sorting by @code{spam-score} is done by extracting spam scores listed in the headers of the message, which are usually placed there by external spam scoring programs such as SpamAssassin. Spam scores are expected to be numbers, either integers or real numbers. The headers that should be used for extracting spam scores are listed in the variable @code{vm-spam-score-headers}. The variable is a list of triples, where each triples contains a regular expression identifying the name of the header, a regular expression matching the spam-score string on that header and a function that VM can invoke to convert the spam-score string to a number. Here is an example triple: @example ("X-Spam-Status:" "[-+]?[0-9]*\\.?[0-9]+" string-to-number) @end example @noindent This triple causes VM to extract a spam-score from @code{X-Spam-Status} headers. The first string on the header line that matches the second regular expression is extracted and converted to a number using the @code{string-to-number} function. The order in which the headers are listed in @code{vm-spam-score-headers} is significant. The first header that is found in the message is used as the spam score. If you want to move messages around by hand, use @kbd{C-M-n} (@code{vm-move-message-forward}) and @kbd{C-M-p} (@code{vm-move-message-backward}). The default is to move the current message forward or backward by one message in the message list. A prefix argument @var{n} can specify a longer move. The value of @code{vm-move-messages-physically} applies to these commands. @menu * Threading:: Using subjects and message IDs to group messages. @end menu @node Threading,, Sorting Messages, Sorting Messages @section Threading @cindex threading A @dfn{thread} is a group of messages that are either related by subject or that have a common ancestor. @dfn{Threading} is the process of determining the relationship between such messages and displaying them so that those relationships are evident. @findex vm-toggle-threads-display @vindex vm-summary-thread-indent-level @vindex vm-summary-maximum-thread-indentation To enable and disable threading, type @kbd{C-t} (@code{vm-toggle-threads-display}). You will find that, in the summary buffer, all related messages are grouped together and the subject titles are indented to show hierarchical relationships. @vindex vm-thread-using-subject @cindex header: References @cindex header: In-Reply-To @cindex header: Subject Message relationships are discovered by examining the @code{References}, @code{In-Reply-To}, and @code{Subject} headers. The first two headers are more reliable sources of information but not all mailers provide them. Therefore, all messages with similar @code{Subject} headers are also grouped into threads. If you don't want VM to use Subject headers for threading, set the variable @code{vm-thread-using-subject} to @code{nil}. Unlike in previous versions of VM, threading is not a form of sorting. You can sort threads by the usual sort keys and the sort order will apply to at least the root messages of threads. Sorting threads by subject, for instance, can be a quick way to find threads with similar subject lines. Sorting them by date would sort them chronologically according to when the threads were initiated. Sorting them by activity is a variant of the chronological order where the dates of latest activity are given prominence instead of the dates of the initial messages. @vindex vm-sort-subthreads Normally, thread-based grouping applies to entire threads as well as all their subthreads. You can block subthread grouping by setting the variable @code{vm-sort-subthreads} to @code{nil}. In that case, all the internal messages of the threads are sorted by the chosen sort order, e.g., by date, author etc. instead of being grouped into subthreads. The value of the variable @code{vm-move-messages-physically} applies to threading just as it applies to sorting. @node Digests, Summaries, Sorting Messages, Top @chapter Digests A @dfn{digest} is one or more mail messages encapsulated within another message. VM supports digests by providing a command to ``burst'' them into their individual messages. These messages can then be handled like any other messages under VM. @findex vm-burst-digest The command (@code{vm-burst-digest}) bursts a digest into its individual messages and appends them to the current folder. These messages are then assimilated into the current folder as new messages. The original digest message is not altered, and the messages extracted from it are not part of the on-disk copy of the folder until a save is done. You will be prompted for the type of digest to burst. VM understands three formats, ``rfc934'', ``rfc1154'' and ``mime''. If you don't know what kind of digest you've received, type ``guess'' and VM will try to figure out the digest type on its own. VM is pretty smart about digests and will usually make the correct choice if the digest is properly formatted. @node Summaries, Virtual Folders, Digests, Top @chapter Summaries @findex vm-summarize @vindex vm-auto-center-summary @vindex vm-summary-arrow @kindex h Typing @kbd{h} (@code{vm-summarize}) causes VM to display a summary of contents of the current folder. The information in the summary is automatically updated as changes are made to the current folder. An arrow @samp{->} appears to the left of the line summarizing the current message. The variable @code{vm-auto-center-summary} controls whether VM will keep the summary arrow vertically centered within the summary window. A value of @code{t} causes VM to always keep the arrow centered. A value of @code{nil} (the default) means VM will never bother centering the arrow. A value that is not @code{nil} and not @code{t} causes VM to center the arrow only if the summary window is not the only existing window. You can change what the summary arrow looks like by setting @code{vm-summary-arrow} to a string depicting the new arrow. You should set this variable before VM creates the summary buffer. You can have a summary generated automatically at VM startup by setting the variable @code{vm-startup-with-summary} non-nil. @xref{Starting Up}. @vindex vm-follow-summary-cursor All VM commands are available in the summary buffer just as they are in the folder buffer itself. If you set @code{vm-follow-summary-cursor} non-@code{nil}, VM will select the message under the cursor in the summary window before executing commands that operate on the current message. Note that this occurs @emph{only} when executing a command from the summary buffer window. @vindex vm-gargle-uucp A non-@code{nil} value of @code{vm-gargle-uucp} means to use a crufty regular expression that does surprisingly well at beautifying UUCP addresses that are substituted for @samp{%f} and @samp{%t} as part of summary and attribution formats. @menu * Summary Format:: Customizing the summary format * Threaded Summaries:: How threading affects summaries * Thread Folding:: Collapsing message threads in the summary * Thread Operations:: Running bulk operations on message threads * Summary Faces:: Decorating summary with fonts and colors @end menu @node Summary Format, Threaded Summaries, Summaries, Summaries @section Summary Format @vindex vm-summary-format The variable @code{vm-summary-format} controls the format of each message's summary. Its value should be a string. This string should contain printf-like ``%'' conversion specifiers which substitute information about the message into the final summary. Recognized specifiers are: @table @code @item a attribute indicators (always four characters wide) @* The first char is `D', `N', `U' or ` ' for deleted, new, unread and read messages respectively. @* The second char is `F', `W' or ` ' for filed (saved) or written messages. @* The third char is `R', `Z' or ` ' for messages replied to, and forwarded messages. @* The fourth char is `E' if the message has been edited, ` ' otherwise. @item A longer version of attributes indicators (seven characters wide).@* @* The first char is `D', `N', `U' or ` ' for deleted, new, unread and read messages respectively. @* The second is `r' or ` ', for message replied to. @* The third is `z' or ` ', for messages forwarded. @* The fourth is `b' or ` ', for messages redistributed. @* The fifth is `f' or ` ', for messages filed. @* The sixth is `w' or ` ', for messages written. @* The seventh is `e' or ` ', for messages that have been edited. @vindex vm-summary-attachment-indicator @item P indicator for a message with attachments. The variable @code{vm-summary-attachment-indicator} is the inserted string, by default a @kbd{$}. @vindex vm-summary-postponed-indicator @item p indicator for a postponed message. The variable @code{vm-summary-postponed-indicator} is the inserted string, by default a @kbd{P}. @item c number of characters in message (ignoring headers) @item S human readable size of the message @item d numeric day of month message sent @item f author's address @item F author's full name (same as f if full name not found) @item h hour:min:sec message sent @item H hour:min message sent @item i message ID @item I thread indentation @item l number of lines in message (ignoring headers) @item L labels (as a comma list) @item m month message sent @item M numeric month message sent (January = 1) @item n message number @item s message subject @item t addresses of the recipients of the message, in a comma-separated list @item T full names of the recipients of the message, in a comma-separated list If a full name cannot be found, the corresponding address is used instead. @item U user defined specifier. The next character in the format string should be a letter. VM will call the function vm-summary-function- (e.g. vm-summary-function-A for ``%UA'') in the folder buffer with the message being summarized bracketed by (point-min) and (point-max). The function will be passed a message struct as an argument. The function should return a string, which VM will insert into the summary as it would for information from any other summary specifier. @item w day of the week message sent @item y year message sent @item z timezone of date when the message was sent @item * `*' if the message is marked, ` ' otherwise @item ( starts a group, terminated by %). Useful for specifying the field width and precision for the concatenation of group of format specifiers. Example: \"%.35(%I%s%)\" specifies a maximum display width of 35 characters for the concatenation of the thread indentation and the subject. @item ) ends a group. @end table Use ``%%'' to get a single ``%''. A numeric field width may be specified between the ``%'' and the specifier; this causes right justification of the substituted string. A negative field width causes left justification. The field width may be followed by a ``.'' and a number specifying the maximum allowed length of the substituted string. If the string is longer than this value, it is truncated. @vindex vm-summary-uninteresting-senders @vindex vm-summary-uninteresting-senders-arrow If you save copies of all your outbound messages in a folder and later visit that folder, the @samp{%F} format specifier will normally display your own name. If you would rather see the recipient addresses in this case, set the variable @code{vm-summary-uninteresting-senders}. This variable's value, if non-@code{nil}, should be a regular expression that matches addresses that you don't consider interesting enough to appear in the summary. When such senders would be displayed by the @samp{%F} or @samp{%f} summary format specifiers VM will substitute the value of @code{vm-summary-uninteresting-senders-arrow} (default "To: ") followed by what would be shown by the @samp{%T} and @samp{%t} specifiers respectively. The summary format need not be one line per message but it must end with a newline, otherwise the message pointer will not be displayed correctly in the summary window. @findex vm-fix-my-summary Summary lines are precomputed and cached in the folder buffer. If you change the @code{vm-summary-format}, you need to force the cache to be updated. You can do this by the command@code{vm-fix-my-summary}. @vindex vm-restore-saved-summary-format Every folder can have its own summary format. The format is written into the folder and saved on the disk. When you visit the folder again, you can reuse the saved summary format. Set the variable @code{vm-restore-saved-summary-format} to t to achieve this effect. @node Threaded Summaries, Thread Folding, Summary Format, Summaries @section Threaded Summaries @findex vm-toggle-threads-display @vindex vm-summary-thread-indent-level @vindex vm-summary-maximum-thread-indentation When message threading is enabled (@pxref{Threading}), you will find that the Summary buffer has all related messages are grouped together and the subject titles are indented to show hierarchical relationships. Parent messages are displayed before their children and children are indented by a default two spaces to the right. The amount of indentation per level is controlled by the variable @code{vm-summary-thread-indent-level}. The default is two spaces. The variable @code{vm-summary-maximum-thread-indentation} says how many levels should be displayed via indentation. The default is 20. @vindex vm-summary-show-threads If you want VM to always display summaries using threads, you should set the default value of the variable @code{vm-summary-show-threads} non-@code{nil} in your VM init file. Example: @example (setq-default vm-summary-show-threads t) @end example @noindent Do not use @code{setq}, as this will only set the value of the variable in a single buffer. Once you've started VM you should not change the value of this variable. Rather you should use @kbd{C-t} to control the thread display. @xref{Threading}. @unnumberedsubsec Manual control of thread indentation When you deal with long discussions in mailing lists or newsgroups, you would find that threads get very deep and their indentation in the Summary window is not entirely helpful. You can temporarily promote the subthreads to higher level so that you can view the threading relationships more clearly. @kindex < @findex vm-promote-subthread The command @kbd{<} (@code{vm-promote-subthread}) temporarily decreases the indentation of the current message and its subthread by one step. You can give the command a numeric prefix argument N asking it to decreasing indentation by N steps. Giving 0 as the prefix argument has a special meaning. It says that the current message should not be indented at all, effectively making it appear as the root message of a thread. @kindex > @findex vm-demote-subthread The command @kbd{>} (@code{M-x vm-demote-subthread}) does the opposite. It increases the indentation of the current message and its subthread. You can specify the level of increased indentation as the prefix argument. Giving 0 as the prefix argument has the special meaning of asking VM to return the message to its standard indentation as determined by its thread level. Both of these commands alter the thread indentation for the current session only. The next time you visit the folder, the threads will be displayed using the standard indentation. @node Thread Folding, Thread Operations, Threaded Summaries, Summaries @section Thread Folding A new feature in VM version 8.2 is that of ``folding'' message threads in the summary window. This feature allows you to collapse all the messages in a thread into a single line of the summary window, so that you can see a more compact summary of the folder. @vindex vm-summary-enable-thread-folding @findex vm-toggle-thread @findex vm-expand-thread @findex vm-collapse-thread @findex vm-collapse-all-threads @findex vm-expand-all-threads @kindex T Thread folding is enabled by setting the variable @code{vm-summary-enable-thread-folding} to a non-nil value. The summary window then has a folding indicator in the first column: with @code{-} for threads that are expanded and @code{+} for threads that are collapsed. The command @kbd{T} (@code{vm-toggle-thread}) allows you to expand a collapsed thread or collapse an expanded thread. The commands @code{vm-expand-thread} and @code{vm-collapse-thread} implement the more specific versions of the function. @vindex vm-summary-visible When threads are folded, not all messages in the threads are hidden. New messages that are yet unread continue to be visible. Which messages remain visible in folded threads is controlled by the variable @code{vm-summary-visible}, whose value must be a list of VM selectors in the same format as those in @code{vm-virtual-folder-alist}. @xref{Virtual Folders}. @vindex vm-summary-thread-folding-on-motion The variable @code{vm-summary-thread-folding-on-motion} allows a more automatic expansion/collapsing of threads. If the variable is set to a non-nil value, then the usual motion commands @kbd{N} and @kbd{P} (@code{vm-next-message-no-skip} and @code{vm-previous-message-no-skip}) cause the threads to be expanded or collapsed as needed when you move into or out of threads. @vindex vm-summary-show-thread-count The variable @code{vm-summary-show-thread-count} allows a more elaborate display of the thread information in the summary window. If it is set to non-nil then the message number field of the summary line includes a count of the messages in its thread, in the format @code{N+C} where @code{N} is the message number and @code{C} is the message count in the thread. This takes up 3 extra columns in the summary lines. Set the variable to nil to obtain the more standard format of the summary. @findex vm-expand-all-threads @findex vm-collapse-all-threads @kindex E @kindex C When thread folding is enabled, the Summary window starts out with all the threads folded. You can expand all the threads in the folder using the command @kbd{E} (@code{vm-expand-all-threads}). The command @kbd{C} (@code{vm-collapse-all-threads}) does the reverse. @node Thread Operations, Summary Faces, Thread Folding, Summaries @section Thread Operations @vindex vm-enable-thread-operations @findex vm-toggle-thread-operations When you have thread-folding enabled, you can execute VM operations such as saving and deleting messages on entire threads. To obtain this functionality, set the variable @code{vm-enable-thread-operations} to a non-@code{nil} value in your vm-init-file. Setting it to `t' enables thread operations unconditionally. Setting it to the symbol `ask' allows a confirmation dialog before a thread operation is invoked. You can use the command @code{vm-toggle-thread-operations} in a running VM session to enable or disable thread operations. As an example, doing an @kbd{s} (@code{vm-save-message}) operation on an ordinary message saves just the single message. However, if thread operations are enabled and you invoke @kbd{s} on the root message of a collapsed thread, then the entire thread is saved. The same effect can be obtained using message marking. @xref{Marking Messages}. The following sequence of key strokes can achieve the effect of saving an entire thread: @example MuMTMNsMu @end example @noindent However, the thread-operation is simpler and more convenient. All operations that can be sensibly invoked on multiple messages extend to thread operations in this way. They include deleting, undeleting, marking, unmarking, forwarding, saving/deleting attachments etc. Replying to messages cannot be invoked as a thread operation, to prevent the accidental sending of replies to unintended recipients. The thread operations can give rise to surprising behavior. Even though it appears that an operation was invoked on a single message, it actually applies to all the messages in a thread. So, care and practice are warranted before you enable thread operations unconditionally. A safer option is to set `vm-enable-thread-operations' to `ask'. In that case, VM asks for confirmation every time an operation is applicable to all the messages in a collapsed thread. You can override the confirmation dialog by giving a prefix argument `C-u' to your operation. @node Summary Faces,, Thread Operations, Summaries @section Summary Faces @cindex faces @cindex summary faces By default, the summary of a folder is shown in a black-and-white window with plain text. This is suitable for terminal mode Emacs users. The variable @code{vm-summary-highlight-face}, which is set to the standard Emacs @code{bold} face by default, is used to highlight the currently selected message. You can set the variable to any other face, or to nil if you wan to turn off highlighting. @findex vm-summary-faces-mode @vindex vm-summary-enable-faces You can turn on more elaborate faces support, suitable for color graphics terminals, by setting the variable @code{vm-summary-enable-faces} to t in your vm-init-file. You can also run @code{M-x vm-summary-faces-mode} in the middle of a VM session to turn on summary faces. Then VM decorates the summary lines with different faces based on the attributes of the message. @xref{Faces,,,emacs, the GNU Emacs Manual}, for basic information on faces. The predefined faces used to highlight the summary window are listed below. It is possible for you to change the definitions of these faces in your vm-init-file as well as to define new faces of your own. @vindex vm-summary-faces-alist The variable @code{vm-summary-faces-alist} defines a list of condition-action pairs for decorating the summary with faces. It has the following form: @example ( ((@var{SELECTOR} [@var{ARG} ...]) @var{vm-summary-FACE}) ... ) @end example The first element of each pair is a VM selector in the same format as used for @code{vm-virtual-folder-alist}. @xref{Virtual Folders}. The second element is a face name of the form @code{vm-summary-FACE} where @code{FACE} is one of the face types listed below. The first condition satisfied by the message wins, and the face listed there is used to decorate its summary line. The faces @code{vm-summary-selected}, @code{vm-summary-collapsed} and @code{vm-summary-expanded} are special. They are @i{added} to the face specified by @code{vm-summary-faces-alist} instead of replacing it. This allows VM to add highlighting for the selected message and the collapsed/expanded thread roots, without scrubbing the natural face determined by the message attributes. @vindex vm-mouse-track-summary The variable @code{vm-mouse-track-summary} controls whether summary entries are highlighted when the mouse pointer passes over them. The highlighting is done using the standard Emacs @code{highlight} face. @subsubheading Hiding summary lines @cindex hiding summary lines @cindex vm-summary-faces-hide The command @code{vm-summary-faces-hide} allows you to hide the summary lines of messages with a particular face type. By default, it hides messages with the @code{deleted} face type. By invoking it with a prefix argument, you can specify other face types that you might like to hide. (Note that @code{deleted} face type does not necessarily mean deleted messages. Whatever messages satisfy the condition associated with the @code{vm-summary-deleted-face} in @code{vm-summary-faces-alist} will be hidden.) @subsubheading Predefined summary faces @cindex predefined summary faces @anchor{predefined summary faces} @itemize @item vm-summary-high-priority: Messages that are flagged or have other priority headers. @item vm-summary-low-priority: Messages that might be of low priority, by user-defined criteria. @item vm-summary-deleted: Deleted messages. @item vm-summary-new: New messages that have arrived during the session. @item vm-summary-unread: Messages that have not been read. @item vm-summary-marked: Messages currently marked. @item vm-summary-replied: Messages for which a reply has been sent. @item vm-summary-saved: Messages saved to a folder on disk. (Subsumes the earlier categories filed and written.) @item vm-summary-forwarded: Messages forwarded to other recipients. (Subsumes the earlier category redistributed.) @item vm-summary-edited: Messages edited after receipt. @item vm-summary-outgoing: Messages sent by you. @item vm-summary-default: Messages not matching any of the above criteria. @item vm-summary-collapsed: Root messages of threads that are collapsed. @item vm-summary-expanded: Root messages of threads that are expanded. @item vm-summary-selected: Message that is currently selected. @end itemize @node Virtual Folders, @acronym{IMAP} Server Folders, Summaries, Top @chapter Virtual Folders @cindex searching @cindex virtual folders A @dfn{virtual folder} is a mapping of messages from one or more real folders into a container that in most ways acts like a real folder but has no real existence outside of VM. You can have a virtual folder that contains a subset of messages in a real folder or several real folders. A virtual folder can also contain a subset of messages from another virtual folder. @cindex search folders @cindex interactive virtual folders There are two ways of working with virtual folders. When you are visiting a folder, you can use one or more selectors or search keys to interactively create a virtual folder. We call such folders @dfn{search folders}. You can browse through the messages in the search folder and carry out actions on them which will be reflected back to the original folder. When you are done, you can quit the search folder and return to the original folder. @cindex defined virtual folders @vindex vm-virtual-folder-alist @kindex V V @findex vm-visit-virtual-folder A second way of using virtual folders is to define them through the variable @code{vm-virtual-folder-alist}. You can visit such virtual folders by typing @kbd{V V} (@code{vm-visit-virtual-folder}). Any actions carried out on the virtual folder messages will be reflected back to the underlying real folders. When you quit a virtual folder, all its underlying real folders will also be quit, unless they were previously visited in the Emacs session. We call such virtual folders @dfn{defined virtual folders}. @menu * Search Folders:: Virtual folders created interactively * Defined Folders:: Virtual folders defined in advance * Virtual Selectors:: Selectors used for creating virtual folders * Working with Virtual Folders:: What you can do in a virtual folder * vm-avirtual:: Automatic operations using virtual selectors @end menu @node Search Folders, Defined Folders, Virtual Folders, Virtual Folders @section Search Folders @findex vm-create-virtual-folder @findex vm-create-search-folder @kindex V C The command @code{vm-create-search-folder} (bound to @kbd{V C}) lets you interactively create a virtual folder from the messages of the current folder, using exactly one selector to choose the messages. If you type @kbd{V C header @key{RET} greeting}, VM will create a folder containing only those messages that contain the string @samp{greeting} in one of its headers. @xref{Virtual Selectors}, for virtual selectors you can use for this purpose. @findex vm-create-virtual-folder-of-threads @findex vm-create-search-folder-of-threads @kindex V T The command @code{vm-create-search-folder-of-threads} (bound to @kbd{V T}) lets you create a virtual folder in the same way, but consisting of entire message threads. If a message thread contains any message matching the given selector then it is included in the virtual folder. For instance, if you type @kbd{V T author @key{RET} Peter} then all threads containing a message authored by @samp{Peter} will be included in the virtual folder. @findex vm-apply-virtual-folder @kindex V X The command @code{vm-apply-virtual-folder} (bound to @kbd{V X}) tries the selectors of a defined virtual folder against the messages of the current folder and creates a virtual folder containing the matching messages. @kindex V S @kindex V A @findex vm-create-virtual-folder-same-subject @findex vm-create-virtual-folder-same-author The commands @code{vm-create-virtual-folder-same-subject} (bound to @kbd{V S} in version 7.19) and @code{vm-create-virtual-folder-same-author} (bound to @kbd{V A} in version 7.19) create virtual folders containing all the messages in the current folder with the same subject or author as the current message. There are also short-cut key bindings for a number of frequently used selectors: @kindex V a @kindex V r @kindex V s @kindex V t @kindex V d @kindex V l @kindex V ! @kindex V n @kindex V u @findex vm-create-author-virtual-folder @findex vm-create-author-or-recipient-virtual-folder @findex vm-create-subject-virtual-folder @findex vm-create-text-virtual-folder @findex vm-create-date-virtual-folder @findex vm-create-label-virtual-folder @findex vm-create-flagged-virtual-folder @findex vm-create-new-virtual-folder @findex vm-create-unseen-virtual-folder @table @kbd @item V a (@code{vm-create-author-virtual-folder}) @item V r (@code{vm-create-author-or-recipient-virtual-folder}) @item V s (@code{vm-create-subject-virtual-folder}) @item V t (@code{vm-create-text-virtual-folder}) @item V d (@code{vm-create-date-virtual-folder}) @item V l (@code{vm-create-label-virtual-folder}) @item V ! (@code{vm-create-flagged-virtual-folder}) @item V n (@code{vm-create-new-virtual-folder}) @item V u (@code{vm-create-unseen-virtual-folder}) @end table @cindex searching When you quit a search folder, the currently selected message in the virtual folder becomes the current message in the underlying folder. So, you can use the search folder facility to search for particular messages. For example, if you knew that one of the messages with the subject @samp{greeting} had a hotel offer and you wanted to find it, you can first create a search folder of messages with subject @samp{greeting}, browse through them to find the message that had the hotel offer, and then quit the virtual folder. VM will return you to the copy of the same message in the original folder. Search folders also form an efficient way to search for some string in the text of messages. The key binding @kbd{V t} (@code{vm-create-text-virtual-folder}) can be used to find all messages with the string. This is more efficient than the @code{vm-isearch-forward} command (@pxref{Selecting Messages}) because it only searches in the text part of message bodies, not inside @acronym{MIME} attachments. @node Defined Folders, Working with Virtual Folders, Search Folders, Virtual Folders @section Defined Virtual Folders @vindex vm-virtual-folder-alist @findex vm-visit-virtual-folder @kindex V V A defined virtual folder is defined by its name, the folders that it contains and its selectors. The variable @code{vm-virtual-folder-alist} is a list of the definitions of all such virtual folders. You can visit a virtual folder listed in @code{vm-virtual-folder-alist} with the @code{vm-visit-virtual-folder} (@kbd{V V}) command. Each virtual folder definition should have the following form: @example (@var{VIRTUAL-FOLDER-NAME} ( (@var{FOLDER} ...) (@var{SELECTOR} [@var{ARG} ...]) ... ) ... ) @end example @var{VIRTUAL-FOLDER-NAME} is the name of the virtual folder being defined. This is the name by which you and VM will refer to this folder. @var{FOLDER} should be the specification of a real folder: a file path for a local folder or a maildrop specification for a @acronym{POP}/@acronym{IMAP} folder. There may be more than one @var{FOLDER} listed, the @var{SELECTOR}s within that sublist will apply to them all. If @var{FOLDER} is a directory, VM will assume this to mean that all the folders in that directory should be searched. The @var{SELECTOR} is a Lisp symbol that tells VM how to decide whether a message should be included in the virtual folder. (See below for a complete list of the possible selectors.) Some @var{SELECTOR}s require an argument @var{ARG}; unless otherwise noted, @var{ARG} may be omitted. When several selectors are listed, messages matching any one of them are included. @cindex searching @findex vm-isearch-forward @findex vm-isearch-backward The @code{text} selector provides a particularly effective way to search for strings in messages. It is better than the @code{vm-isearch-forward/backward} functions because it avoids searching inside encoded attachments, hence faster. Here is an example that you may find useful as a template for creating virtual folder definitions. @example (setq vm-virtual-folder-alist '( ;; start virtual folder definition ("virtual-folder-name" (("/path/to/folder" "/path/to/folder2") (header "foo") (header "bar") ) (("/path/to/folder3" "/path/to/folder4") (and (header "baz") (header "woof")) ) ) ;; end of virtual folder definition ) ) @end example When you visit a defined virtual folder, all the underlying folders that it depends on will be visited automatically. Likewise, when you quit the virtual folder, all the underlying folders that were purposely visited as part of the virtual folder will be closed automatically. But any other underlying folders that you might have previously visited for independent reasons will remain open. @subsection Virtual Selectors @anchor{Virtual Selectors} @unnumberedsubsubsec Generic selectors @cindex @acronym{BBDB} @table @code @item any matches any message. @item header matches message if @var{ARG} matches any part of the header portion of the message; @var{ARG} should be a regular expression. @item text matches message if @var{ARG} matches any part of the text portion of the message; @var{ARG} should be a regular expression. @item header-or-text matches message if @var{ARG} matches any part of the headers or the text portion of the message; @var{ARG} should be a regular expression. @item header-field matches messages if the header field named @var{ARG1} has text matching @var{ARG2}. @end table @unnumberedsubsubsec Selectors based on message headers @table @code @item author matches message if @var{ARG} matches the author; @var{ARG} should be a regular expression. @item author-or-recipient matches message if @var{ARG} matches the author of the message or any of its recipients; @var{ARG} should be a regular expression. @item recipient matches message if @var{ARG} matches any part of the recipient list of the message. @var{ARG} should be a regular expression. @vindex vm-summary-uninteresting-senders @item outgoing matches message if your are the author of it, i.e. if the author matches @code{vm-summary-uninteresting-senders}. @cindex @acronym{BBDB} @item in-bbdb matches message if its addresses are in the @acronym{BBDB}. With an optional first argument you can specify the address class (@code{authors} or @code{recipients}) . With an optional second argument @code{t}, the selector checks only the first address specified in the message. Examples: @example (in-bbdb authors) @end example @example (in-bbdb recipients t) @end example @item subject matches message if @var{ARG} matches any part of the message's subject; @var{ARG} should be a regular expression. @item sent-after matches message if it was sent after the date @var{ARG}. A fully specified date looks like this: @example ``31 Dec 1999 23:59:59 GMT'' @end example @noindent although the parts can appear in any order. You can leave out any part and it will default to the current date's value for that part, with the exception of the @samp{hh:mm:ss} part which defaults to midnight. @item sent-before matches message if it was sent before the date @var{ARG}. A fully specified date looks like this: @example ``31 Dec 1999 23:59:59 GMT'' @end example @noindent although the parts can appear in any order. You can leave out any part and it will default to the current date's value for that part, with the exception of the hh:mm:ss part which defaults to midnight. @item older-than matches message if it is more than @var{ARG} days old @item newer-than matches message if it is at most @var{ARG} days old @item message-id matches message if its Message ID is @var{ARG} @item uid matches message if its IMAP UID is @var{ARG} (for IMAP folders) @item uidl matches message if its POP UIDL is @var{ARG} (for POP folders) @item spam-score matches message if its spam score is at least @var{ARG}. See @code{vm-spam-score-headers} for configuration. @end table @unnumberedsubsubsec Selectors based on message attributes @table @code @item deleted matches message if it is flagged for deletion. @item undeleted matches message if it has not been deleted. @item edited matches message if it has been edited. @item unedited matches message if it has not been edited. @item filed matches message if it has been saved with its headers. @item unfiled matches message if it has not been saved with its headers. @item written matches message if it has been saved without its headers. @item new matches message if it is new. @item recent matches message if it is new. Same as the @code{new} selector. @item read matches message if it is neither new nor unread. @item unread matches message if it is not new and hasn't been read. @item unseen matches message if it is not new and hasn't been read. Same as the @code{unread} selector. @item flagged matches message if it is flagged. @item unflagged matches message if it is not flagged. @item replied matches message if it has been replied to. @item answered matches message if it has been replied to. Same as the @code{replied} selector. @item unreplied matches message if it has not been replied to. @item unanswered matches message if it has not been replied to. Same as the @code{unreplied} selector. @item forwarded matches message if it has been forwarded using a variant of @code{vm-forward-message}, @code{vm-send-digest} or one of their variants. @item unforwarded matches message if it has not been forwarded using @code{vm-forward-message}, @code{vm-send-digest} or one of their variants. @item redistributed matches message if it has been redistributed using @code{vm-resend-message}. @item unredistributed matches message if it has not been redistributed using @code{vm-resend-message}. @item marked matches message if it is marked, as with @code{vm-mark-message}. @end table @unnumberedsubsubsec Selectors based on analysing the text @table @code @vindex vm-vs-attachment-regexp @item attachment matches if a message contains an attachment, i.e., its text matches @code{vm-vs-attachment-regexp}. @item less-chars-than matches message if message has less than @var{ARG} characters. @var{ARG} should be a number. @item less-lines-than matches message if message has less than @var{ARG} lines. @var{ARG} should be a number. @item more-chars-than matches message if message has more than @var{ARG} characters. @var{ARG} should be a number. @item more-lines-than matches message if message has more than @var{ARG} lines. @var{ARG} should be a number. @end table @unnumberedsubsubsec Complex selector operations @table @code @item sexp matches message if the argument ``s-expression'' yields @code{t}. For example, to find all the messages from @samp{Jenny} with attachments, you can type @kbd{V C sexp @key{RET} (and (author "Jenny") attachment) @key{RET}}. (This selector is available for creating interactive virtual folders. The argument ``s-expression'' can involve selectors combined using the logical connectives listed below. There would be no need to use the @code{sexp} selector in defining predefined virtual folders because those definitions can directly use ``s-expressions''.) @item eval matches message if evaluating the Lisp expression @var{ARG} yields @code{t}. The Lisp expression can refer to the message by the name @code{vm-virtual-message}. This is more flexible than the @code{sexp} selector because it allows arbitrary Lisp expressions, not only the built-in selectors. However, you would need some knowledge of the Lisp functions that manipulate VM messages to use this selector. @item and matches the message if all its argument selectors match the message. Example: @example (and (author "Derek McGinty") (new)) @end example @noindent matches all new messages from Derek McGinty. @code{and} takes any number of arguments. @item not matches message only if its selector argument does NOT match the message. Example: @example (not (deleted)) @end example @noindent matches messages that are not deleted. @item or matches the message if any of its argument selectors match the message. Example: @example (or (author "Dave Weckl") (subject "drum")) @end example @noindent matches messages from Dave Weckl or messages with the string ``drum'' in their Subject header. @code{or} takes any number of arguments. @item thread matches a message thread if any message in the thread matches the argument selector. Example: @example (thread (outgoing)) @end example @noindent matches all threads that have an outgoing message, i.e., a message authored by you. @item thread-all matches a message thread if all messages in the thread match the argument selector. Example: @example (thread (less-chars-than 1000)) @end example @noindent matches threads if all their messages contain fewer than 1000 characters. @end table @unnumberedsubsubsec Selectors based on context @table @code @item folder-name matches message if it is from a folder matching @code{ARG} @item virtual-folder-member matches message if the message is already a member of some virtual folder currently being visited. @item vm-mode matches the message if the current-buffer is in vm-mode and one of its argument selectors matches the message. @item mail-mode matches the message if the current-buffer is in mail-mode and one of its argument selectors matches the message. @end table @node Working with Virtual Folders, vm-avirtual, Defined Folders,Virtual Folders @section Working with Virtual Folders @findex vm-get-new-mail @findex vm-save-folder Once you've visited a virtual folder most VM commands work as they do in a normal folder. There are exceptions. If you use @kbd{S} (@code{vm-save-folder}), the folder save command will be invoked on each real folder in turn. Similarly if you use @kbd{g} (@code{vm-get-new-mail}) in a virtual folder, mail is retrieved from the spool files associated with each of the real folders. If any of the retrieved messages are matched by the virtual folder's selectors, they will be added to the virtual folder. These commands will signal an error when invoked in a virtual folder: @display vm-save-buffer vm-write-file vm-change-folder-type vm-expunge-imap-messages vm-expunge-pop-messages @end display Normally messages in a virtual folder share attributes with the underlying real messages. For example, if you delete a message in a virtual folder, it is also flagged as deleted in the real folder. If you then run @code{vm-expunge-folder} in the virtual folder, the deleted message is expunged from the virtual folder as well as the real folder. Labels are shared between virtual and real messages. However virtual folders have their own set of message marks. To make virtual folders not share message attributes with real folders by default, set the variable @code{vm-virtual-mirror} to nil. This should be done in your VM init file and you should use @code{setq-default}, as this variable is automatically local to all buffers. @example (setq-default vm-virtual-mirror nil) @end example @findex vm-toggle-virtual-mirror @kindex V M @noindent If you want to change virtual mirror status of a particular virtual folder, use the command @code{vm-toggle-virtual-mirror} (bound to @kbd{V M}). If the virtual folder is currently sharing attributes with real folders, it will no longer be. If it is not sharing attributes with the underlying folders then it will be. @node vm-avirtual,, Working with Virtual Folders, Virtual Folders @section vm-avirtual Package @cindex vm-avirtual The @samp{vm-avirtual} add-on package created by Robert Widhopf-Fenk provides various automatic operations based on virtual selectors. These facilities are only partially documented. @kindex V O @findex vm-virtual-omit-message @kindex V U @findex vm-virtual-update-folders The command @code{M-x vm-virtual-omit-message} (bound to @kbd{V O} in version 8) will omit a message from a virtual folder, irrespective of whether it satisfies the definition of the virtual folder. The command @code{M-x vm-virtual-update-folders} (bound to @kbd{V U} in version 8) will force an update of all the visited virtual folders to reflect the changes in their underlying folders. @findex vm-virtual-check-selector-interactive The command @kbd{M-x vm-virtual-check-selector-interactive} (bound to @kbd{V T} in version 8) allows you to test a selector, i.e., a virtual folder definition, interactively by applying it to the current message. With a prefix argument, it will print diagnostic information in a separate buffer. This feature is useful because virtual folder selectors can get quite complicated and it is important to make sure that they work correctly. The vm-avirtual packages allows you to use virtual selectors to carry out automatic deletion of messages (e.g., for spam) and for automatic saving of messages to folders. @unnumberedsubsec Automatic deletion @findex vm-virtual-auto-delete-message @vindex vm-virtual-auto-delete-message-selector Automatic deletion of messages based on the virtual folder facility can be achieved with the command @code{vm-virtual-auto-delete-message} (bound to @kbd{V D} in version 8). First, set the variable @code{vm-virtual-auto-delete-message-selector} to the name of a virtual folder whose members should be normally deleted. Then invoking the command on the current message (or a COUNT number of messages with a prefix argument) deletes all those messages among them that belong to the virtual folder @code{vm-virtual-auto-delete-message-selector}. There is no need to separately view the virtual folder before deleting such messages. @findex vm-virtual-auto-delete-messages @vindex vm-arrived-messages-hook The function @code{vm-virtual-auto-delete-messages} can be added to the VM hook @code{vm-arrived-messages-hook}. This causes all the messages matching the @code{vm-virtual-auto-delete-message-selector} in the incoming mail to be automatically deleted before you view them. @unnumberedsubsec Automatic saving @findex vm-virtual-save-message @findex vm-virtual-auto-archive-messages @vindex vm-virtual-auto-folder-alist The commands @kbd{M-x vm-virtual-save-message} and @kbd{M-x vm-virtual-auto-archive-messages} provide variants of @code{vm-save-message} and @code{vm-auto-archive-messages} based on the virtual folder facility. To use them, you must first set the variable @code{vm-virtual-auto-folder-alist} to an association-list of the form @example ((@var{VIRTUAL-FOLDER-NAME} . @var{FOLDER}) ... ) @end example @noindent where @var{VIRTUAL-FOLDER-NAME} is a string and @var{FOLDER} is either a string or an expression that evaluates to a string. If the message being saved is a member of @var{VIRTUAL-FOLDER-NAME}, as per its definition in @code{vm-virtual-folder-alist}, then @var{FOLDER} is regarded as the place where it should be saved. The command @code{vm-virtual-save-message} suggests this folder as the default location for saving. The command @code{vm-virtual-auto-archive-messages} archives all matching messages in the corresponding @var{FOLDER}s, as suggested by @code{vm-virtual-auto-folder-alist}. @node @acronym{IMAP} Server Folders, Frames and Windows, Virtual Folders, Top @chapter @acronym{IMAP} Server Folders This chapter covers the additional features of @acronym{IMAP} server folders, i.e., folders on an @acronym{IMAP} server that you access using VM. @xref{@acronym{IMAP} Folders}. Do not use these features if you just download mail from IMAP mail boxes into local folders. @findex vm-imap-synchronize The command @code{vm-imap-synchronize} can be used to perform full synchronization between a VM folder and the corresponding folder on the IMAP server. (Recall that @code{vm-get-new-mail} and @code{vm-save-folder} do half-synchronization in one direction each.) @vindex vm-imap-connection-mode The variable @code{vm-imap-connection-mode} allows you to work while disconnected from the network. If it is set to @code{online}, which is the default, VM communicates with the server during @code{vm-get-new-mail}, @code{vm-save-folder} and @code{vm-imap-synchronize} operations. In order to work while disconnected from the network, set the variable to @code{offline}. In this mode, @code{vm-save-folder} writes any changes made to the folder to the local copy on disk (the ``cache'' folder); @code{vm-visit-imap-folder} likewise visits the cache folder. You can set @code{vm-imap-connection-mode} to @code{autoconnect} if you have intermittent problems with the network. In this mode, doing @code{vm-get-new-mail} attempts to connect to the network. If it succeeds then @code{vm-imap-connection-mode} turns into @code{online}. When the @acronym{IMAP} server is connected again, you should run @kbd{C-u M-x vm-imap-synchronize}, i.e., call it with a @emph{prefix argument}. This causes @emph{all} the message attributes and labels to be written to the server, since it may not be known which of them have actually changed during the offline operation. Similarly, @emph{all} the messages that may have been expunged in the cache folder are expunged on the server. @anchor{@acronym{UIDVALIDITY}} @unnumberedsubsec @acronym{UIDVALIDITY} @cindex @acronym{UIDVALIDITY} Messages on an @acronym{IMAP} server have unique id numbers called UID's. In addition, a second id number called @dfn{@acronym{UIDVALIDITY}} allows the server to renumber messages when the id numbers within a particular @acronym{UIDVALIDITY} are exhausted. All the messages on the server at any given time have the same @acronym{UIDVALIDITY} value. When the server needs to renumber the messages, it changes the @acronym{UIDVALIDITY} value and issues new @acronym{UID} numbers for all the messages with new @acronym{UIDVALIDITY}. This happens but rarely because there are over two billion UID's within each @acronym{UIDVALIDITY}. When the @acronym{UIDVALIDITY} changes on the @acronym{IMAP} server, VM has no easy way to identify the new UID's for the messages in its cache. So, it marks all the messages in the cache as invalid and refreshes the cache with new copies of messages from the server. This is a time-consuming operation but it happens only rarely. VM warns you before it refreshes the cache and asks for confirmation. You can abort the operation if you cannot spare the time, but note that it is not possible to perform any changes to the @acronym{IMAP} folder until the cache is refreshed. You might consider setting the @code{vm-enable-external-messages} flag to @code{(imap)} before you refresh the cache so that it will be quicker. @pxref{External Messages}. @unnumberedsubsec Operations for the IMAP server @cindex vm-list-imap-folders The command @code{vm-list-imap-folders} lists the folders available on the @acronym{IMAP} server, along with the total number of messages and recent (new) messages in each of them. If you run it with a prefix argument, it lists only those folders that have new messages. @cindex vm-create-imap-folder @cindex vm-delete-imap-folder @cindex vm-rename-imap-folder Use the command @code{vm-create-imap-folder} for creating a new folder on the @acronym{IMAP} server and @code{vm-delete-imap-folder} for deleting an existing folder. You can rename a folder using @code{vm-rename-imap-folder}. @node Frames and Windows, Toolbar, @acronym{IMAP} Server Folders, Top @chapter Frames and Windows VM uses Emacs frames and windows to display messages and summaries and to provide a place for you to compose messages. Using VM's frame configuration facilities you can control when VM creates new frames and the size and attributes associated with new frames. Inside each frame you can associate different window setups with commands and classes of commands by using VM's window configuration facilities. @vindex vm-mutable-frame-configuration @vindex vm-mutable-frames To use VM's frame configuration features, the variable @code{vm-mutable-frame-configuration} must be set non-@code{nil}. This is the default. If @code{vm-mutable-frame-configuration} is set to @code{nil} VM will only use the current frame, and VM will not create, delete or resize frames. (This variable was called @code{vm-mutable-frames} in versions prior to 8.2.) @vindex vm-mutable-window-configuration @vindex vm-mutable-windows To use window configurations, the variable @code{vm-mutable-window-configuration} must be set non-@code{nil}. If @code{vm-mutable-window-configuration} is set to @code{nil}, VM will only use the selected window, and will not create, delete or resize windows. (This variable was called @code{vm-mutable-windows} in versions prior to 8.2.) @menu * Frame Configuration:: How to configure frame use and appearance. * Window Configuration:: How to configure window use and appearance. @end menu @node Frame Configuration, Window Configuration, Frames and Windows, Frames and Windows @section Frame Configuration VM has a set of variables that let you specify when VM creates frames and what attributes the new frames will have. @vindex vm-frame-per-folder If @code{vm-frame-per-folder} is set non-@code{nil}, when you visit a folder, VM will create a new frame and display that folder in the new frame. When you quit the folder, VM will delete the frame. @vindex vm-frame-per-summary If @code{vm-frame-per-summary} is set non-@code{nil}, the @code{vm-summarize} command will create a new frame in which to display a folder's summary buffer. This works best if a full-screen window configuration has been assigned to the @code{vm-summarize} command. When you quit the folder or kill the summary, VM will delete the frame. @vindex vm-frame-per-composition Setting @code{vm-frame-per-composition} non-@code{nil} causes VM to create a new frame for the composition buffer when you run any of VM's message composition commands. E.g. @code{vm-reply-include-text}, @code{vm-mail}, @code{vm-forward-message}. When you finish editing the composition and send it, or when you kill the composition buffer, the frame will be deleted. @vindex vm-frame-per-edit The variable @code{vm-frame-per-edit}, if non-@code{nil}, tells VM to create a new frame when the vm-edit-message command is run. When you finish editing the message, or abort the edit, the frame will be deleted. @vindex vm-frame-per-help If @code{vm-frame-per-help} is set non-@code{nil}, VM will create a new frame to display any help buffer produced by the vm-help command. @vindex vm-frame-per-completion If @code{vm-frame-per-completion} is set non-@code{nil}, VM will create a new frame on mouse initiated completing reads. A mouse initiated completing read occurs when you invoke a VM command using the mouse, either with a menu or a toolbar button. That command must then prompt you for information, and there must be a limited set of valid responses. If these conditions are met and @code{vm-frame-per-completion}'s value is non-@code{nil}, VM will create a new frame containing a list of responses that you can select with the mouse. @vindex vm-search-other-frames When VM is deciding whether to create a new frame, it checks other existing frames to see if a buffer that it wants to display in a frame is already being displayed somewhere. If so, then VM will not create a new frame. If you don't want VM to search other frames, set the variable @code{vm-search-other-frames} to @code{nil}. VM will still search the currently selected frame and will not create a new frame if the buffer that it wants to display is visible there. @vindex vm-frame-parameter-alist The variable @code{vm-frame-parameter-alist} allows you to specify the frame parameters for newly created frames. The value of @code{vm-frame-parameter-alist} should be of this form @example ((@var{SYMBOL} @var{PARAMLIST}) (@var{SYMBOL2} @var{PARAMLIST2}) ...) @end example @var{SYMBOL} must be one of ``completion'', ``composition'', ``edit'', ``folder'', ``primary-folder'' or ``summary''. It specifies the type of frame that the following @var{PARAMLIST} applies to. @table @code @item completion specifies parameters for frames that display lists of choices generated by a mouse-initiated completing read. (See @code{vm-frame-per-completion}.) @item composition specifies parameters for mail composition frames. @item edit specifies parameters for message edit frames (e.g. created by @code{vm-edit-message-other-frame}) @item folder specifies parameters for frames created by `vm' and the @code{vm-visit-} commands. @item primary-folder specifies parameters for the frame created by running @code{vm} without any arguments. @item summary specifies parameters for frames that display a summary buffer (e.g. created by @code{vm-summarize-other-frame}) @end table @var{PARAMLIST} is a list of pairs as described in the documentation for the function @code{make-frame}. @node Window Configuration,, Frame Configuration, Frames and Windows @section Window Configuration @findex vm-save-window-configuration @kindex W S Window configurations allow you to specify how the windows within a frame should look for a particular command or class of commands. Each command can have a configuration associated with it and you can also associate a configuration with command classes like ``reading-message'' or ``composing-message''. To setup a window configuration, first use Emacs' window management commands (@code{split-window}, @code{enlarge-window}, etc.) to make the windows in the frame look the way you want. Then use the switch-to-buffer command to put the buffers you want to see into the windows. Next type @kbd{W S}, which invokes the @code{vm-save-window-configuration} command. Type the name of the command or class of commands to which you want the configuration to apply. Nearly all VM commands can be entered here. Valid classes are: @display default startup quitting reading-message composing-message marking-message searching-message @end display When a VM command is executed, window configurations are searched for as follows. First, a command specific configuration is searched for. If one is found, it is used. Next a class configuration is searched for. Not all commands are in command classes. Message composition commands are in the ``composing-message'' class. All the @code{vm-quit*} commands are in the ``quitting'' class. All the VM commands that set and clear message marks are in the ``marking-message'' class, and so on. If such a class configuration is found it is used. If no matching class configuration is found, the ``default'' class configuration is used, if it is defined. Note that when a window configuration is saved the selected window at that time will be the selected window when that window configuration is used. So if you prefer for the cursor to be in a particular window, make sure you invoke @code{vm-save-window-configuration} window from that window. Remember that you can invoke the command with @kbd{M-x} if VM's normal key map is not in effect. @kindex W D @findex vm-delete-window-configuration To delete a window configuration, use @kbd{W D} which is bound to @code{vm-delete-window-configuration}. You will be prompted for the name of the configuration to delete. @kindex W W @findex vm-apply-window-configuration To see what an existing configuration looks like, type @kbd{W W} which invokes @code{vm-apply-window-configuration}. @vindex vm-window-configuration-file @cindex .vm.windows VM saves information about your window configurations in the file named by the variable @code{vm-window-configuration-file}. The default location of the configuration file is @file{"~/.vm.windows"}. Do not make @code{vm-window-configuration-file} point to the same location as @code{vm-init-file}, as the window configuration save commands will then overwrite the content of your init file. @node Toolbar, Menus, Frames and Windows, Top @chapter Toolbar VM can display a toolbar that allows you to run VM commands with a single mouse click. By default the toolbar is displayed on the left of the Emacs frame and is only visible if you're running under a window system like X Windows or Microsoft Windows. @vindex vm-use-toolbar To make VM not display the toolbar, set @code{vm-use-toolbar} to nil. To configure what buttons are displayed on the toolbar, you must change the value of @code{vm-use-toolbar}. If non-@code{nil}, the value of @code{vm-use-toolbar} should be a list of symbols and integers, which specify which buttons appear on the toolbar and the layout of the buttons. These are the allowed symbols along with the buttons they represent. @table @code @item autofile The AutoFile button. Clicking on this button runs the command @code{vm-toolbar-autofile-message}. This command will save the current message into the folder matched by @code{vm-auto-folder-alist}, if there is a match. @item compose The Compose button. Clicking on this button runs the command @code{vm-toolbar-compose-command}. This command is normally just an alias for the @code{vm-mail} command. If you want the Compose button to do something else, redefine @code{vm-toolbar-compose-command} using either @code{fset} or @code{defun}. @item delete/undelete The Delete/Undelete button. If the current message is marked for deletion, this button displays as an Undelete button. Otherwise it displays as a Delete button. @item file The File button. Clicking on this button runs the command @code{vm-toolbar-file-command}. This command is normally just an alias for the @code{vm-mail} command. If you want the File button to do something else, redefine @code{vm-toolbar-file-command} using either @code{fset} or @code{defun}. @item getmail The Get Mail button. Clicking on this button runs the command @code{vm-toolbar-getmail-command}. This command is normally just an alias for the @code{vm-get-new-mail} command. If you want the Get Mail button to do something else, redefine @code{vm-toolbar-getmail-command} using either @code{fset} or @code{defun}. @item help The Helper button. Clicking on this button runs the command @code{vm-toolbar-helper-command}. This command normally just runs @code{vm-help}, but it also does context specific things under certain conditions. If the current message is a @acronym{MIME} message that needs decoding, the Helper button becomes the Decode @acronym{MIME} button. If the current folder has an auto-save file that appears to be the result of an Emacs or system crash, the Helper button becomes the Recover button. Clicking on the Recover button runs @code{vm-recover-folder}, so you can recover your folder from an existing auto-save file. @item mime The Decode @acronym{MIME} button. Clicking on this button runs the command @code{vm-toolbar-mime-command}. This command is normally just an alias for the @code{vm-decode-mime-message} command. @item next The Next button. Clicking on this button runs the command @code{vm-toolbar-next-command}. This command is normally just an alias for the @code{vm-next-message} command. If you want the Next button to do something else, redefine @code{vm-toolbar-next-command} using either @code{fset} or @code{defun}. @item previous The Previous button. Clicking on this button runs the command @code{vm-toolbar-previous-command}. This command is normally just an alias for the @code{vm-previous-message} command. If you want the Previous button to do something else, redefine @code{vm-toolbar-previous-command} using either @code{fset} or @code{defun}. @item print The Print button. Clicking on this button runs the command @code{vm-toolbar-print-command}. This command is normally just an alias for the @code{vm-print-message} command. If you want the Print button to do something else, redefine @code{vm-toolbar-print-command} using either @code{fset} or @code{defun}. @item quit The Quit button. Clicking on this button runs the command @code{vm-toolbar-quit-command}. This command is normally just an alias for the @code{vm-quit} command. If you want the Quit button to do something else, redefine @code{vm-toolbar-quit-command} using either @code{fset} or @code{defun}. @item reply The Reply button. Clicking on this button runs the command @code{vm-toolbar-reply-command}. This command is normally just an alias for the @code{vm-reply-include-text} command. If you want the Reply button to do something else, redefine @code{vm-toolbar-reply-command} using either @code{fset} or @code{defun}. @item visit The Visit button. Clicking on this button runs the command @code{vm-toolbar-visit-command}. This command is normally just an alias for the @code{vm-visit-folder} command. If you want the Visit button to do something else, redefine @code{vm-toolbar-visit-command} using either @code{fset} or @code{defun}. @item nil If nil appears in the list, it must appear exactly once. The buttons associated with symbols that appear after nil in the list will be display flushright for top and bottom toolbars, and flushbottom for left and right toolbars. @end table If an positive integer appears in the the @code{vm-use-toolbar} list, it specifies the number of pixels of blank space to display between the button that comes before and the button that comes after the integer. @vindex vm-toolbar-orientation The variable @code{vm-toolbar-orientation} controls on which side of the frame the toolbar is displayed. E.g. @example (setq vm-toolbar-orientation 'top) @end example @noindent causes the toolbar to be displayed at the top of the frame. The @code{top} in the example can be replaced with @code{bottom}, @code{right} and @code{left} to make the toolbar appear in those places instead. @vindex vm-toolbar-pixmap-directory VM finds the images for the toolbar in the directory specified by @code{vm-toolbar-pixmap-directory}. This variable should already be set properly by whoever installed VM on your system, so you should not need to set it. @node Menus, Faces, Toolbar, Top @chapter Menus @vindex vm-popup-menu-on-mouse-3 @cindex menu bar @cindex menus, pop-up VM uses Emacs' menu bar and pop-up menus whenever they are available using which you can readily access VM's commands. By default, VM puts a context-sensitive pop-up menu on mouse button 3 (usually the rightmost mouse button). If you don't want this menu, set the variable @code{vm-popup-menu-on-mouse-3} to nil. @vindex vm-use-menus If you set @code{vm-use-menus} to nil, VM will not generate a menu bar for VM folder buffers and VM won't use pop-up menus either. If you set @code{vm-use-menus} to @samp{1}, VM will add a single @samp{VM} menu to the existing menu bar and provide various submenus under it for the VM operations. By default, @code{vm-use-menus} is set to a list of symbols indicating which menus should appear in the menu bar. These menus will replace the standard Emacs menus whenever VM folder are being viewed. You can switch to the Emacs menu bar when necessary by clicking on the menu labelled @code{[Emacs]} (on some systems, thre will be a drop-down menu labelled @code{Emacs}). From the Emacs menu bar, you can return to the VM menu bar by clicking on the menu labelled @code{[VM]} (or under the drop-down menu labelled @code{VM}). @cindex graphics toolkit On some graphics toolkits, menu bar cannot have ``buttons'' that invoke immediate actions (such as @code{[Emacs]}). VM knows about some of those toolkits and automatically uses drop-down menus instead of buttons. If your system shows buttons but they are not operational, then you should set @code{vm-use-menubar-buttons} to nil in your init file. That will cause VM use to drop-down menus instead of buttons on the menu bar. The available menus for the VM menubar are the following: @table @code @item dispose This is menu of commands that are commonly used to dispose of a message. E.g. reply, print, save, delete. @item emacs This provides a menu button labelled @code{[Emacs]} that causes the menu bar to change to the global Emacs menu bar. On that menu bar you will find a @code{[VM]} button that can return you to the VM menu bar. @item folder This is a menu of folder related commands. You can visit a folder, save a folder, quit a folder and so on. @item help This is a menu of commands that provide information for you if you don't know what to do next. @item label This is a menu of commands that let you add and remove message labels from messages. @item mark This is a menu of commands that you can use to mark and unmark messages based on various criteria. @xref{Marking Messages}. @item motion This is a menu of commands to move around inside messages and inside folders. @item send This is a menu of commands you use to compose and send messages. @item sort This is a menu of commands to sort a folder by various criteria. @item undo This provides a menu button that invokes the @code{vm-undo} command. @item virtual This is a menu of commands that let you visit and create virtual folders. @item nil If nil appears in the list, it should appear exactly once. All menus after nil in the list will be displayed flushright in the menu bar. @end table @node Faces, Using the Mouse, Menus, Top @chapter Faces VM uses Emacs faces to emphasize text in the folder and summary buffers. In addition to using the predefined faces of Emacs, VM also defines several faces of its own. You can do @code{M-x list-faces} inside Emacs to see what faces have been defined. You can also define your own faces using Emacs primitives for doing so. @xref{Faces,,,emacs, the GNU Emacs Manual}. @vindex vm-highlighted-header-regexp @vindex vm-highlighted-header-face In the folder or presentation buffer, the header contents of headers matched by the @code{vm-highlighted-header-regexp} variable are displayed using the face named by @code{vm-highlighted-header-face}. This variable is ignored under XEmacs if @code{vm-use-lucid-highlighting} is non-@code{nil}. The XEmacs @code{highlight-headers} package is used instead. See the documentation for the function @code{highlight-headers} to find out how to customize header highlighting using this package. @cindex @acronym{URL} @vindex vm-highlight-url-face @vindex vm-url-search-limit URL's that occur in message bodies are displayed using the face named by @code{vm-highlight-url-face}. Typing Return on such URL's or clicking button-2 has the effect of sending the @acronym{URL} to an external web browser. @xref{Using the Mouse}. Searching for @acronym{URL}s in a large message can take a long time. Since @acronym{URL}s often occur near the beginning and near the end of messages, VM offers a way to search just those parts of a message for @acronym{URL}s. The variable @code{vm-url-search-limit} specifies how much of a message to search. If @code{vm-url-search-limit} has a positive numeric value @var{N}, VM will search the first @math{@var{N} / 2} characters and the last @math{@var{N} / 2} characters in the message for @acronym{URL}s. @vindex vm-mime-button-face The face named by @code{vm-mime-button-face} is used to display the textual buttons that trigger the display of @acronym{MIME} objects. @xref{Summary Faces}, for the faces support in the Summary buffer. @node Using the Mouse, Hooks, Faces, Top @chapter Using the Mouse VM uses the following layout for the mouse buttons in the folder and summary buffers. @table @asis @item button-1 (left button usually) Unchanged. @cindex @acronym{URL} @item button-2 (middle button usually) Activate. If you click on a summary entry, that message will be selected and become the current message. If you click on a highlighted @acronym{URL} in the body of a message, that @acronym{URL} will be sent to the browser specified by @code{vm-url-browser}. @item button-3 (right button usually) Context Menu. If the mouse pointer is over the contents of the From header, button-3 pops up a menu of actions that can be taken using the author of the message as a parameter. For instance, you may want to create a virtual folder containing all the messages in the current folder written by this author. If the mouse pointer is over the contents of the Subject header, a menu of actions to be performed on the current message's subject is produced. If button-3 is clicked over a highlighted @acronym{URL}, a menu of Web browsers is produced. Otherwise the normal VM mode specific menu is produced. @end table @cindex w3m @cindex @acronym{HTML} These button assignments work only in plain text messages. For @acronym{HTML} messages, you might use an internal web browser such as w3m to display the content, which will have its own button assignments. For instance, w3m binds button-2 to the browser function specified by the variable @code{w3m-goto-article-function}. You will need to set that variable to the desired browser function to get button-2 to work in @acronym{HTML} messages. In mail composition buffers only mouse button-3 is affected. Context sensitive menus are produced when that button is clicked. @findex vm-mouse-send-url-to-netscape @findex vm-mouse-send-url-to-xxx @findex vm-mouse-send-url-to-xxx-new-window @findex browse-url @cindex browse-url @cindex web browser VM provides a number of browser functions that you can set as the value of @code{vm-url-browser}. An example is the function @code{vm-mouse-send-url-to-netscape}, which sends the @acronym{URL} at mouse to the Netscape browser. Other browsers supported in this way include @code{mosaic}, @code{mmosaic}, @code{opera}, @code{mozilla}, @code{firefox}, and @code{konqueror}, all of which have functions of the form @code{vm-mouse-send-url-to-xxx} and @code{vm-mouse-send-url-to-xxx-new-window}. You can also set @code{vm-url-browser} to the Emacs function @code{browse-url}, and use the facilities defined in the @samp{browse-url} library to send URL's to external browsers. @node Hooks, Preface to Add-ons, Using the Mouse, Top @chapter Hooks VM has many hook variables that allow you to run functions when certain events occur. Here is a list of the hooks and when they are run. (If you don't write Emacs-Lisp programs you can skip this chapter.) @table @code @vindex vm-select-new-message-hook @item vm-select-new-message-hook List of hook functions called every time a message with the ``new'' attribute is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max). @item vm-select-unread-message-hook @vindex vm-select-unread-message-hook List of hook functions called every time a message with the ``unread'' attribute is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max). @item vm-select-message-hook @vindex vm-select-message-hook List of hook functions called every time a message is made to be the current message. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max). @item vm-save-message-hook @vindex vm-save-message-hook List of hook fucntions called every time a message is saved to a folder. When the hooks are called, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max). The hooks are calle with one argument, a string denoting the folder where the message was saved. The folder could be a file name or the maildrop specification of an @acronym{IMAP} mailbox. @item vm-arrived-message-hook @vindex vm-arrived-message-hook List of hook functions called once for each message gathered from the system mail spool, or from another folder with @code{vm-get-new-mail}, or from a digest with @code{vm-burst-digest}. When the hooks are run, the current buffer will be the folder containing the message and the start and end of the message will be bracketed by (point-min) and (point-max). @item vm-spooled-mail-waiting-hook @vindex vm-spooled-mail-waiting-hook List of functions called when VM first notices mail is spooled for a folder. The folder buffer will be current when the hooks are run. @item vm-arrived-messages-hook @findex vm-get-new-mail @vindex vm-arrived-messages-hook List of hook functions called after VM has gathered a group of messages from the system mail spool, or from another folder with @code{vm-get-new-mail}, or from a digest with @code{vm-burst-digest}. When the hooks are run, the new messages will have already been added to the message list but may not yet appear in the summary. When the hooks are run the current buffer will be the folder containing the messages. @item vm-reply-hook @vindex vm-reply-hook List of hook functions to be run after a Mail mode composition buffer has been created for a reply. VM runs this hook and then runs @code{vm-mail-mode-hook} before leaving you in the Mail mode buffer. @item vm-forward-message-hook @vindex vm-forward-message-hook List of hook functions to be run after a Mail mode composition buffer has been created to forward a message. VM runs this hook and then runs @code{vm-mail-mode-hook} before leaving the user in the Mail mode buffer. @item vm-resend-bounced-message-hook @vindex vm-resend-bounced-message-hook List of hook functions to be run after a Mail mode composition buffer has been created to resend a bounced message. VM runs this hook and then runs @code{vm-mail-mode-hook} before leaving you in the Mail mode buffer. @item vm-resend-message-hook @vindex vm-resend-message-hook List of hook functions to be run after a Mail mode composition buffer has been created to resend a message. VM runs this hook and then runs @code{vm-mail-mode-hook} before leaving you in the Mail mode buffer. @item vm-send-digest-hook @vindex vm-send-digest-hook List of hook functions to be run after a Mail mode composition buffer has been created to send a digest. VM runs this hook and then runs @code{m-mail-mode-hook} before leaving you in the Mail mode buffer. @item vm-mail-hook @vindex vm-mail-hook List of hook functions to be run after a Mail mode composition buffer has been created to send a non specialized message, i.e. a message that is not a reply, forward, digest, etc. VM runs this hook and then runs @code{vm-mail-mode-hook} before leaving you in the Mail mode buffer. @item vm-summary-update-hook @vindex vm-summary-update-hook List of hook functions called just after VM updates an existing entry in a folder summary buffer. @item vm-summary-redo-hook @vindex vm-summary-redo-hook List of hook functions called just after VM adds or deletes entries from a folder summary buffer. @item vm-visit-folder-hook @vindex vm-visit-folder-hook List of hook functions called just after VM visits a folder. It doesn't matter if the folder buffer already exists, this hook is run each time @code{vm} or @code{vm-visit-folder} is called interactively. It is @emph{not} run after @code{vm-mode} is called. @item vm-retrieved-spooled-mail-hook @vindex vm-retrieved-spooled-mail-hook List of hook functions called just after VM has retrieved a group of messages from your system mailbox(es). When these hooks are run, the messages have been added to the folder buffer but not the message list or summary. When the hooks are run, the current buffer will be the folder where the messages were incorporated. @item vm-edit-message-hook @vindex vm-edit-message-hook List of hook functions to be run just before a message is edited. This is the last thing @code{vm-edit-message} does before leaving you in the edit buffer. @item vm-mail-mode-hook @vindex vm-mail-mode-hook List of hook functions to be run after a Mail mode composition buffer has been created. This is the last thing VM does before leaving you in the Mail mode buffer. @item vm-mode-hook @vindex vm-mode-hook List of hook functions to run when a buffer enters @code{vm-mode}. These hook functions should generally be used to set key bindings and local variables. @item vm-mode-hooks @vindex vm-mode-hooks Old name for @code{vm-mode-hook}. Supported for backward compatibility. You should use the new name. @item vm-summary-mode-hook @vindex vm-summary-mode-hook List of hook functions to run when a VM summary buffer is created. The current buffer will be that buffer when the hooks are run. @item vm-summary-mode-hooks @vindex vm-summary-mode-hooks Old name for @code{vm-summary-mode-hook}. Supported for backward compatibility. You should use the new name. @item vm-virtual-mode-hook @vindex vm-virtual-mode-hook List of hook functions to run when a VM virtual folder buffer is created. The current buffer will be that buffer when the hooks are run. @item vm-presentation-mode-hook @vindex vm-presentation-mode-hook List of hook functions to run when a VM presentation buffer is created. The current buffer will be the new presentation buffer when the hooks are run. Presentation buffers are used to display messages when some type of decoding must be done to the message to make it presentable. E.g. @acronym{MIME} decoding. @item vm-quit-hook @vindex vm-quit-hook List of hook functions to run when you quit VM. This applies to all VM quit commands, including @code{vm-quit-no-change}. So you should not include in this hook any functions that alter the folder. For automatically expunging deleted messages, set the variable @code{vm-expunge-before-quit}. @item vm-summary-pointer-update-hook @vindex vm-summary-pointer-update-hook List of hook functions to run when the VM summary pointer is updated. When the hooks are run, the current buffer will be the summary buffer. @item vm-display-buffer-hook @vindex vm-display-buffer-hook List of hook functions that are run every time VM wants to display a buffer. When the hooks are run, the current buffer will be the buffer that VM wants to display. The hooks are expected to select a window and VM will display the buffer in that window. If you use display hooks, you should not use VM's built-in window configuration system as the result is likely to be confusing. @item vm-undisplay-buffer-hook @vindex vm-undisplay-buffer-hook List of hook functions that are run every time VM wants to remove a buffer from the display. When the hooks are run, the current buffer will be the buffer that VM wants to disappear. The hooks are expected to do the work of removing the buffer from the display. The hook functions should not kill the buffer. If you use undisplay hooks, you should not use VM's built-in window configuration system as the result is likely to be confusing. @item vm-iconify-frame-hook @vindex vm-iconify-frame-hook List of hook functions that are run whenever VM iconifies a frame. @item vm-menu-setup-hook @vindex vm-menu-setup-hook List of hook functions that are run just after all menus are initialized. @item vm-mime-display-function @vindex vm-mime-display-function If non-@code{nil}, this should name a function to be called inside @code{vm-decode-mime-message} to do the @acronym{MIME} display of the current message. The function is called with no arguments, and at the time of the call the current buffer will be the @dfn{presentation buffer} for the folder, which is a temporary buffer that VM uses for the display of @acronym{MIME} messages. A copy of the current message will be in the presentation buffer at that time. The normal work that @code{vm-decode-mime-message} would do is not done, because this function is expected to subsume all of it. @item vm-mail-send-hook @vindex vm-mail-send-hook List of hook functions to call just before sending a message. The hooks are run after confirming that you want to send the message (see @code{vm-confirm-mail-send} but before @acronym{MIME} encoding and FCC processing. @item mail-yank-hooks @vindex mail-yank-hooks Hooks called after a message is yanked into a mail composition buffer. (This hook is deprecated, you should use mail-citation-hook instead.) The value of this hook is a list of functions to be run. Each hook function can find the newly yanked message between point and mark. Each hook function should return with point and mark around the yanked message. See the documentation for @code{vm-yank-message} to see when VM will run these hooks. @item mail-citation-hook @vindex mail-citation-hook Hook for modifying a citation just inserted in the mail buffer. Each hook function can find the citation between (point) and (mark t). And each hook function should leave point and mark around the citation text as modified. If this hook is entirely empty, i.e. @code{nil}, a default action is taken instead of no action. @end table @node Preface to Add-ons, Customizations, Hooks, Top @unnumbered What are Add-ons? Over the years, a number of users have contributed various functions and packages adding features and customizations to VM. Many of them have been collected and included in the standard VM distribution. Some of the packages have their own manuals. For example, the ``VM Personality Crisis'' package has a manual, @xref{top,,,VM-Pcrisis, Personality Crisis for VM}. Most others have never been documented. This part of the manual is an effort to provide some rudimentary documentation for these add-ons. The add-ons are classified into: @itemize @item Customizations. Small functions or settings that can be tagged on top of VM to make it easier to use, either in general or in particular environments. @item Add-ons. More elaborate features. @item Packages. Full-blown packages that add new functionality or interface to other packages in your environment. @end itemize @node Customizations, Add-ons, Preface to Add-ons, Top @chapter Customizations Useful ways to customize VM. @section Reading messages @unnumberedsubsubsec Shrunken headers @cindex headers, shrunken @vindex vm-enable-addons Some messages come with huge lists of recipients and one has to page through them before getting to the actual content of the message. The @dfn{shrunken headers} feature, included in @code{vm-rfaddons}, addresses this problem. To use the feature, you must add @code{shrunken-headers} to the variable @code{vm-enable-addons} in your VM init file: @example (setq vm-enable-addons (cons 'shrunken-headers vm-enable-addons)) @end example @noindent The add-on abbreviates all the message headers to single lines, and adds a button at the end. You can click the button to expand the header to its full length. The function @code{vm-shrunken-headers-toggle} can be used to expand or collapse all the headers of a message. You might bind this to a key, if you use it often. (This add-on was provided by Robert Fenk.) @unnumberedsubsubsec @acronym{MIME} alternatives @cindex @acronym{MIME} alternatives The default setting of VM for handling @acronym{MIME} alternatives is @code{best-internal}, which means the best alternative that can be displayed internally in VM is chosen. Many users have environments where only @code{text/plain} parts can be displayed internally. However, some messages come with @code{text/html} parts that are expected to be more faithful to the sender's composition. On occasion, you might wish to see the @code{text/html} part even if it has to be viewed externally. @cindex @acronym{MIME} alternative, best @cindex @acronym{MIME} alternative, best-internal @findex vm-toggle-best-mime The function @code{vm-toggle-best-mime} function, included in @code{vm-rfaddons}, allows you to change VM's selection method to @code{best} temporarily so that you can view the @code{text/html} part. You can use the same function to change the method back to @code{best-internal}. (Thanks to Alley Stoughton for this contribution.) @section Saving messages and attachments @unnumberedsubsubsec Auto saving attachments Messages with attachments get bulky and increase the size of VM folders, slowing down VM. The functions @code{vm-save-all-attachments} and @code{vm-save-attachments} provide ways to save attachments of messages on the file system and deleting them from the mail folders. @findex vm-mime-auto-save-all-attachments @vindex vm-mime-auto-save-all-attachments-subdir The function @code{vm-mime-auto-save-all-attachments}, included in @code{vm-rfaddons}, provides enhanced functionality for saving attachments. It saves the attachments in a subdirectory of @code{vm-mime-save-attachment-save-directory}, whose name is obtained by concating the ``from'', ``subject'' and ``date'' headers of the message. This can be customized via the variable @code{vm-mime-auto-save-all-attachments-subdir}. You can save the attachments of all new messages automatically by putting @code{vm-mime-auto-save-all-attachments} in @code{vm-select-new-message-hook}. (This add-on was provided by Robert Fenk.) @section Printing messages @node Add-ons, History and Administration, Customizations, Top @chapter Add-ons @section Postponing message composition @cindex vm-pine @cindex postponing message composition Sometimes, you might want to interrupt the composing of a message and continue it later. This is called @dfn{postponing}. The add-on called @samp{vm-pine} provides this functionality. @findex vm-postpone-composition @kindex C-c C-d @vindex vm-postponed-folder In a message composition buffer, the command @key{C-c C-d} (@code{vm-postpone-composition}) postpones the current composition. The postponed message is stored in the folder specified in @code{vm-postponed-folder}. (The default is a folder called ``postponed''). When called with a prefix argument, @code{vm-postpone-composition} will ask you for the folder to save the draft to. You might also save it to your inbox in this way. @findex vm-continue-postponed-message You can continue composing the postponed messages by visiting @code{vm-postponed-folder}, selecting a message and running @kbd{M-x vm-continue-postponed-message}. This constructs a new message composition buffer by copying the text from the VM Presentation buffer. It also converts any @acronym{MIME} buttons into attachment buttons, which will be encoded as valid @acronym{MIME} attachments when the message is sent. Unfortunately, any attachments that are displayed inline in the Presentation buffer will not be encoded. This is a limitation of this package. (This add-on was provided by Robert Fenk.) @node History and Administration, Highlights, Add-ons, Top @chapter History and Administration @cindex Kyle Jones VM was developed by Kyle Jones, starting in early 1989. The first public release of VM was version 4.10, released in June of that year. The original development environment was GNU Emacs 18.52. @cindex Wonderworks The copyright for the code was retained by Kyle Jones. Hence, the package was never included in GNU releases, which only contain code copyrighted by the Free Software Foundation. However, Lucid/XEmacs shipped VM starting with version 19.9. The other users obtained VM from the Wonderworks web site, which hosted Kyle Jones's work. The home page of VM at this site is @uref{http://www.wonderworks.com/vm}. The last version released by Kyle Jones was 7.19, in September 2004, which can be found on the Wonderworks web site and its mirror sites. @cindex Robert Widhopf-Fenk After this release, Robert Widhopf-Fenk picked up the maintenance of VM, by releasing a series of patches under a separate distribution. He also acquired a number of add-on's contributed by various developers, including himself, and included them in his distribution. Kyle Jones agreed to hand over the maintenance of VM to Robert Fenk in February, 2007. Further releases were made by Robert Fenk under the @code{8.0.x} series. @cindex Savannah All these releases are available from the new project page of VM hosted by Savannah, at the @acronym{URL} @uref{http://savannah.nongnu.org/projects/viewmail/}. According to the project page, ``this site exists to continue VM development after version 7.19 as a community project.'' @cindex Ulrich Müller @cindex Uday S Reddy Currently, VM is maintained by a ``VM Development Team,'' consisting of Robert Widhopf-Fenk, Ulrich Müller and Uday S Reddy. Other potential members are warmly welcomed. Robert Fenk has been inactive since November, 2008 but he continues to be an official member of the team. The new releases made by the team are numbered @code{8.1.0} and up. @cindex Launchpad The project code base is maintained at the Launchpad web site @uref{http://launchpad.net/vm}. The ``VM Development Team'' can be reached here using the email address @email{vm@@lists.launchpad.net}. @unnumberedsubsec Savannah project site The changes made in each of the releases is described in the @samp{NEWS} file, which can be found in the source code repository. The changes made in versions up to 7.19 are described in the @samp{CHANGES} file. The @code{Download} link on the Savannah project page, takes you to the downloads area where all the recent releases are available. Under the @code{Source Code} menu, the @code{Browse Sources Repository} takes you to the source files, which include, among others, the @samp{NEWS} and @samp{CHANGES} files mentioned above. If you have obtained VM through a secondary distribution that does not include all the sources, you can browse and download the sources from the @code{Source Code} menu. The @code{Use Bazaar} entry in the menu takes you to a page that lists various version of VM source code, and gives instructions for downloading it via @samp{Bazaar} (@code{bzr}). @unnumberedsubsec Technical support VM has a dedicated usenet newsgroup @code{gnu.emacs.vm.info} and a gmane newsgroup @code{gmane.emacs.viewmail}, in which the developers and the active users participate. This is the first port of call for getting help with VM. The archives of the newsgroup dating back to the very beginning can be found at the Google Groups site @uref{http://groups.google.com/group/gnu.emacs.vm.info/topics}. The discussions can also be accessed by email via a mailing list @uref{viewmail-info}. Please go to the Savannah home page to subscribe to it. The easiest way to report bugs that need fixing is to use the command @code{M-x vm-submit-bug-report} within VM. This prepares an email message by including a state of your VM program which will allow the developers to reproduce your problem. (Potentially sensitive information such as passwords are not included in this state.) Please include a detailed description of the problem and how it arose. The developers may need to ask you for further information or ask you to try alternative approaches to narrow down the problem. The best way to report bugs is via the Launchpad bug tacker. See below. @unnumberedsubsec Get Involved VM is now supported and maintained by the user community. So, as an active user, your participation is key to keep the project going. Consider registering as a user of the Launchpad development site @uref{http://launchpad.net/vm}. This allows you to communicate with the developers and other users using a private Launchpad email address. In particular, you can contribute bug reports and participate in the bug report discussions. You can download the development versions of VM and act as an ``alpha'' tester. This will allow you to shape the new developments and features and make suggestions that will be valuable to the developers. To download the development version, identify the ``branch'' that you would like to download, and use Bazaar version control system with an appropriate Launchpad @acronym{URL}. For example, the command @command{bzr get lp:vm} can be used to download the main development branch. You can also make change to the branch you have downloaded, and submit them to the developers for inclusion in the project. The @code{README} file in the distribution explains how to do this. Alternatively, you can create a separate branch in your own space on the Launchpad web site, and submit your changes to that branch. The developers can review and merge your branch with the main development when your changes are ready. @unnumberedsubsec Contributors Contributions to the code from the following members of the VM community are gratefully acknowledged: @itemize @item Aidan Kehoe @item Glenn @item Jens Gustedt @item John J Foerch @item Kevin Rogers @item Kyle Jones @item Rob Hodges @item Robert Marshall @item Robert P. Goldman @item Katsumi Yamaoka @item Julian Bradfield @item Samuel Bronson @item Brent Goodrick @item Tim Cross @item Arik Mitschang @item Anthony Mallet @item Noah Friedman @end itemize Please let us know if any other contributors have been missed out. @unnumberedsubsec Selected Releases of Kyle Jones @itemize @item Version 4.10, released in 1989. @item Version 5.00, released in 1990. @item Version 6.00, released 6 January, 1997. @item Version 7.00, released 2 December, 2001. @item Version 7.10, released 5 March, 2003. @item Version 7.15, released 3 May, 2003. @item Version 7.16, released 26 May, 2003. @item Version 7.17, released 6 July, 2003. @item Version 7.18, released 2 November, 2003. @item Version 7.19, released 29 September, 2004. @end itemize @unnumberedsubsec Releases of Robert Widhopf-Fenk @itemize @item Version 8.0.0, released 31 May, 2007. @item Version 8.0.1, released 29 June, 2007. @item Version 8.0.2, released 25 July, 2007. @item Version 8.0.3, released 15 August, 2007. @item Version 8.0.4, released 2 November, 2007. @item Version 8.0.5, released 3 November, 2007. @item Version 8.0.6, released 2 January, 2008. @item Version 8.0.7, released 5 January, 2008. @item Version 8.0.8, released 11 February, 2008. @item Version 8.0.9, released 20 February, 2008. @item Version 8.0.10, released 22 June, 2008. @item Version 8.0.11, released 11 August, 2008. @item Version 8.0.12, released 5 November, 2008. @item Version 8.0.13, released 29 November, 2009. @item Version 8.0.14, released 16 December, 2009. @end itemize @unnumberedsubsec Releases of VM development team @itemize @item Version 8.1.0, released 21 March, 2010. @item Version 8.1.1, released 25 April, 2010. @item Version 8.1.2, planned for release in July/August, 2010. @item Version 8.2.0, planned for release in August/September, 2010. @end itemize @node Highlights, Future Plans, History and Administration, Top @chapter Highlights Here are some of the VM features that its users find most valuable: @cindex @acronym{BBDB} @cindex @acronym{IMAP} @cindex @acronym{HTML} @cindex @acronym{MIME} @cindex virtual folders @itemize @item VM's reliability and stability. @item Integration within Emacs, providing ease of editing and familiar key bindings. @item Speed of usage facilitated by keyboard commands. @item Integration with @acronym{BBDB} for maintaining contacts and email addresses. @item VM-Pcrisis for managing multiple mail identities. @item Integration with emacs-w3m for viewing @acronym{HTML} email. @item Comprehensive @acronym{MIME} support. @item Ability to operate on all attachments of a message, such as saving or deleting. @item Interactive virtual folders (created by @code{V C}). @item Support for @acronym{IMAP} folders. @item Ability to delete duplicate copies of messages. @end itemize @node Future Plans, Bugs, Highlights, Top @chapter Future Plans Some of the ideas being worked on for future extensions of VM are the following: @itemize @item Ability to compose rich text email messages (in 'text/enriched' and 'text/html' modes). @item Incremental search in virtual folders. @item Thread-level operations such as killing an entire thread. @item Headers-only downloading of @acronym{IMAP} folders. @item Downloading @acronym{IMAP} messages without attachments. @item Support for maildir folders. @item A message migration/expiration facility. @end itemize @node Bugs, Internals, Future Plans, Top @chapter Reporting Bugs @cindex bug reports VM has a sophisticated bug reporting system in order to provide the VM maintainers with adequate information about the state of VM when the error situation occurred. However, it is still important for the users to give as full an explanation of the problem as possible. @xref{Bugs,,,emacs, the GNU Emacs Manual}. @findex vm-submit-bug-report The command @code{M-x vm-submit-bug-report} should be invoked from the VM folder buffer in which a problem is encountered. This creates a mail buffer with information about the state of VM pre-filled. Insert suitable text to explain the problem and send the bug-report message. @findex vm-pop-start-bug-report @findex vm-pop-submit-bug-report @findex vm-imap-start-bug-report @findex vm-imap-submit-bug-report For mail server-associated problems dealing with @acronym{POP}/@acronym{IMAP} spool files or @acronym{POP}/@acronym{IMAP} folders, the cause of the problem might be in the interaction with the mail server. To identify the cause, it may be necessary for the VM maintainer to look at the server interactions during the problem occurrence. To capture the server interactions, run @code{vm-pop-start-bug-report}/@code{vm-imap-start-bug-report} before the problem occurrence and @code{vm-pop-submit-bug-report} /@code{vm-imap-submit-bug-report} after the problem occurrence. All the server interactions during the interval are captured and automatically included in the bug-report. @node Internals, Concept Index, Bugs, Top @chapter VM Internals This section gives a sketchy overview of the VM internals for the developers/programmers. @menu * Folder Internals:: Structure of the folders * Message Internals:: Structure of the message data structure * Summary Internals:: Details of summary generation * Threading Internals:: Details of message threads handling * Sorting Internals:: Details of how messages are sorted * User Interaction:: Handling of the user interaction * Coding Systems:: How VM handles character coding * @acronym{MIME} Display:: How VM displays @acronym{MIME} messages * @acronym{MIME} Composition:: How @acronym{MIME} messages are composed * Virtual Folder Internals:: Details of virtual folders and selectors * Extents and Overlays:: How VM deals with XEmacs and GNU Emacs differences * Timers and Concurrency:: How VM runs asynchronous timers @end menu @node Folder Internals, Message Internals , , Internals @section Folder Internals @cindex mbox @inindex mbox VM stores mail folders in the Unix @samp{mbox} format (in all its variants). Internal to Emacs, the mbox is loaded into a text buffer (the @dfn{Folder} buffer) and individual messages are identified by remembering markers into the text buffer. @xref{Message Internals}. The Unix @dfn{mbox} format is described in the RFC 4155 specification of the Internet Engineering Task Force. The mail folder is a text file consisting of a sequence of messages, with each message consisting of a series of headers followed by a message body. The beginning of each message is delineated by a separator line starting with the string ``From '' and the end of the message by a blank line. The leading separator line in VM folder is of the form ``From VM ...'' where the ``...'' records the time at which VM first saw the message. The format of the individual messages is as per the RFC 2822 specification, except that Line-Feed characters may be used to delineate the end of lines in the "Unix" format. @vindex vm-folder-type @cindex From_ folder type @cindex BellFrom_ folder type @cindex From_with-Content-Length folder type @cindex System V @inindex vm-folder-type @inindex From_ folder type @inindex BellFrom_ folder type @inindex From_with-Content-Length folder type @inindex System V Three variants of the @code{mbox} format are recognized by VM, called @code{From_}, @code{BellFrom_} and @code{From_with-Content-Length}. In a @code{From_} type mbox, every message has a leading and trailing separator line, as indicated above. In a @code{BellFrom_} type mbox, the trailing separator line can be missing. (This is so that the mbox's from the old System V format can be handled.) In a @code{From_with-Content-Length} type mbox, the @code{From} separator line stores the length of the message. So, no trailing separator line is required. @cindex @acronym{MMDF} format @cindex Babyl format @inindex @acronym{MMDF} format @inindex Babyl format In addition to these mbox formats, VM also handles the @acronym{MMDF} format and the Emacs Rmail's Babyl format. The variable @code{vm-folder-type} stores the type of the folder being used. @inindex X-VM-v5-Data header To every message, VM adds a header with the field name ``X-VM-v5-Data:'' and stores in it the information about the message it wishes to remember between sessions. The first message of the VM folder file contains additional headers used by VM for remembering information between sessions. @itemize @inindex X-VM-Bookmark @item X-VM-Bookmark. This header stores the position of the cursor, as a message number, in effect when VM saved the folder. Upon revisiting the folder, VM attempts to put the cursor back at this position. @item @inindex X-VM-Last-Modified X-VM-Last-Modified. The date and time at which the folder was last modified. @item @inindex X-VM-Message-order X-VM-Message-Order. This header lists the order in which the messages should be listed. @item @inindex X-VM-Labels X-VM-Labels. This header lists the message labels that have been used in the folder. @item @inindex X-VM-VHeader X-VM-VHeader. This header lists the values of @code{vm-visible-headers} and @code{vm-invisible-header-regexp} that were in effect when the folder was saved. The messages in the folder would have their headers arranged according to these variables. @item @inindex X-VM-Summary-Format X-VM-Summary-Format. This header stores the format string for the summary lines. @item @inindex X-VM-@acronym{POP}-Retrieved X-VM-@acronym{POP}-Retrieved. This header lists all the messages that have been retrieved from @acronym{POP} servers together with the identifying information for the @acronym{POP} servers. VM refrains from retrieving these messages again in future in order to avoid duplication. @item @inindex X-VM-@acronym{IMAP}-Retrieved X-VM-@acronym{IMAP}-Retrieved. This header lists messages that have been retrieved from @acronym{IMAP} servers together with their identifying information on the @acronym{IMAP} servers (@acronym{UID} and @acronym{UIDVALIDITY}). VM refrains from retrieving these messages again in future in order to avoid duplication. (For local folders, this lists all the retrieved messages except those known to be expunged on the server. For @acronym{IMAP} folders, it does not list all the retrieved messages because they are normally the same as those on the server. Only the messages locally expunged in the cache folder but not known to be expunged on the server are listed. In the normal cases, the variable is just nil in @acronym{IMAP} folders.) @end itemize @unnumberedsubsubsec Folder variables Internal to Emacs, VM stores the folder as simply a text buffer. However, it remembers a variety of data about the message contents in the buffer through internal variables. @itemize @item @inindex vm-message-list @code{vm-message-list}. A list of message data structures for all the messages in the buffer. @item @inindex vm-folder-type @code{vm-folder-type}. The type of the current folder indicating how the messages are stored: one of 'babyl, 'From_, 'BellFrom_, 'From_-with-Content-Length and 'mmdf. @item @inindex vm-folder-access-method @code{vm-folder-access-method}. The method for accessing the server message store: 'pop for pop-folders and 'imap for imap-folders, and nil for all other folders. @item @inindex vm-folder-access-data @code{vm-folder-access-data}. A vector of data for accessing the server message store. The first two elements of the vector are the maildrop specification for the mail server and a reference to the process connecting to the mail server. For the 'pop access method, that is all there is. But, for the 'imap access method, the vector has 9 other entries detailing various pieces of data about the @acronym{IMAP} server. @item @inindex vm-folder-read-only @code{vm-folder-read-only}. A boolean flag indicating whether the folder is read-only. If so, no modifications are allowed, including attribute changes. However, messages can be fetched from external storage for viewing. @item @inindex vm-virtual-folder-definition @code{vm-virtual-folder-definition}. If the current folder is virtual, then this variable holds the data constituting its definition. @item @inindex vm-real-buffers @code{vm-real-buffers}. If the current folder is virtual, then this variable is a list of all the real folder buffers involved in constructing it. @item @inindex vm-virtual-buffers @code{vm-virtual-buffers}. A list of all the virtual folder buffers that the current buffer is involved in. @item @inindex vm-component-buffers @code{vm-component-buffers}. An a-list containing all the folder buffers (real or virtual) that make up the components of the current virtual folder, and a flag indicating whether those folders were visited as part of visiting the virtual folder. When the virtual folder is closed, all the folders purposely visited will also be closed.. @item @inindex vm-summary-buffer @code{vm-summary-buffer}. The Summary buffer of the folder. (If the Summary buffer gets killed for any reason, the value of this variable becomes , which is unfortunate. Therefore, most interactive commands of VM check for killed Summary buffer and reset this variable to nil in such a case. So, in the middle of code, this variable can be regarded as a valid buffer pointer.) @item @inindex vm-presentation-buffer-handle @code{vm-presentation-buffer-handle}. The message Presentation buffer of the folder. (Same proviso applies as for @code{vm-summary-buffer}.) @item @inindex vm-presentation-buffer @code{vm-presentation-buffer}. This seems to be a copy of the @code{vm-presentation-buffer-handle}. Its purpose is unknown. @end itemize The running state of the folder buffer is represented in a number of buffer-local variables: @itemize @item @inindex vm-message-pointer @code{vm-message-pointer}. A sublist of vm-message-list starting from the current message that the cursor is on. So, the first element of vm-message-pointer is the current message. @item @inindex vm-last-message-pointer @code{vm-last-message-pointer}. Whenever the cursor is moved, the previous value of vm-message-pointer is remembered in this variable. @item @inindex vm-summary-pointer @code{vm-summary-pointer}. The message struct of the message which has the summary pointer in the Summary buffer. @item @inindex vm-fetched-messages @code{vm-fetched-messages}. List of external messages whose bodies were fetched for viewing or other operations. @item @inindex vm-fetched-message-count @inindex vm-fetched-messages @code{vm-fetched-message-count}. The number of messages in @code{vm-fetched-messages}. An attempt is made to keep this below the @code{vm-fetched-message-limit}. @item @inindex vm-mime-decoded @inindex @acronym{MIME} @code{vm-mime-decoded}. The @acronym{MIME} decoding state of the current message display: @code{undecoded} if the message is shown in undecoded plain text form, @code{decoded} if the message is shown decoded, and @code{buttons} if the message is shown as a series of buttons for all its @acronym{MIME} components. The @kbd{D} command cycles through these states. @item @inindex vm-system-state @code{vm-system-state}. The state of VM in a Folder buffer or Presentation buffer: @itemize @item @inindex previewing @code{previewing}. if a message is being previewed. @item @inindex showing @code{showing}. if a full message is being shown. @item @inindex reading @code{reading}. if message reading is in progress. @end itemize @inindex editing A message edit buffer is in state @code{editing}. A message composition buffer may be in one of these states: @itemize @item @inindex forwarding @code{forwarding}. if a message is being forwarded. @item @inindex replying @code{replying}. if a message is being replied to. @item @inindex redistributing @code{redistributing}. if a message is being redistributed. @end itemize @item @inindex vm-spooled-mail-waiting @code{vm-spooled-mail-waiting}. VM periodically checks if there is new mail in the spool files of the current folder and set this flag to t if there is new mail. @item @inindex vm-undo-record-list @code{vm-undo-record-list}. A list of undo records describing the actions to be performed if an undo operation is invoked. Each undo record has an action, the message, if any, to which the action applies, and any arguments needed for the action. @item @inindex vm-undo-record-pointer @code{vm-undo-record-pointer}. A pointer into the @code{vm-undo-record-list} indicating the current position of the undoing cycle. @end itemize @unnumberedsubsubsec vm-folder-access-data The variable @code{vm-folder-access-data} is a vector storing data about the state of the mail server (for @acronym{POP} and @acronym{IMAP} servers). It contains the following items: @itemize @item @code{pop-maildrop-spec} or @code{imap-maildrop-spec}. MAILDROP specification of the server folder. @item @code{pop-process} or @code{imap-process}. The Emacs process being used to communicate with the server for this folder. (Each folder uses a separate process to avoid unwanted interference.) @item @code{imap-uid-validity}. The @acronym{UIDVALIDITY} value of the @acronym{IMAP} folder. @item @code{imap-read-write}. A boolean flag indicating whether the folder is writable. @item @code{imap-can-delete}. A boolean flag indicating whether the folder allows deletions. @item @code{imap-body-peek}. A boolean flag indicating whether the folder allows the @code{BODYPEEK} command of @acronym{IMAP}. @item @code{imap-permanent-flags}. The list of permananet flags that have been stored in the folder. @item @code{imap-mailbox-count}. The number of messages in the folder. @item @code{imap-recent-count}. The number of messages in the folder that are considered ``recent'' by the server. @item @code{imap-retrieved-count}. The number of messages present in the folder when messages were last retrieved. This would have been the value of @code{imap-mailbox-count} at that time. @item @code{imap-uid-list}. The list of UID's and flags of the messages in the folder, using cons cells of the form (msg-num . uid . size . flags list). The cons cells (size . flags list) are shared with @code{imap-flags-obarray} below. @item @code{imap-uid-obarray}. An obarray that binds all the UIDs of messages in the folder to their message sequence numbers. @item @code{imap-flags-obarray}. An obarray that binds all the UIDs of messages in the folder to cons cells of the form (size . flags list). These cons cells are the same as those occurring in the @code{imap-uid-list} field. So, any updates will be shared through both the views. The two obarrays, @code{imap-uid-obarray} and @code{imap-flags-obarray}, bind exactly the same set of UIDs. Jointly, they are referred to as @code{uid-and-flags-data}. The reason for their separation is historical. @end itemize @node Message Internals, Summary Internals, Folder Internals, Internals @section Message Internals The message data structure is a vector containing various pieces of data about the message, some of which is permanent and some that is calculated during a VM session. The data is organized into four sub-vectors: @itemize @item Location data. This data about the location of the various parts of the message in the Folder buffer is calculated after a folder is loaded and parsed. @item Soft data. This vector contains other calculated data about the message that is specific to a VM session. @item Attributes. All the hard-wired message attributes are stored in this vector. @item Cached Data. Calculated data that is cached for each message. @item Mirror Data. Extra data shared by virtual messages if vm-virtual-mirror is non-nil. @end itemize @inindex X-VM-v5-Data The attributes vector and cached data vector are stored in the folder on disk as the @code{X-VM-v5-Data} header of the first message. @subsubheading Location data @anchor{Location data vector} This vector holds the data about the location of the various parts of the message in the folder buffer. Every folder buffer or folder-like buffer (such as a Presentation buffer) has variables that contain message data structures. The location data is normally expected to refer to locations in that very buffer. However, this condition is not actually required. (See below.) @inindex start @itemize @item @code{start}. Marker for the starting position of the message, at which a leading separator line begins. @inindex headers @item @code{headers}. Marker for the position in the buffer where the headers of the message start. @inindex vheaders @item @code{vheaders}. Marker for the position in the buffer where the visible headers of the message start. (The headers are rearranged in such a way that all the visible headers are towards the end of the headers region.) @inindex text @item @code{text}. Marker for the position in the buffer where the text of the message starts. @inindex text-end @item @code{text-end}. Marker for the position in the buffer where the text of the message ends. @inindex end @item @code{end}. Marker for the position in the buffer where the message ends. @end itemize Unfortunately, in the current versions of VM, the folder buffer to which the location data point is not itself part of this vector. This information is inferred from the context (which makes the code brittle). The Folder buffer of the message can be obtained from the soft data vector but the location data could also point to a Presentation buffer. @subsubheading Soft data @anchor{Soft data vector} This vector contains other calculated data about the message that is specific to a VM session. @inindex number @itemize @item @code{number}. The message number as an integer. @inindex padded-number @item @code{padded-number}. The message number as a padded string. @inindex mark @item @code{mark}. Flag that indicates if the message has been marked (via @code{vm-mark-message}). @inindex su-start @item @code{su-start}. The position in the Summary buffer where the summary line of the message starts. @inindex su-end @item @code{su-end}. The position in the Summary buffer where the summary line of the message ends. @inindex real-message-sym @item @code{real-message-sym}. If the message is in a virtual folder, then its corresponding ``real message'' is the underlying message in another folder which is described by a message data structure similar to the current one. The real message data structures are represented by uninterned symbols written as ``<<>>''. This field stores the symbol representing the real message of the current message. If the current message is a real message then this field contains its own symbol. The use of symbols for this purpose avoids the possibility of circular data structures. @inindex mirrored-message-sym @item @code{mirrored-message-sym}. This is similar to the @code{real-message-sym}, except that it points to the message directly mirrored by the current virtual folder message. @inindex reverse-link-sym @item @code{reverse-link-sym}. Reference to the previous message in the message list, also represented by an uninterned symbol written as ``<--''. @inindex message-type @item @code{message-type}. A symbol indicating the type of the message according to its folder type, one of @code{BellFrom_}, @code{From_} and @code{From_-with-Content-Length}. @inindex message-id-number @item @code{message-id-number}. A number that uniquely identifies the message within a VM session. @inindex buffer @item @code{buffer}. The Folder buffer of the message. (Messages in Presentation buffers also have this field set to the corresponding Folder buffer.) @inindex thread-indentation @item @code{thread-indentation}. Indentation level of the message in its message thread. @inindex thread-list @item @code{thread-list}. List of symbols from @code{vm-thread-obarray} that give this message's lineage. @inindex thread-subtree @item @code{thread-subtree}. List of messages that form the subtree under this message in a threaded summary display. @inindex babyl-frob-flag @item @code{babyl-frob-flag}. @inindex saved-virtual-attributes @item saved-virtual-attributes. Saved attributes if the message switched from unmirrored to mirrored. @inindex saved-virtual-mirror-data @item @code{saved-virtual-mirror-data}. Saved mirror data, if the message was switched from unmirrored to mirrored. @inindex virtual-summary @item @code{virtual-summary}. Summary for unmirrored virtual message. @inindex mime-layout @item @code{mime-layout}. @acronym{MIME} layout information; types, ids, positions, etc of all @acronym{MIME} entities. (See below.) @inindex mime-encoded-header-flag @item @code{mime-encoded-header-flag}. Flag that indicates if the headers of the message are @acronym{MIME} encoded. @inindex su-summary-mouse-track-overlay @item @code{su-summary-mouse-track-overlay}. The overlay on the summary of this message used for selection by mouse. @inindex message-access-method @item @code{message-access-method}. The access-method to be used for the message, inherited from its real folder. @end itemize @subsubheading Attributes @anchor{Attributes vector} All the hard-wired message attributes are stored in this vector. They also get saved as part of the @code{X-VM-v5-Data} header field when the folder is saved to disk. @inindex new-flag @itemize @item new-flag. Flag to indicate if the message is ``new''. @inindex unread-flag @item unread-flag. Flag to indicate if the message is unread. @inindex deleted-flag @item deleted-flag. Flag to indicate if the message has been deleted. @inindex filed-flag @item filed-flag. Flag to indicate if the message has been filed. @inindex replied-flag @item replied-flag. Flag to indicate if the message has been replied to. @inindex written-flag @item written-flag. Flag to indicate if the message has been saved. @inindex forwarded-flag @item forwarded-flag. Flag to indicate if the message has been forwarded. @inindex edited-flag @item edited-flag. Flag to indicate if the message has been edited. @inindex redistributed-flag @item redistributed-flag. Flag to indicate if the message has been redistributed. @end itemize @subsubheading Cached Data @anchor{Cached data vector} @cindex cached data @inindex X-VM-v5-Data header The data that is cached for the message and stored on the disk as part of the @code{X-VM-v5-Data} header field. Even though this vector is only supposed to have data that can be calculated from the message itself, the fields pop-uidl, imap-uid and imap-uid-validity form an exception. They are really hard data that cannot be calculated from anything else. Some of the data deals with information from message headers. The header fields can have @acronym{MIME}-encoded words in them. The strings stored in the cached-data vector, however, are @acronym{MIME}-decoded versions of the header fields, but they also have text properties that store the names of the original character sets used in the header fields. This allows the strings to be quickly re-encoded for storage on disk. @inindex byte-count @itemize @item byte-count. The size of the message in bytes. @item weekday, monthday, month, year, hour, zone. Data indicating the date of the message. @inindex full-name @item full-name. The full name of the author of the message. This is a @acronym{MIME}-decoded string with text properties. @inindex from @item from. The email address of the author of the message. This is a @acronym{MIME}-decoded string with text properties. @inindex message-id @item message-id. The unique id of the message. @inindex line-count @item line-count. The number of lines in the message. @inindex subject @item subject. The subject string of the message. This is a @acronym{MIME}-decoded string with text properties. @inindex vheaders-regexp @item vheaders-regexp. A regular expression that can be used to find the start of the visible headers. The headers must have been already ordered so that the visible headers are at the bottom of the headers section. @inindex to @item to. Addresses of the recipients of the message in a comma separated string. This is a @acronym{MIME}-decoded string with text properties. @inindex to-names @item to-names. The full names of the recipients in a comma separated string. Addresses are used if full names are not available. This is a @acronym{MIME}-decoded string with text properties. @inindex month-number @item month-number. Numeric month of the sent date. @inindex sortable-datestring @item sortable-datestring. Date string of the sent date for sorting purposes (or delivery date if @code{vm-sort-messages-by-delivery-date} is set to t). @inindex sortable-subject @item sortable-subject. The subject string for sorting purposes. (Prefixes such as ``re:'' are removed.) This is a @acronym{MIME}-decoded string with text properties. @inindex summary @item summary. A tokenized summary for the message, from which the actual summary line can be quickly calculated. This is a list containing tokens, such as @code{number} and @code{thread-indent}, as well as @acronym{MIME}-decoded strings with text properties. @inindex parent @item parent. The message ID of the parent of the message in its thread. @inindex references @item references. Message IDs listed in the References header of the message. @c @inindex headers-to-be-retrieved @c @item @c headers-to-be-retrieved. Flag that indicates whether the headers of the @c message have not been retrieved from the mail server (for @acronym{POP} or @acronym{IMAP} @c folders). @inindex body-to-be-discarded @item body-to-be-discarded. Flag that indicates whether they body of the message should be discarded before the folder is saved. (This is used in conjunction with the @code{body-to-be-retrieved} below. @inindex body-to-be-retrieved @item body-to-be-retrieved. Flag that indicates whether the body of the message has not been retrieved from the mail server. @inindex pop-uidl @item pop-uidl. The @acronym{UIDL} id of the message on the @acronym{POP} server. @inindex imap-uid @item imap-uid. The @acronym{UID} of the message on the @acronym{IMAP} server. @inindex imap-uid-validity @item imap-uid-validity. The @acronym{UIDVALIDITY} value of the message on the @acronym{IMAP} server. @inindex spam-score @item spam-score. The spam score of the message. @end itemize @subsubheading Mirror Data @anchor{Mirror data vector} Extra data shared by virtual messages if vm-virtual-mirror is non-nil. @inindex edit-buffer @itemize @item edit-buffer. If the message is being edited, this is the buffer being used. @inindex virtual-messages-sym @item virtual-messages-sym. List of virtual messages mirroring the current real message, represented by an uninterned symbol written as ``''. @inindex stuff-flag @item stuff-flag. Flag to indicates if the attribute changes have been ``stuffed'' into the folder buffer. @inindex labels @item labels. List of labels attached to the message. @inindex label-string @item label-string. The string of labels attached to the message. @inindex attribute-modflag @item attribute-modflag. Flag to indicate if the attributes of the message have been modified since the last save. @end itemize @unnumberedsubsec @acronym{MIME} layout @anchor{@acronym{MIME} layout} The @acronym{MIME} layout of a message, stored in the soft data of the message, is in turn a vector containing various pieces of data. Such a vector is used not only for the overall message, but for all its @acronym{MIME} parts and subparts as well. @inindex type @inindex Content-Type @itemize @item @code{type}. A list of strings consisting of the @acronym{MIME} type of the part along with its attributes. This comes from ``Content-Type'' header. The type could be of the form `type/subtype'. Quotation marks are stripped from attribute values. An example is @code{("multipart/mixed" "boundary=----_=_NextPart_001_01AFE588.63E23840")}. @inindex qtype @item @code{qtype}. Like type, but the quotation marks are not stripped. @inindex encoding @inindex Content-Transfer-Encoding @item @code{encoding}. The @acronym{MIME} encoding used for the part. It comes from the ``Content-Transfer-Encoding'' header. @inindex id @inindex Content-ID @item @code{id}. The id obtained from the ``Content-ID'' header of the part. @inindex description @inindex Content-Description @item @code{description}. A description string obtained from the ``Content-Description'' header of the part. @inindex disposition @inindex Content-Disposition @item @code{disposition}. A list of strings obtained from the ``Content-Disposition'' header of the part. Quotation marks are stripped from attribute values. (An example is @code{(``attachment'', ``filename=mydocument.doc'')}.) @inindex qdisposition @item @code{qdisposition}. Like disposition, but the quotation marks are not stripped. @inindex header-start @item @code{header-start}, @code{header-end}, @code{body-start} and @code{body-end}. Markers into the content buffer delineating the headers/body of the @acronym{MIME} part. @inindex parts @item @code{parts}. A list of @acronym{MIME} layouts for the individual subparts of this part. @inindex cache @item @code{cache}. A symbol that is unique to this @acronym{MIME} part. Other data is stored as properties of this symbol: @itemize @inindex vm-mime-display-external-generic @item @code{vm-mime-display-external-generic}. This property stores the id of the process used to externally display the @acronym{MIME} part as well as the name of the temporary file used. @inindex vm-mime-display-internal-image-xxxx @item @code{vm-mime-display-internal-image-xxxx}. This property stores the name of the temporary file where the image is stored. For an image represented as image strips, it actually stores a list with a number of other data items. @inindex vm-image-modified @item @code{vm-image-modified}. This property stores a boolean flag indicating that the image has been modified. @inindex vm-mime-display-internal-audio/basic @item @code{vm-mime-display-internal-audio/basic}. This property stores the name of the temporary file where the audio clip is stored. @inindex vm-message-garbage @item @code{vm-message-garbage}. @end itemize @inindex message-symbol @item @code{message-symbol}. A reference to the message that contains the @acronym{MIME} part. Represented as a symbol (that is, an interned key into a hash table). This is a different symbol from the real-message-sym of the message. @inindex display-error @item @code{display-error}. If the display of a @acronym{MIME} part fails, its error string is stored here. @inindex layout-is-converted @item @code{layout-is-converted}. Flag indicating that @acronym{MIME} type conversion has been performed on this part. @pxref{@acronym{MIME} type conversion}. @inindex unconverted-layout @item @code{unconverted-layout}. If the @acronym{MIME} type conversion has been performed on this part, then this holds the original unconverted layout. @end itemize @unnumberedsubsec Cross-buffer sharing of data @inindex vm-message-list @inindex vm-message-pointer Every Folder buffer has a @code{vm-message-list} and a @code{vm-message-pointer} list containing message data vectors. Every Presentation buffer also uses a @code{vm-message-pointer} list with a single message (the one being presented). The message data vector in the Presentation buffer has its own location data, but @i{shares} all other components with the message in the Folder buffer. This allows the Presentation buffer to, for example, change the attributes of the message without having to switch context to the Folder buffer. Virtual folders, which contain only references to messages in other folders, store just a single message body in the Folder buffer. However, they have message descriptors for all the messages in @code{vm-message-list}. All the message descriptors use the same location data vector, because only one message body can be stored in the Folder buffer, but have separate Soft data vectors. (This allows, for instance, virtual folders to have their own threads, which could in general be different from the threads in the underlying folders.) The other sub-vectors are shared with the underlying real folders. (In particular, the tokenized summary line is the same in the virual folders and their underlying folders.) @node Summary Internals, Threading Internals, Message Internals, Internals @section Summary Internals @inindex vm-summary-line-format @inindex summary line, tokenized @inindex tokenized summary line Generating a summary is quite a time-consuming operation. VM uses a variety of tricks to speed up the generation of summaries. The format of the summary lines is specified in the variable @code{vm-summary-line-format}. The information that needs to go into the summary lines is divided into two classes: @itemize @item Information that is fixed for each message. Examples include the subject, author and other header information. @item Information that is variable during a VM session. Examples include the message number and thread indentation. @end itemize A @emph{tokenized summary line} is a list whose elements can be strings, representing fixed information in a message, and tokens, representing variable information. VM calculates a tokenized summary line for each message and caches it in the cached-data vector. The following forms of tokens are used in tokenized summary lines: @itemize @item @code{number}. Stands for the message number in the linear order of the summary. @item @code{mark}. Stands for an indicator of message mark (whether the message is marked at present). @item @code{thread-indent}. Stands for the indentation to be used for the message's summary depending on its position in the message thread. @item @code{group-begin}, @code{group-end}. Brackets used to denote groups of items that might have particular formatting constraints. @end itemize The function @code{vm-tokenized-summary-insert} converts a tokenized summary line into a string and inserts it in the summary buffer. The minibuffer message ``Generating summary...'' is used to show the progress of generating summary lines from tokenized summaries. Buffer local variables in each Folder buffer responsible for maintaining summary information: @itemize @item @inindex vm-summary-pointer @code{vm-summary-pointer}. The message selected by the cursor in the Summary window. @item @inindex vm-summary-redo-start-point @code{vm-summary-redo-start-point}. A pointer into the @inindex vm-message-list @code{vm-message-list} indicating the first message for which the summary line must be redisplayed. All the messages from here on are assumed to require a summary redisplay. The assumption is usually valid because the message numbers of all the succeeding messages might have changed. But, if message numbers are not included in the summary lines, then this results in unnecessary work. @item @inindex vm-messages-needing-summary-update @code{vm-messages-needing-summary-update}. The list of messages for which summary lines must be redisplayed. Messages are included in this list by calling the function @code{vm-mark-for-summary-update}. @item @inindex vm-numbering-redo-start-point @code{vm-numbering-redo-start-point}. A pointer into @inindex vm-message-list @code{vm-message-list} indicating the first message whose message number needs to be recalculated. @inindex vm-numbering-redo-end-point @code{vm-numbering-redo-end-point}. A pointer into @code{vm-message-list} indicating the last message whose message number needs to be recalculated. @end itemize The beginning and the ending positions of each message summary line are stored in the message's soft data vector. @pxref{Message Internals}. The positions within the summary line have text-properties set, which give the data about the message: @itemize @item @inindex vm-message @code{vm-message}. The message struct for which this line is a summary. @end itemize @node Threading Internals, Sorting Internals, Summary Internals, Internals @section Threading Internals @inindex vm-thread-obarray @inindex vm-thread-subject-obarray @inindex In-Reply-To header @inindex References header Message threads required for threaded summaries are calculated using message ID's, which are unique when the message was originally composed. However, VM may need to deal with multiple copies of the same message received via possibly different routes. So, message ID's are not unique for messages inside VM. Messages composed as replies generally have an ``In-Reply-To'' header. The message mentioned in this header is referred to as the parent of the message. In addition, messages also arrive with a ``References'' header which lists all the ancestors of the message, with the oldest message being listed first. The last message listed in the ``References'' header is the direct parent of message. It is important to keep in mind that all the messages listed in the ``References'' header may not be present in the VM folder. Thread trees are constructed using the ``In-Reply-To'' headers and ``References'' headers. Jamie Zawinski has done a good analysis of the information contained in these headers which can be found on the web. VM's threading algorithm is currently based on these ideas. These trees are called reference-based threads. @inindex vm-thread-using-subject In addition, VM also allows threads to be built using the subject headers via the option @code{vm-thread-using-subject}. Subject-based threading is used in addition to reference-based threading. So, in a subject-based thread, the root message would be the oldest message with that subject and, below it, would be reference-based threads all of which share the same subject. The roots of these reference-based threads are referred to as the ``members'' of the subject thread. Subject threading is only one level deep, whereas reference threading can be arbitrarily deep. Threads are built using two hash tables @code{vm-thread-obarray} and @code{vm-thread-subject-obarray}. The former keeps track of the thread obtained by following parent and reference chains. The latter keeps track of messages with the ``same subject''. To prevent messages from jumping from one thread to another within the same VM session, the subject used is not the message's own subject, but rather the subject of the oldest message in the thread. This subject is retained even if the oldest message is expunged. The message ID's are interned in @code{vm-thread-obarray} and the following information is stored for each message ID: @itemize @item messages: The list of messages that carry this message ID in the folder. There could be none, if we only know this message from its appearance in other ``References'' headers. @item message: The ``canonical'' message with this message ID. It is typically the first message encountered by VM with this message ID. If there are no messages with this ID, then the field is @code{nil}. @item date: The date of the message. @item parent: The interned message ID of the parent of this message. (The folder may or may not contain a message with this ID.) If there is no parent, then this is @code{nil} @item children: The interned message ID's of all the children of this message. (The folder may or may not contain messages with these ID's.) @item youngest-date: The date of the youngest message in the thread, among all the messages present in the folder. @item oldest-date: The date of the oldest message in the thread, among the messages present in the folder. @item oldest-subject: The subject of the oldest message in the thread, among the messages present in the folder. @end itemize The @code{vm-thread-subject-obarray} interns each subject string found in the folder and maps it to a vector containing the following elements: @itemize @item id-sym: The interned message ID of what is likely to be the root of the thread, which is, at any rate, the oldest message with this subject. @item date: The date of the root message. @item members: A list of interned message ID's for the ``members'' of the subject thread, which are messages without any reference-based ancestors. The root message represented by @code{id-sym} is not included as a member. @item messages: The list of all the messages in the folder that have this subject. @end itemize @inindex threads, building @b{Building threads} involves calculating all the data stored with the @code{vm-thread-obarray} and @code{vm-thread-subject-obarray}. These two collections of data are calculated in sequence, because the subject threads are based on the reference threads. @inindex thread-subtree @inindex thread-list @inindex thread-indentation After the threads are built, the @code{thread-list}, @code{thread-indentation} and the @code{thread-subtree} fields of the Soft data vector are calculated as needed on demand and cached. (@xref{Soft data vector}.) These fields cannot be calculated without building threads first. When new messages are assimilated, they are added to the threads that might have been already built, and the thread-related fields in the Soft data vector are erased so that they will be recalculated. The @code{thread-subtree} field is erased for all the ancestors of the assimilated message. The @code{thread-list} and @code{thread-indentation} fields are erased for all the descendants of the assimilated message. @inindex unthread Before messages in the folder are expunged, they are @b{unthreaded}. This involves removing them from their respective thread trees. It also involves the erasure of the @code{thread-subtree} field of all their ancestors and the @code{thread-list} and @code{thread-indentation} fields of the descendants. @unnumberedsubsec Error handling The code for threading has to be robust in the presence of erroneous information in the message headers. We have no control over the mail clients that produce those messages and faulty information should not lead to VM hanging or producing errors. It should just do the best job it can in the presence of imperfect information. It is possible that the information in the headers give rise to cycles in the thread trees. Kyle Jones's original implementation allowed these cycles to exist, but all functions that traversed the thread trees were protected to detect cycles. However, since thread trees are updated when new messages are received or existing messages are expunged, this led to unstable results. Following Jamie Zawinski's recommendation, VM now avoids cycles in thread trees. Loop detection is still carried out during traversal as a double safeguard. VM gives priority to the parent information contained in the ``In-Reply-To'' headers in preference to the information in the ``References'' headers. However, if an ``In-Reply-To'' header gives rise to a cycle, it is ignored, and then ``References'' headers might be used to fill in the missing information. @node Sorting Internals, User Interaction, Threading Internals, Internals @section Sorting Internals @inindex vm-key-functions Sorting of messages in VM is carried out using the Emacs built-in sorting function, which is generic in the comparison operation to be used for sorting. The required comparison operation is expressed as a sequence of basic comparison operations such as comparison by date, by author, by subject etc. The dynamic variable @code{vm-key-functions} is bound to a list of comparison functions before calling the Emacs sort function. @inindex vm-sort-compare-xxxxxx The function @code{vm-sort-compare-xxxxxx} uses the functions listed in @code{vm-key-functions} to do the overall comparison. It compares the given messages using the key functions in sequence. If the first key function decides one of the messages to precede the other, then the comparison is over. If the messages are found to be equivalent according to the first key function then the second key function is tried and, if they are still equivalent, then the next key function is tried and so on. This is called the lexicographic combination of the given key functions. @inindex vm-sort-compare-thread Sorting by threads is special. When messages are to be sorted by threads, all the messages belonging to a thread should appear together. The required effect is achieved by using @code{vm-sort-compare-thread} as the first key function in the sequence. This function checks to see if the two messages belonging to the same thread. If they do then the farthest ancestors of the two messages that share the same parent are returned so that the remaining comparison operations can be applied to these ancestors. The rationale is that these ancestors are the roots of the thread subtrees that the two messages belong to. So, the relative ordering of the messages should be the same as the relative ordering of these ancestors. If the two messages belong to different threads then the thread roots of the two messages are returned, again with the same rationale. Threaded summaries can be sorted by any key, e.g., by author (full-name). It is most common to sort them by ``activity,'' i.e., the order of the most recent message in the thread or subthread. Sorting them by ``date'' means using the date of the root message of the thread or subthread. @node User Interaction, Coding Systems, Sorting Internals, Internals @section User Interaction @inindex vm-mail-buffer @inindex vm-select-folder-buffer-and-validate @inindex vm-user-interaction-buffer For each mail folder, VM creates three kinds of buffers in Emacs: the Folder buffer, the Presentation buffer and the Summary buffer. All three types of buffers have the same user interface as far as possible: the same key bindings, menu bars, tool bars and also the same @i{commands}. The functions implementing the commands must therefore work irrespective which of the three buffers they are invoked in. This makes VM quite different from most Emacs modes. @inindex vm-mail-buffer @inindex vm-summary-buffer @inindex vm-presentation-buffer VM stores the identity of the Folder buffer in a buffer-local variable @code{vm-mail-buffer} in each of the other types of buffers. Conversely, each Folder buffer uses buffer-local variables @code{vm-summary-buffer} and @code{vm-presentation-buffer} to store the identity of the other buffers. @inindex vm-user-interaction-buffer @inindex vm-select-folder-buffer-and-validate Whenever a VM command is invoked by the user, VM calls a function called @code{vm-select-folder-buffer-and-validate}, which sets the current-buffer to the Folder buffer. It also stores the identity of the buffer with the user's focus in a global variable called @code{vm-user-interaction-buffer}. Thus, at every point during the command execution, VM has knowledge of all the buffers involved as well as the buffer in which the command execution was initiated. [More to be filled in on @code{vm-display} etc.] @inindex vm-mode-menu-map The default menu bar of VM contains VM-specific menus, replacing the standard Emacs menus. This is achieved by setting the buffer-specific menu bar to one in which the Emacs menus are @code{undefined} (at least in Gnu Emacs). VM computes its standard menu bar and stores it internally: @itemize @item In Gnu Emacs, this is stored in the keymap @code{vm-mode-menu-map}. @item In XEmacs ... @end itemize @noindent The menu bar also has a menu, or a menu item, to switch back to the standard Emacs menu bar. @inindex vm-use-menus The computed menu bar is then installed depending on the setting of @code{vm-use-menus}. If the user selects the action to revert to the standard Emacs menu bar, the installation is easily reverted. @itemize @item In Gnu Emacs, the installation involves inserting a key binding for @code{menu-bar}. @item In XEmacs, ... @end itemize @inindex vm-menu-toggle-menubar @noindent When the user picks a menu item to revert to the Emacs menu bar, the function @code{vm-menu-toggle-menubar} is invoked, which installs a fresh menu bar retaining the standard Emacs menus. The same function is used to reinstall the dedicated VM menu bar when needed. @node Coding Systems, Virtual Folder Internals, User Interaction, Internals @section Coding Systems @inindex coding system A Coding System is a way of encoding characters as bit patterns. @pxref{Coding System Basics,, Coding System Basics, elisp, Emacs Lisp manual}. US-ASCII is a coding system for English. Other coding systems are used to encode the various languages of the world, e.g., @code{iso-latin-1} for Western European languages, and @code{hebrew-iso-8bit} for Hebrew. Emacs also uses its own internal coding system for characters, which can encode all character sets currently in existence. But the internal coding system can vary between different versions of Emacs. @inindex mime-charset @inindex coding-system-get @inindex charset @inindex vm-mime-mule-coding-to-charset-alist @inindex vm-mime-mule-charset-to-coding-alist Emacs defines a property called @code{mime-charset} for each implemented coding system, which is the official preferred name of the @acronym{MIME} character set that it corresponds to. For example, @code{iso-latin-1} corresponds to the @acronym{MIME} charset @code{iso-8859-1}, and @code{hebrew-iso-8bit} corresponds to the @acronym{MIME} charset @code{iso-8859-8}. The Emacs function @code{coding-system-get} can be used to extract the @code{mime-charset} property of a coding system. VM stores all the known coding systems and the corresponding @acronym{MIME} charsets in its internal variables @code{vm-mime-mule-coding-to-charset-alist} and @code{vm-mime-mule-charset-to-coding-alist}. @inindex Content-Type @inindex decode-coding-region @inindex encode-coding-region @acronym{MIME} messages specify the character set that their content is in, in the Content-Type header. VM uses this information to decode the content to the Emacs internal coding system. This is done using the function @code{decode-coding-region}. Conversely, VM encodes the outgoing messages into the default or chosen @acronym{MIME} character set using the function @code{encode-coding-region}. @inindex decode-coding-string @inindex encode-coding-string @inindex base 64 @inindex quoted printable The headers of email messages can only be in US-ASCII. So header fields in other character sets are encoded using either base-64 or quoted-printable encoding (which give ASCII strings) and annotated with the name of the original character set. Such annotations look like @code{=?charset?B?}. They can apply to individual words or sequences of words appearing the in the headers. Note that the annotation @code{?B?} signifies base-64 encoding of the byte stream. Similarly the annotation @code{?Q?} might be used to denote the quoted-printable encoding. VM decodes such strings using the function @code{decode-coding-string}. Conversely, the headers of outgoing messages are encoded using @code{encode-coding-string} @node Virtual Folder Internals, @acronym{MIME} Display, Coding Systems, Internals @section Virtual Folder Internals @inindex virtual-folder-definition @inindex vm-virtual-folder-alist A virtual folder is characterized by its definition, which is stored in the buffer-local variable @code{virtual-folder-definition}. The form of the definition is as given in @code{vm-virtual-folder-alist}. @xref{Defined Folders, vm-virtual-folder-alist}. It is a collection of clauses, with each clause listing a collection of folders and a collection of virtual selectors. Each virtual selector @var{X} has a corresponding Lisp function @samp{vm-vs-@var{X}}, whose purpose is to check whether a given message matches the selector. The arguments for @samp{vm-vs-@var{X}} are a message data structure @code{m} and all the arguments for the virtual selector @var{X}. For example, the virtual selector @code{author} has a string argument, representing the author name. The corresponding Lisp function is defined as: @example (defun vm-vs-author (m author-name) (or (string-match author-name (vm-su-full-name m)) (string-match author-name (vm-su-from m)))) @end example @noindent The definition checks to see if the given @code{author-name} pattern occurs in the full name of the author (@code{vm-su-full-name}) or the email address of the author (@code{vm-su-from}). The @code{author} selector is then registered in four places: @itemize @inindex vm-virtual-selector-function-alist @item The variable @code{vm-virtual-selector-function-alist}, which contains pairs of the form @samp{(@var{SELECTOR} . @var{FUNCTION})}. For the @code{author} selector, the pair is @code{(author . vm-vs-author)}. @inindex vm-virtual-selector-arg-type @item The selector symbol @code{author} is given a property @code{vm-virtual-selector-arg-type} indicating the type of argument it requies: @example (put 'author 'vm-virtual-selector-arg-type 'string) @end example @inindex vm-supported-interactive-virtual-selectors @item The variable @code{vm-supported-interactive-virtual-selectors}, which contains lists of strings, each string being the name of a virtual selector. For the @code{author} selector, the list is @code{("author")}. Including the selector in this variable allows it to be used in creating interactive virtual folders (search folders). @inindex vm-virtual-selector-clause @item The selector symbol @code{author} is given a property @code{vm-virtual-selector-clause} indicating the prompt string for interactive use: @example (put 'author 'vm-virtual-selector-clause "with author matching") @end example @end itemize @noindent Evidently, the last two registrations are only needed for interactive selectors that can be used with the @kbd{V C} command. @node @acronym{MIME} Display, @acronym{MIME} Composition, Virtual Folder Internals, Internals @section @acronym{MIME} Display @inindex vm-decode-mime-layout The @acronym{MIME} layout of a message is stored in the @code{mime-layout} field of the Soft data vector of the message. (@xref{@acronym{MIME} layout}.) The @acronym{MIME} layout is in general a tree structure of ``@acronym{MIME} parts''. The function @code{vm-decode-mime-layout} is responsible for traversing the tree structure at each @acronym{MIME} part and displaying it appropriately. The function @code{vm-decode-mime-layout} goes through the following sequence of decisions: @enumerate @item If the @acronym{MIME} part is a @code{multipart} type, then the subparts are displayed as needed. If it is a single part, it proceeds as follows. @item If the @acronym{MIME} part should not be displayed automatically, it is displayed as a button. (An automatically displayed @acronym{MIME} type is one listed in @code{vm-mime-auto-displayed-content-types} but not listed in the corresponding exceptions.) @item If the @acronym{MIME} part should be displayed internally and VM is able to do so, then it is displayed internally. (An internally displayed @acronym{MIME} type is one listed in @code{vm-mime-internal-content-types} but not listed in the corresponding exceptions.) @item Otherwise, the @acronym{MIME} part is displayed externally. An external viewer is found from @code{vm-mime-external-content-types-alist} and it is invoked to display the @acronym{MIME} part. @end enumerate @inindex message/external-body @acronym{MIME} parts of type @samp{message/external-body} need special treatment. If they are not asked to be auto-displayed, then they are displayed as buttons, but the button caption may use information from the child part (the actual object that is in the external-body) such as its type and description. If a @code{message/external-body} part is asked to be auto-displayed, then the child part is fetched from the external source and stored in an internal buffer. It may be auto-displayed if it is appropriate to do so, or shown in turn as a button. @inindex @acronym{MIME} button @acronym{MIME} buttons are displayed as regions of text displaying button labels. In addition, they have an overlay/extent placed on them, which has a number of properties associated with it: @itemize @item @code{vm-button}. Always @code{t}. @item @code{vm-mime-layout}. Gives the layout of the @acronym{MIME} part. @item @code{vm-mime-function}. The function that carries out the action represented by pressing the button. @item @code{vm-mime-disposable}. Set to true if the button should be removed when it is replaced by the @acronym{MIME} object. @inindex vm-mime-button-face @item @code{face}. Set to the value of @code{vm-mime-button-face}. @item @code{local-map} (FSF Emacs) or @code{keymap} (XEmacs). Set to a keymap that includes @code{vm-mime-reader-map}, binding the @kbd{$} keys. @end itemize @node @acronym{MIME} Composition, Extents and Overlays, @acronym{MIME} Display, Internals @section @acronym{MIME} Composition @inindex attachment button A @acronym{MIME} message is composed just like a normal message. When objects are attached using commands like @code{vm-attach-file}, @b{attachment buttons} are created in the message composition buffer. An attachment button is a region of text that looks like: @example [Attachment mary.jpeg, image/jpeg] @end example @noindent Various text properties are associated with an attachment button, allowing it to be turned into an actual attachment when the message is sent. The representation of the attachment buttons differs in GNU Emacs and XEmacs. In GNU Emacs, the region of text is given @i{text properties} that represent the metadata about the object. In XEmacs, the region of text is given an @i{extent}, which is then given properties representing the metadata. The reason for the different representations is that in GNU Emacs, only text properties are preserved under killing and yanking. The following properties are defined for attachment buttons: @itemize @item @code{vm-mime-object}. The object denoting the @acronym{MIME} attachment. It is either @itemize @item a string denoting a file name, @item a buffer containing the file to be attached, @item a list of the form (buffer, start, end, filename) indicating a region in a buffer, typically the Folder buffer, or @item @code{t} indicating that the attachment is another @acronym{MIME} object in a VM folder. @end itemize @noindent In the last case, the @code{vm-mime-layout} property describes the rest of the metadata. @item @code{vm-mime-type}. A string denoting the @acronym{MIME} type of the object. (Note that it is a single string, unlike the @code{type} component of a @acronym{MIME} layout.) @item @code{vm-mime-parameters}. A list of strings denoting the parameters of the @acronym{MIME} type. @item @code{vm-mime-description}. A string for the @acronym{MIME} description of the object. @item @code{vm-mime-disposition}. A list describing the @acronym{MIME} disposition. @item @code{vm-mime-encoded}. A boolean indicating whether the object has @acronym{MIME} headers. @item @code{vm-mime-encoding}. The @acronym{MIME} encoding used, if it is already encoded. @item @code{vm-mime-forward-local-refs}. Whether or not references to local external-body objects should be forwarded as is. @item @code{fontified}. Standard text property. @item @code{duplicable}. Set to @code{t} in XEmacs allowing the extent to be preserved under killing and yanking. @item @code{front-nonsticky} and @code{rear-nonsticky}. Standard stickiness of text properties in GNU Emacs. @end itemize @inindex vm-mime-fake-attachment-overlays When a composed message is sent, the attachment buttons are replaced by actual attachment objects. In FSF Emacs, the attachment buttons are first converted into ``fake'' overlays before @acronym{MIME} encoding, in a function called @code{vm-mime-fake-attachment-overlays}. This allows the next stage to treat both FSF Emacs and XEmacs using the same logic. The function @code{vm-mime-encode-composition} then encodes the composition buffer, by selecting each attachment button and replacing it with the corresponding object. The bodies of @samp{external-body} objects are also retrieved at this stage. Unless the objects were already @acronym{MIME}-encoded, they are @acronym{MIME}-encoded and made into @acronym{MIME} parts by adding suitable headers. The message itself is given @acronym{MIME} headers describing its content and then handed to Emacs message-sending functions. @unnumberedsubsec Yanking or Forwarding @acronym{MIME} Messages @inindex yank @inindex include @inindex vm-include-mime-attachments When another message is yanked or ``included'' in a message composition, the handling of attachments depends on the variable @code{vm-include-mime-attachments}. If the variable is @code{nil}, then the attachments are displayed as token buttons in @i{plain text} that appear similar to: @example [DELETED ATTACHMENT mary.jpg, image/jpeg] @end example @noindent The function @code{vm-decode-mime-layout} is employed to generate the yanked text along with such token buttons. If @code{vm-include-mime-attachments} is @code{t}, then first the @code{vm-decode-mime-layout} function is employed to generate proper @acronym{MIME} buttons for all the attachments. In a second step, the @acronym{MIME} buttons are replaced by attachment buttons using a function called @code{vm-mime-convert-to-attachment-buttons}. These attachment buttons are then handled as described above. @node Extents and Overlays, Timers and Concurrency, @acronym{MIME} Composition, Internals @section Extents and Overlays @inindex extents @inindex overlays XEmacs and GNU Emacs differ in how they represent non-textual properties in buffers. The web page on ``XEmacs vs GNU Emacs'' describes the situation as follows: @quotation XEmacs uses "extents" to represent all non-textual aspects of buffers; GNU Emacs 19 uses two distinct objects, "text properties" and "overlays", which divide up the functionality between them. Extents are a superset of the union of the functionality of the two GNU Emacs data types. The full GNU Emacs 19 interface to text properties and overlays is supported in XEmacs (with extents being the underlying representation). Extents can be made to be copied into strings, and then restored, by kill and yank. Thus, one can specify this behavior on either "extents" or "text properties", whereas in GNU Emacs 19 text properties always have this behavior and overlays never do. @end quotation While extents and overlays look similar on the surface, they differ fundamentally in that extents are attached to text and, so, can be killed and yanked, whereas overlays are not attached to text. XEmacs has implemented GNU-like text properties on top of extents. So, text properties may work more uniformly in both the Emacsen, but VM was developed in the early days of the forking and does not use these common features. The file @code{vm-misc.el} contains definitions whereby both extents and overlays can be treated as a single type of ``VM extents''. Wherever such VM extents can be used, there is some uniformity in the code but, in other places, there is not. (Independently, the XEmacs team has developed the @code{fsf-compat} package by which FSF-style overlays are implemented on top of extents. This package is not compatible with the way VM deals with the two types.) Another major differences between extents and overlays is that the beginning and ending of overlays are markers. This has some advantages. However, if a buffer has many overlays, normal editing operations must update all the overlay markers, which can be time-consuming. The major applications of extents and overlays in VM are the following: @enumerate @item Summary buffers use extents/overlays for each summary line. These are implemented uniformly but, to avoid the performance problem in GNU Emacs, all the markers are reset to nil before a summary is regenerated and then set to their correct positions afterwards. Not doing this correctly can seriously degrade the performance of summary generation. @item Presentation buffers use extents/overlays for @acronym{MIME} buttons. These are implemented uniformly. @item The message composition buffers have attachment buttons. These are implemented using text properties in GNU Emacs and extents in overlays. The difference is necessary because VM allows the attachment buttons to be killed and yanked. It is not possible to implement this functionality using overlays. @end enumerate @node Timers and Concurrency,, Extents and Overlays, Internals @section Timers and Concurrency VM has been designed as mainly a sequential program. However, there three timer tasks that get scheduled to occur at regular intervals: @table @code @inindex vm-flush-itimer-function @item vm-flush-itimer-function Stores message attributes in the folder so that they will be saved when an auto-save is done. This is controlled by the variable @code{vm-flush-interval}. @inindex vm-get-mail-itimer-function @item vm-get-mail-itimer-function Moves new mail from maildrops into the folder. This is controlled by the variable @code{vm-auto-get-new-mail}. @inindex vm-check-mail-itimer-function @item vm-check-mail-itimer-function Checks the maildrops for any new mail. This is controlled by the variable @code{vm-mail-check-interval}. @end table @noindent These timer tasks are scheduled using the @code{itimer} package in XEmacs and the @code{timer} package in Gnu Emacs. @node Concept Index, Key Index, Internals, Top @unnumbered Concept Index @printindex cp @node Key Index, Command Index, Concept Index, Top @unnumbered Key Index @printindex ky @node Command Index, Variable Index, Key Index, Top @unnumbered Command Index @printindex fn @node Variable Index, Internals Index, Command Index, Top @unnumbered Variable Index @printindex vr @node Internals Index, License, Variable Index, Top @unnumbered Internals Index @printindex in @node License,, Internals Index, Top @unnumbered GNU GENERAL PUBLIC LICENSE @center Version 2, June 1991 @display Copyright @copyright{} 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @end display @unnumberedsec Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software---to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. @iftex @unnumberedsec TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION @end iftex @ifnottex @center TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION @end ifnottex @enumerate 0 @item This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The ``Program'', below, refers to any such program or work, and a ``work based on the Program'' means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term ``modification''.) Each licensee is addressed as ``you''. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. @item You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. @item You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: @enumerate a @item You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. @item You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. @item If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) @end enumerate These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. @item You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: @enumerate a @item Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, @item Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, @item Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) @end enumerate The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. @item You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. @item You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. @item Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. @item If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. @item If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. @item The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and ``any later version'', you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. @item If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. @iftex @heading NO WARRANTY @end iftex @ifnottex @center NO WARRANTY @end ifnottex @item BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW@. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM ``AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE@. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU@. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. @item IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. @end enumerate @iftex @heading END OF TERMS AND CONDITIONS @end iftex @ifnottex @center END OF TERMS AND CONDITIONS @end ifnottex @page @unnumberedsec How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the ``copyright'' line and a pointer to where the full notice is found. @smallexample @var{one line to give the program's name and an idea of what it does.} Copyright (C) 19@var{yy} @var{name of author} This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE@. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. @end smallexample Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: @smallexample Gnomovision version 69, Copyright (C) 19@var{yy} @var{name of author} Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. @end smallexample The hypothetical commands @samp{show w} and @samp{show c} should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than @samp{show w} and @samp{show c}; they could even be mouse-clicks or menu items---whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a ``copyright disclaimer'' for the program, if necessary. Here is a sample; alter the names: @smallexample @group Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. @var{signature of Ty Coon}, 1 April 1989 Ty Coon, President of Vice @end group @end smallexample This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. @summarycontents @contents @bye vm-8.2.0b/pixmaps/0002755000175000017500000000000011676442161014252 5ustar srivastasrivastavm-8.2.0b/pixmaps/undelete-dn.xpm0000755000175000017500000000251511676442161017210 0ustar srivastasrivasta/* XPM */ static char * undelete_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "x c #AAAAAA", "% c #EEEEEE", "_ c #888888", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " BBBBB ", " B B...BB B x ", " B B%%%B.B B x ", " BB%..BBBB xx ", " BB...B.B_x ", " B..B...B_x ", " BB...B.B_x ", " BB.%%%%%B_x ", " B B%+++++B_B ", " B B%+++++B_ B x ", " BBBBBBBB_x x ", " ________x xx ", " xxxxxxx ", " ", " ", " ", " ", " # # # # ", " # # # # ", " # # # # # ## # ", " # # ## # ### # # # ", " # # # # # # #### # ", " # # # # # # # # ", " ### # # ### ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/next-up.xpm0000755000175000017500000000252311676442161016403 0ustar srivastasrivasta/* XPM */ static char * next_up_xpm[] = { "32 32 7 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "% c #EEEEEE", "+ c #CCCCCC", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B%B B%B ", " BBBBBB%%B BBBBBB%%B ", " B%%%%%+%%B B%%%%%+%%B ", " B%++++++%%B B%++++++%%B ", " B%++++++%B_xB%++++++%B_x ", " BBBBBB+%B_x BBBBBB+%B_x ", " ____B%B_x ____B%B_x ", " BB_x BB_x ", " B_x B_x ", " x x ", " ", " ", " ", " ", " ", " # # # ", " ## # # ", " # # # ## # # ### ", " # ## # # # # # ", " # # #### # # ", " # # # # # # ", " # # ### # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/quit-dn.xpm0000755000175000017500000000243411676442161016365 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " BBBBBB ", " Bx B_ ", " Bx Bx ", " Bx BB Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx xx Bx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " ### # ", " # # # # ", " # # # # ### ", " # # # # # # ", " # # # # # # # ", " # # # ## # # ", " ## # # # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/visit-dn.xpm0000755000175000017500000000251211676442161016536 0ustar srivastasrivasta/* XPM */ static char * visit_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " BBB ", " BB BBB..B_ BBB ", " B..BBB.....BBB__B_ ", " B........BBB_____B_x ", " B...%%BBB_______B__x ", " B..%%+B_____BB__B_xx ", " B.%++B__BBB____B_x ", " B%++B_________B__x ", " B%++B__BBB____B_xx ", " B++B_______BBB_x ", " B+B_____BBB____x ", " B+B__BBB____xxxx ", " BBBB____xxxx ", " ____ xxx ", " xxxx ", " ", " ", " ", " # # # ", " # # # # # ", " # # ### ### ", " # # # # # # ", " # # # ## # # ", " # # # # # # ", " # # ### # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/recover-dn.xpm0000755000175000017500000000240111676442161017042 0ustar srivastasrivasta/* XPM */ static char * recover_up_xpm[] = { "32 32 3 1", " c #B2B2B2 s backgroundToolBarColor", "R c #666666", "# c #808080", " ", " ", " ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " ", " ", " ", " ", " #### ", " # # ", " # # ## ## ## # # ", " #### # # # # # # # # ", " # # #### # # # # # ", " # # # # # # # # # ", " # # ### ## ## # ", " ", " ", " "}; vm-8.2.0b/pixmaps/visit-up.xpm0000755000175000017500000000254311676442161016565 0ustar srivastasrivasta/* XPM */ static char * visit_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " BBB ", " BB BBB..B_ BBB ", " B..BBB.....BBB__B_ ", " B........BBB_____B_x ", " B...%%BBB_______B__x ", " B..%%+B_____BB__B_xx ", " B.%++B__BBB____B_x ", " B%++B_________B__x ", " B%++B__BBB____B_xx ", " B++B_______BBB_x ", " B+B_____BBB____x ", " B+B__BBB____xxxx ", " BBBB____xxxx ", " ____ xxx ", " xxxx ", " ", " ", " ", " # # # ", " # # # # # ", " # # ### ### ", " # # # # # # ", " # # # ## # # ", " # # # # # # ", " # # ### # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/make-gtk-pixmaps.py0000755000175000017500000000120211676442161017777 0ustar srivastasrivasta#!/usr/bin/python # -*- python -*- import os, sys if not os.path.exists("gtk"): os.mkdir("gtk") for xpmfile in sys.argv[1:]: fd = open(xpmfile, "r") xpm = fd.readlines() fd.close() xpm[2] = xpm[2].replace("32 32", "28 24") xpm[3] = xpm[3].replace("#B2B2B2 s backgroundToolBarColor", "none") for i in range(4, 20): if xpm[i].startswith('" '): del xpm[i+22:i+31] xpm.insert(i, xpm[i]) for j in range(i, i+24): xpm[j] = '"' + xpm[j][3:3+28] + '"' + xpm[j][34:] break fd = open("gtk/" + xpmfile, "w") fd.writelines(xpm) fd.close() vm-8.2.0b/pixmaps/previous-up.xpm0000755000175000017500000000254611676442161017306 0ustar srivastasrivasta/* XPM */ static char * previous_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "_ c #888888", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B.B B.B ", " B.%BBBBBB B.%BBBBBB ", " B.%+%%%%%Bx B.%+%%%%%Bx ", " B.%+++++++BxB.%+++++++Bx ", " xB%+++++++B_xB%+++++++B_ ", " x_B%+BBBBBB_x_B%+BBBBBB_ ", " x_B%B______ x_B%B______ ", " x_BB_ x_BB_ ", " x_B_ x_B_ ", " x__ x__ ", " ", " ", " ", " ", " ", " #### ", " # # ", " # # ### ## # # ", " #### # # # # # # ", " # # #### # # ", " # # # # # ", " # # ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime-up.xpm0000755000175000017500000000246511676442161016361 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " BB B B ", " BB BB BB BB BBB BB ", " B BB B B B ", " ", " xx x x x x x x xxx xx x ", " x x xx xx x ", " x x x x x x x x x x x ", " ", " BB B BBB ", " BB BB BB BB BBB B BB ", " B BB B B BBB ", " ", " xx x x xxx x x x x xx ", " xxx x x x x xx x x x x ", " ", " ", " ", " ", " # # ", " ## ## ", " # # # # # ###### ## ", " # # # # # # # # ", " # # # # # # #### ", " # # # # # # # ", " # # # # # # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/next-dn.xpm0000755000175000017500000000247211676442161016363 0ustar srivastasrivasta/* XPM */ static char * next_up_xpm[] = { "32 32 7 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "% c #EEEEEE", "+ c #CCCCCC", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B%B B%B ", " BBBBBB%%B BBBBBB%%B ", " B%%%%%+%%B B%%%%%+%%B ", " B%++++++%%B B%++++++%%B ", " B%++++++%B_xB%++++++%B_x ", " BBBBBB+%B_x BBBBBB+%B_x ", " ____B%B_x ____B%B_x ", " BB_x BB_x ", " B_x B_x ", " x x ", " ", " ", " ", " ", " ", " # # # ", " ## # # ", " # # # ## # # ### ", " # ## # # # # # ", " # # #### # # ", " # # # # # # ", " # # ### # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/forward-dn.xpm0000755000175000017500000000251411676442160017045 0ustar srivastasrivasta/* XPM */ static char * forward_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " B ", " BBBBBBBBBBBBBBBBBB BB ", " B................B_B%B ", " B.BB..........BBBBBB%%B ", " B.............B%%%%%+%%B ", " B....BBBBBB...B%++++++%%B ", " B.............B%++++++%B_x ", " B....BBBBB....BBBBBB+%B_x ", " B..............____B%B_x ", " BBBBBBBBBBBBBBBBBB_BB_x ", " __________________B_x ", " xxxxxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " ### # ", " # # ", " # # ## # # # ## ## ", " ## # # # # # # # # # # # # # ", " # # # # # # # # # # # # ", " # # # # # # # # # # # # ", " # # # # # ## # ## ", " ", " ", " "}; vm-8.2.0b/pixmaps/followup-dn.xpm0000755000175000017500000000251511676442160017251 0ustar srivastasrivasta/* XPM */ static char * followup_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "_ c #888888", "+ c #CCCCCC", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " B ", " B B BB_BBBBBBBBBBBBBB ", " B% B% B.B..............B_ ", " B%xB%xB.%BBBBBB......BB.B_x ", " B%xB%xB.%+%%%%%B......BB.B_x ", " B%xB%xB.%+++++++BxBB......B_x ", " B%xB%xB%+++++++B_........B_x ", " _B%xB%xB%%BBBBBB_B.......B_x ", " _B%xB%xB%B______........B_x ", " _B%xB%xBB_BBBBBBBBBBBBBB_x ", " _______B________________x ", " xx xx __xxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " #### # # ", " # # # ", " # ## # # ## # # # ", " ### # # # # # # # # # ", " # # # # # # # # # # ", " # # # # # # # # # # ", " # ## # # ## ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/autofile-up.xpm0000755000175000017500000000256511676442161017243 0ustar srivastasrivasta/* XPM */ static char * autofile_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " # # ", " # # # ", " # # # # ### ## ", " ##### # # # # # ", " # # # # # # # ", " # # # ## # # # ", " # # # # # ## ", " ", " ", " "}; vm-8.2.0b/pixmaps/previous-dn.xpm0000755000175000017500000000251511676442161017257 0ustar srivastasrivasta/* XPM */ static char * previous_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "_ c #888888", "# c #808080", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B.B B.B ", " B.%BBBBBB B.%BBBBBB ", " B.%+%%%%%Bx B.%+%%%%%Bx ", " B.%+++++++BxB.%+++++++Bx ", " xB%+++++++B_xB%+++++++B_ ", " x_B%+BBBBBB_x_B%+BBBBBB_ ", " x_B%B______ x_B%B______ ", " x_BB_ x_BB_ ", " x_B_ x_B_ ", " x__ x__ ", " ", " ", " ", " ", " ", " #### ", " # # ", " # # ### ## # # ", " #### # # # # # # ", " # # #### # # ", " # # # # # ", " # # ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime-dn.xpm0000755000175000017500000000243411676442161016332 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "x c #AAAAAA", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " BB B B ", " BB BB BB BB BBB BB ", " B BB B B B ", " ", " xx x x x x x x xxx xx x ", " x x xx xx x ", " x x x x x x x x x x x ", " ", " BB B BBB ", " BB BB BB BB BBB B BB ", " B BB B B BBB ", " ", " xx x x xxx x x x x xx ", " xxx x x x x xx x x x x ", " ", " ", " ", " ", " # # ", " ## ## ", " # # # # # ###### ## ", " # # # # # # # # ", " # # # # # # #### ", " # # # # # # # ", " # # # # # # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/help-up.xpm0000755000175000017500000000246511676442161016362 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BBBBBB ", " BBBBBBBB_ ", " BBBxxxxBBBx ", " BBBxBBBBxBBBx ", " BBBxBBBBxBBBx ", " BBBBBBBxBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBBBBBBBx ", " BBBBBxBBBBx ", " BBBBBBBBx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " # # # ", " # # # ", " # # ## # ### ", " ##### # # # # # ", " # # #### # # # ", " # # # # # # ", " # # ### ## ### ", " # ", " # ", " "}; vm-8.2.0b/pixmaps/forward-up.xpm0000755000175000017500000000254511676442161017075 0ustar srivastasrivasta/* XPM */ static char * forward_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " B ", " BBBBBBBBBBBBBBBBBB BB ", " B................B_B%B ", " B.BB..........BBBBBB%%B ", " B.............B%%%%%+%%B ", " B....BBBBBB...B%++++++%%B ", " B.............B%++++++%B_x ", " B....BBBBB....BBBBBB+%B_x ", " B..............____B%B_x ", " BBBBBBBBBBBBBBBBBB_BB_x ", " __________________B_x ", " xxxxxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " ### # ", " # # ", " # # ## # # # ## ## ", " ## # # # # # # # # # # # # # ", " # # # # # # # # # # # # ", " # # # # # # # # # # # # ", " # # # # # ## # ## ", " ", " ", " "}; vm-8.2.0b/pixmaps/undelete-up.xpm0000755000175000017500000000254611676442161017237 0ustar srivastasrivasta/* XPM */ static char * undelete_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "x c #AAAAAA", "% c #EEEEEE", "_ c #888888", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BBBBB ", " B B...BB B x ", " B B%%%B.B B x ", " BB%..BBBB xx ", " BB...B.B_x ", " B..B...B_x ", " BB...B.B_x ", " BB.%%%%%B_x ", " B B%+++++B_B ", " B B%+++++B_ B x ", " BBBBBBBB_x x ", " ________x xx ", " xxxxxxx ", " ", " ", " ", " ", " # # # # ", " # # # # ", " # # # # # ## # ", " # # ## # ### # # # ", " # # # # # # #### # ", " # # # # # # # # ", " ### # # ### ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/file-up.xpm0000755000175000017500000000256111676442161016346 0ustar srivastasrivasta/* XPM */ static char * file_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " #### # ", " # # ", " # # # ## ", " ### # # # ", " # # # #### ", " # # # # ", " # # # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/getmail-dn.xpm0000755000175000017500000000253311676442161017025 0ustar srivastasrivasta/* XPM */ static char * getmail_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "+ c #CCCCCC", "x c #AAAAAA", "% c #EEEEEE", ": c #F2F2F2", "# c #808080", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B.BB..........BB.B_# ", " B.............BB.B_# ", " B....BBBBBB......B_# ", " B................B_# ", " B....BBBBBB......B_# ", " B.....B%%%B_.....B_# ", " BBBBBBB++%B_#BBBBB_# ", " _____B++%B_#______# ", " ####B++%B_######## ", " BBBB++%BBBB ", " B:++++%%B_# ", " B:++%%B_# ", " B:%%B_# ", " B:B_# ", " B_# ", " # ", " ", " ", " ### # ", " # # # ", " # ## ### ", " # ### # # # ", " # # #### # ", " # # # # ", " ### ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime-xx.xpm0000755000175000017500000000253111676442161016366 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " # # # ", " # # # ", " ### ## # # ### # ", " # # # # # # # ", " # ### # # # ", " # # # # # # ", " # ### # # # # ", " ", " ", " # ", " # ", " ### # ## # ### ", " # # # # # # ", " # # # ### # # # ", " # # # # # # # # ", " ### # ### # # # ", " # ", " # ", " ", " ", " + + ", " xx xx ", " + + + + + +x+x+x x+ ", " x x x x + + + x ", " + + + + x x x+x+ ", " x x x x + + + ", " + + + + x x x+x ", " ", " ", " "}; vm-8.2.0b/pixmaps/Makefile.in0000755000175000017500000000313111676442160016315 0ustar srivastasrivasta@SET_MAKE@ # no csh please SHELL = /bin/sh ############################################################################## # location of required programms prefix = @prefix@ MKDIR = @MKDIR@ RM = @RM@ LS = @LS@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ srcdir = @srcdir@ datadir= @datadir@ datarootdir= @datarootdir@ pixmapdir = @pixmapdir@ SYMLINKS = @SYMLINKS@ LINKPATH = @LINKPATH@ ############################################################################## all: Makefile: @srcdir@/Makefile.in cd @srcdir@/..; ./config.status install: install-pkg install-pkg: $(MKDIR) -p "$(DESTDIR)$(pixmapdir)" for i in `$(LS) *.xpm` ; do \ echo "Installing $$i in '$(DESTDIR)$(pixmapdir)'" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(pixmapdir)" ; \ done ; $(MKDIR) -p "$(DESTDIR)$(pixmapdir)/mime" for i in `ls mime/*.xpm` ; do \ echo "Installing $$i in '$(DESTDIR)$(pixmapdir)'" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(pixmapdir)/mime" ; \ done ; $(MKDIR) -p "$(DESTDIR)$(pixmapdir)/gtk" for i in `ls gtk/*.xpm` ; do \ echo "Installing $$i in '$(DESTDIR)$(pixmapdir)'" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(pixmapdir)/gtk" ; \ done ; @echo VM pixmaps successfully installed\! ############################################################################## clean: -$(RM) -f *~ distclean: clean -$(RM) -f Makefile vm-8.2.0b/pixmaps/reply-dn.xpm0000755000175000017500000000251211676442161016533 0ustar srivastasrivasta/* XPM */ static char * reply_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " B ", " BB BBBBBBBBBBBBBBBBBB ", " B.B B................B_ ", " B.%BBBBBB..........BB.B_x ", " B.%+%%%%%B..........BB.B_x ", " B.%+++++++BxBBBBBB......B_x ", " B%+++++++B_............B_x ", " x_B%+BBBBBB_BBBBB.......B_x ", " x_B%B______............B_x ", " x_BB_BBBBBBBBBBBBBBBBBB_x ", " x_B_ __________________x ", " x__ xxxxxxxxxxxxxxxxxx ", " x_ ", " x ", " ", " ", " ", " #### # ", " # # # ", " # # ## # # # # # ", " #### # # ## # # # # ", " # # #### # # # # # ", " # # # ## # # # # ", " # # ### # # # ### ", " # # ", " # ### ", " "}; vm-8.2.0b/pixmaps/print-dn.xpm0000755000175000017500000000251211676442161016534 0ustar srivastasrivasta/* XPM */ static char * print_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "_ c #888888", "# c #808080", " ", " ", " ", " BBBBBBBBB ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " BBBBBBBBBBBBBBB ", " B.............Bx ", " B. ++++++++++B_x ", " B.++++++++++++B_x ", " B.++++++++++++B_x ", " BBBBBBBBBBBBBBB_x ", " B+_+_+_+_+_+B__x ", " BBBBBBBBBBBBB_xx ", " x____________x ", " xxxxxxxxxxxxx ", " ", " ", " ", " #### # ", " # # # # ", " # # # # # # ### ", " #### ## # # ## # # ", " # # # # # # ", " # # # # # # ", " # # # # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/0002755000175000017500000000000011676442161015037 5ustar srivastasrivastavm-8.2.0b/pixmaps/gtk/undelete-dn.xpm0000755000175000017500000000166111676442161017776 0ustar srivastasrivasta/* XPM */ static char * undelete_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "x c #AAAAAA", "% c #EEEEEE", "_ c #888888", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " ", " BBBBB ", " B B...BB B x ", " B B%%%B.B B x ", " BB%..BBBB xx ", " BB...B.B_x ", " B..B...B_x ", " BB...B.B_x ", " BB.%%%%%B_x ", " B B%+++++B_B ", " B B%+++++B_ B x ", " BBBBBBBB_x x ", " ________x xx ", " xxxxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/next-up.xpm0000755000175000017500000000166711676442161017200 0ustar srivastasrivasta/* XPM */ static char * next_up_xpm[] = { "28 24 7 1", " c none", "B c #330099", "% c #EEEEEE", "+ c #CCCCCC", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B%B B%B ", " BBBBBB%%B BBBBBB%%B ", " B%%%%%+%%B B%%%%%+%%B ", " B%++++++%%B B%++++++%%B ", " B%++++++%B_xB%++++++%B_x ", " BBBBBB+%B_x BBBBBB+%B_x ", " ____B%B_x ____B%B_x ", " BB_x BB_x ", " B_x B_x ", " x x ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/quit-dn.xpm0000755000175000017500000000160011676442161017144 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "28 24 5 1", " c none", "B c #666666", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " ", " BBBBBB ", " Bx B_ ", " Bx Bx ", " Bx BB Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx xx Bx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/visit-dn.xpm0000755000175000017500000000165611676442161017333 0ustar srivastasrivasta/* XPM */ static char * visit_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " BBB ", " BB BBB..B_ BBB ", " B..BBB.....BBB__B_ ", " B........BBB_____B_x ", " B...%%BBB_______B__x ", " B..%%+B_____BB__B_xx ", " B.%++B__BBB____B_x ", " B%++B_________B__x ", " B%++B__BBB____B_xx ", " B++B_______BBB_x ", " B+B_____BBB____x ", " B+B__BBB____xxxx ", " BBBB____xxxx ", " ____ xxx ", " xxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/recover-dn.xpm0000755000175000017500000000154511676442161017637 0ustar srivastasrivasta/* XPM */ static char * recover_up_xpm[] = { "28 24 3 1", " c none", "R c #666666", "# c #808080", " ", " ", " ", " ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/visit-up.xpm0000755000175000017500000000170711676442161017353 0ustar srivastasrivasta/* XPM */ static char * visit_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BBB ", " BB BBB..B_ BBB ", " B..BBB.....BBB__B_ ", " B........BBB_____B_x ", " B...%%BBB_______B__x ", " B..%%+B_____BB__B_xx ", " B.%++B__BBB____B_x ", " B%++B_________B__x ", " B%++B__BBB____B_xx ", " B++B_______BBB_x ", " B+B_____BBB____x ", " B+B__BBB____xxxx ", " BBBB____xxxx ", " ____ xxx ", " xxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/previous-up.xpm0000755000175000017500000000171211676442161020065 0ustar srivastasrivasta/* XPM */ static char * previous_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "_ c #888888", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B.B B.B ", " B.%BBBBBB B.%BBBBBB ", " B.%+%%%%%Bx B.%+%%%%%Bx ", " B.%+++++++BxB.%+++++++Bx ", " xB%+++++++B_xB%+++++++B_ ", " x_B%+BBBBBB_x_B%+BBBBBB_ ", " x_B%B______ x_B%B______ ", " x_BB_ x_BB_ ", " x_B_ x_B_ ", " x__ x__ ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/mime-up.xpm0000755000175000017500000000163111676442161017140 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "28 24 5 1", " c none", "B c #330099", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BB B B ", " BB BB BB BB BBB BB ", " B BB B B B ", " ", " xx x x x x x x xxx xx x ", " x x xx xx x ", " x x x x x x x x x x x ", " ", " BB B BBB ", " BB BB BB BB BBB B BB ", " B BB B B BBB ", " ", " xx x x xxx x x x x xx ", " xxx x x x x xx x x x x ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/next-dn.xpm0000755000175000017500000000163611676442161017151 0ustar srivastasrivasta/* XPM */ static char * next_up_xpm[] = { "28 24 7 1", " c none", "B c #666666", "% c #EEEEEE", "+ c #CCCCCC", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B%B B%B ", " BBBBBB%%B BBBBBB%%B ", " B%%%%%+%%B B%%%%%+%%B ", " B%++++++%%B B%++++++%%B ", " B%++++++%B_xB%++++++%B_x ", " BBBBBB+%B_x BBBBBB+%B_x ", " ____B%B_x ____B%B_x ", " BB_x BB_x ", " B_x B_x ", " x x ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/forward-dn.xpm0000755000175000017500000000166011676442160017633 0ustar srivastasrivasta/* XPM */ static char * forward_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " ", " B ", " BBBBBBBBBBBBBBBBBB BB ", " B................B_B%B ", " B.BB..........BBBBBB%%B ", " B.............B%%%%%+%%B ", " B....BBBBBB...B%++++++%%B ", " B.............B%++++++%B_x", " B....BBBBB....BBBBBB+%B_x ", " B..............____B%B_x ", " BBBBBBBBBBBBBBBBBB_BB_x ", " __________________B_x ", " xxxxxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/followup-dn.xpm0000755000175000017500000000166111676442160020037 0ustar srivastasrivasta/* XPM */ static char * followup_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", "_ c #888888", "+ c #CCCCCC", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " ", " B ", " B B BB_BBBBBBBBBBBBBB ", " B% B% B.B..............B_", " B%xB%xB.%BBBBBB......BB.B_", " B%xB%xB.%+%%%%%B......BB.B_", "B%xB%xB.%+++++++BxBB......B_", " B%xB%xB%+++++++B_........B_", " _B%xB%xB%%BBBBBB_B.......B_", " _B%xB%xB%B______........B_", " _B%xB%xBB_BBBBBBBBBBBBBB_", " _______B________________", " xx xx __xxxxxxxxxxxxxxx", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/autofile-up.xpm0000755000175000017500000000173111676442160020021 0ustar srivastasrivasta/* XPM */ static char * autofile_up_xpm[] = { "28 24 9 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/previous-dn.xpm0000755000175000017500000000166111676442161020045 0ustar srivastasrivasta/* XPM */ static char * previous_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "_ c #888888", "# c #808080", " ", " ", " ", " ", " ", " ", " B B ", " BB BB ", " B.B B.B ", " B.%BBBBBB B.%BBBBBB ", " B.%+%%%%%Bx B.%+%%%%%Bx ", " B.%+++++++BxB.%+++++++Bx ", " xB%+++++++B_xB%+++++++B_ ", " x_B%+BBBBBB_x_B%+BBBBBB_ ", " x_B%B______ x_B%B______ ", " x_BB_ x_BB_ ", " x_B_ x_B_ ", " x__ x__ ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/mime-dn.xpm0000755000175000017500000000160011676442161017111 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "28 24 5 1", " c none", "B c #666666", "x c #AAAAAA", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " BB B B ", " BB BB BB BB BBB BB ", " B BB B B B ", " ", " xx x x x x x x xxx xx x ", " x x xx xx x ", " x x x x x x x x x x x ", " ", " BB B BBB ", " BB BB BB BB BBB B BB ", " B BB B B BBB ", " ", " xx x x xxx x x x x xx ", " xxx x x x x xx x x x x ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/help-up.xpm0000755000175000017500000000163111676442161017141 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "28 24 5 1", " c none", "B c #330099", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " BBBBBB ", " BBBBBBBB_ ", " BBBxxxxBBBx ", " BBBxBBBBxBBBx ", " BBBxBBBBxBBBx ", " BBBBBBBxBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBBBBBBBx ", " BBBBBxBBBBx ", " BBBBBBBBx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/forward-up.xpm0000755000175000017500000000171111676442161017654 0ustar srivastasrivasta/* XPM */ static char * forward_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "+ c #CCCCCC", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " B ", " BBBBBBBBBBBBBBBBBB BB ", " B................B_B%B ", " B.BB..........BBBBBB%%B ", " B.............B%%%%%+%%B ", " B....BBBBBB...B%++++++%%B ", " B.............B%++++++%B_x", " B....BBBBB....BBBBBB+%B_x ", " B..............____B%B_x ", " BBBBBBBBBBBBBBBBBB_BB_x ", " __________________B_x ", " xxxxxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/undelete-up.xpm0000755000175000017500000000171211676442161020016 0ustar srivastasrivasta/* XPM */ static char * undelete_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "x c #AAAAAA", "% c #EEEEEE", "_ c #888888", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " BBBBB ", " B B...BB B x ", " B B%%%B.B B x ", " BB%..BBBB xx ", " BB...B.B_x ", " B..B...B_x ", " BB...B.B_x ", " BB.%%%%%B_x ", " B B%+++++B_B ", " B B%+++++B_ B x ", " BBBBBBBB_x x ", " ________x xx ", " xxxxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/file-up.xpm0000755000175000017500000000172511676442160017133 0ustar srivastasrivasta/* XPM */ static char * file_up_xpm[] = { "28 24 9 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/getmail-dn.xpm0000755000175000017500000000167711676442161017622 0ustar srivastasrivasta/* XPM */ static char * getmail_up_xpm[] = { "28 24 9 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "+ c #CCCCCC", "x c #AAAAAA", "% c #EEEEEE", ": c #F2F2F2", "# c #808080", " ", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B.BB..........BB.B_# ", " B.............BB.B_# ", " B....BBBBBB......B_# ", " B................B_# ", " B....BBBBBB......B_# ", " B.....B%%%B_.....B_# ", " BBBBBBB++%B_#BBBBB_# ", " _____B++%B_#______# ", " ####B++%B_######## ", " BBBB++%BBBB ", " B:++++%%B_# ", " B:++%%B_# ", " B:%%B_# ", " B:B_# ", " B_# ", " # ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/mime-xx.xpm0000755000175000017500000000167511676442161017163 0ustar srivastasrivasta/* XPM */ static char * mime_up_xpm[] = { "28 24 5 1", " c none", "B c #330099", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " # # # ", " # # # ", " ### ## # # ### # ", " # # # # # # # ", " # ### # # # ", " # # # # # # ", " # ### # # # # ", " ", " ", " # ", " # ", " ### # ## # ### ", " # # # # # # ", " # # # ### # # # ", " # # # # # # # # ", " ### # ### # # # ", " # ", " # ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/reply-dn.xpm0000755000175000017500000000165611676442161017330 0ustar srivastasrivasta/* XPM */ static char * reply_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " ", " B ", " BB BBBBBBBBBBBBBBBBBB ", " B.B B................B_ ", " B.%BBBBBB..........BB.B_x", " B.%+%%%%%B..........BB.B_x", " B.%+++++++BxBBBBBB......B_x", " B%+++++++B_............B_x", " x_B%+BBBBBB_BBBBB.......B_x", " x_B%B______............B_x", " x_BB_BBBBBBBBBBBBBBBBBB_x", " x_B_ __________________x", " x__ xxxxxxxxxxxxxxxxxx", " x_ ", " x ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/print-dn.xpm0000755000175000017500000000165611676442161017331 0ustar srivastasrivasta/* XPM */ static char * print_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "_ c #888888", "# c #808080", " ", " ", " ", " ", " BBBBBBBBB ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " BBBBBBBBBBBBBBB ", " B.............Bx ", " B. ++++++++++B_x ", " B.++++++++++++B_x ", " B.++++++++++++B_x ", " BBBBBBBBBBBBBBB_x ", " B+_+_+_+_+_+B__x ", " BBBBBBBBBBBBB_xx ", " x____________x ", " xxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/help-dn.xpm0000755000175000017500000000160011676442161017112 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "28 24 5 1", " c none", "B c #666666", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " ", " BBBBBB ", " BBBBBBBB_ ", " BBBxxxxBBBx ", " BBBxBBBBxBBBx ", " BBBxBBBBxBBBx ", " BBBBBBBxBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBBBBBBBx ", " BBBBBxBBBBx ", " BBBBBBBBx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/followup-up.xpm0000755000175000017500000000171211676442160020057 0ustar srivastasrivasta/* XPM */ static char * followup_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", "_ c #888888", "+ c #CCCCCC", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " B ", " B B BB_BBBBBBBBBBBBBB ", " B% B% B.B..............B_", " B%xB%xB.%BBBBBB......BB.B_", " B%xB%xB.%+%%%%%B......BB.B_", "B%xB%xB.%+++++++BxBB......B_", " B%xB%xB%+++++++B_........B_", " _B%xB%xB%%BBBBBB_B.......B_", " _B%xB%xB%B______........B_", " _B%xB%xBB_BBBBBBBBBBBBBB_", " _______B________________", " xx xx __xxxxxxxxxxxxxxx", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/quit-up.xpm0000755000175000017500000000163111676442161017173 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "28 24 5 1", " c none", "B c #330099", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " BBBBBB ", " Bx B_ ", " Bx Bx ", " Bx BB Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx xx Bx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/autofile-dn.xpm0000755000175000017500000000170011676442160017772 0ustar srivastasrivasta/* XPM */ static char * autofile_up_xpm[] = { "28 24 9 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #808080", " ", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/file-dn.xpm0000755000175000017500000000167411676442160017113 0ustar srivastasrivasta/* XPM */ static char * file_up_xpm[] = { "28 24 9 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #808080", " ", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/getmail-up.xpm0000755000175000017500000000173011676442161017633 0ustar srivastasrivasta/* XPM */ static char * getmail_up_xpm[] = { "28 24 9 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "+ c #CCCCCC", "x c #AAAAAA", "% c #EEEEEE", ": c #F2F2F2", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B.BB..........BB.B_# ", " B.............BB.B_# ", " B....BBBBBB......B_# ", " B................B_# ", " B....BBBBBB......B_# ", " B.....B%%%B_.....B_# ", " BBBBBBB++%B_#BBBBB_# ", " _____B++%B_#______# ", " ####B++%B_######## ", " BBBB++%BBBB ", " B:++++%%B_# ", " B:++%%B_# ", " B:%%B_# ", " B:B_# ", " B_# ", " # ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/delete-up.xpm0000755000175000017500000000171011676442160017450 0ustar srivastasrivasta/* XPM */ static char * delete_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " BBBBB ", " BB B...BB BB_x ", " _BB B%%%B.B BB___x ", " x__BB%++BBBBB__xxxx ", " xx_BBB++BBB_xx ", " xB__BB__B_x ", " BBB__BBB_x ", " BB__..__BBx ", " BB_B..%%%%B_BB ", " BB__xB%%++++B___BB_x ", " _xx BBBBBBBB_xx___x ", " ________x xxxx ", " xxxxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/reply-up.xpm0000755000175000017500000000170711676442161017350 0ustar srivastasrivasta/* XPM */ static char * reply_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " ", " B ", " BB BBBBBBBBBBBBBBBBBB ", " B.B B................B_ ", " B.%BBBBBB..........BB.B_x", " B.%+%%%%%B..........BB.B_x", " B.%+++++++BxBBBBBB......B_x", " B%+++++++B_............B_x", " x_B%+BBBBBB_BBBBB.......B_x", " x_B%B______............B_x", " x_BB_BBBBBBBBBBBBBBBBBB_x", " x_B_ __________________x", " x__ xxxxxxxxxxxxxxxxxx", " x_ ", " x ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/print-up.xpm0000755000175000017500000000170711676442161017351 0ustar srivastasrivasta/* XPM */ static char * print_up_xpm[] = { "28 24 8 1", " c none", "B c #330099", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "_ c #888888", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " BBBBBBBBB ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " BBBBBBBBBBBBBBB ", " B.............Bx ", " B. ++++++++++B_x ", " B.++++++++++++B_x ", " B.++++++++++++B_x ", " BBBBBBBBBBBBBBB_x ", " B+_+_+_+_+_+B__x ", " BBBBBBBBBBBBB_xx ", " x____________x ", " xxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/compose-dn.xpm0000755000175000017500000000166011676442160017634 0ustar srivastasrivasta/* XPM */ static char * compose-up_xpm[] = { "28 24 8 1", " c none", "B c #666666", "+ c #CCCCCC", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "# c #808080", " ", " ", " ", " B ", " B B B ", " B B B ", " BBB ", "BBBBBBBBB ", " BBB ", " B B_B_BBBBBBBBBBBBBBB ", " B B_.B..............B_ ", " Bx.............BB.B_x ", " x.............BB.B_x ", " B....BBBBBB......B_x ", " B................B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/recover-up.xpm0000755000175000017500000000157611676442161017666 0ustar srivastasrivasta/* XPM */ static char * recover_up_xpm[] = { "28 24 3 1", " c none", "R c #FF0000", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/delete-dn.xpm0000755000175000017500000000165711676442160017437 0ustar srivastasrivasta/* XPM */ static char * delete_up_xpm[] = { "28 24 8 1", " c none", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " ", " BBBBB ", " BB B...BB BB_x ", " _BB B%%%B.B BB___x ", " x__BB%++BBBBB__xxxx ", " xx_BBB++BBB_xx ", " xB__BB__B_x ", " BBB__BBB_x ", " BB__..__BBx ", " BB_B..%%%%B_BB ", " BB__xB%%++++B___BB_x ", " _xx BBBBBBBB_xx___x ", " ________x xxxx ", " xxxxxxx ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/gtk/compose-up.xpm0000755000175000017500000000171111676442160017654 0ustar srivastasrivasta/* XPM */ static char * compose-up_xpm[] = { "28 24 8 1", " c none", "B c #330099", "+ c #CCCCCC", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " B ", " B B B ", " B B B ", " BBB ", "BBBBBBBBB ", " BBB ", " B B_B_BBBBBBBBBBBBBBB ", " B B_.B..............B_ ", " Bx.............BB.B_x ", " x.............BB.B_x ", " B....BBBBBB......B_x ", " B................B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/help-dn.xpm0000755000175000017500000000243411676442161016333 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "_ c #888888", "x c #AAAAAA", "# c #808080", " ", " ", " ", " ", " ", " BBBBBB ", " BBBBBBBB_ ", " BBBxxxxBBBx ", " BBBxBBBBxBBBx ", " BBBxBBBBxBBBx ", " BBBBBBBxBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBxBBBBBx ", " BBBBBBBBBBBBx ", " BBBBBxBBBBx ", " BBBBBBBBx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " # # # ", " # # # ", " # # ## # ### ", " ##### # # # # # ", " # # #### # # # ", " # # # # # # ", " # # ### ## ### ", " # ", " # ", " "}; vm-8.2.0b/pixmaps/followup-up.xpm0000755000175000017500000000254611676442160017300 0ustar srivastasrivasta/* XPM */ static char * followup_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "_ c #888888", "+ c #CCCCCC", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " B ", " B B BB_BBBBBBBBBBBBBB ", " B% B% B.B..............B_ ", " B%xB%xB.%BBBBBB......BB.B_x ", " B%xB%xB.%+%%%%%B......BB.B_x ", " B%xB%xB.%+++++++BxBB......B_x ", " B%xB%xB%+++++++B_........B_x ", " _B%xB%xB%%BBBBBB_B.......B_x ", " _B%xB%xB%B______........B_x ", " _B%xB%xBB_BBBBBBBBBBBBBB_x ", " _______B________________x ", " xx xx __xxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " #### # # ", " # # # ", " # ## # # ## # # # ", " ### # # # # # # # # # ", " # # # # # # # # # # ", " # # # # # # # # # # ", " # ## # # ## ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/quit-up.xpm0000755000175000017500000000246511676442161016414 0ustar srivastasrivasta/* XPM */ static char * quit_up_xpm[] = { "32 32 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "_ c #888888", "x c #AAAAAA", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BBBBBB ", " Bx B_ ", " Bx Bx ", " Bx BB Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx BBx Bx ", " Bx xx Bx ", " BBBBBBx ", " xxxxx ", " ", " ", " ", " ", " ### # ", " # # # # ", " # # # # ### ", " # # # # # # ", " # # # # # # # ", " # # # ## # # ", " ## # # # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/autofile-dn.xpm0000755000175000017500000000253411676442161017214 0ustar srivastasrivasta/* XPM */ static char * autofile_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #808080", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " # # ", " # # # ", " # # # # ### ## ", " ##### # # # # # ", " # # # # # # # ", " # # # ## # # # ", " # # # # # ## ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime/0002755000175000017500000000000011676442161015201 5ustar srivastasrivastavm-8.2.0b/pixmaps/mime/application.xpm0000755000175000017500000000132311676442160020231 0ustar srivastasrivasta/* XPM */ static char * clip_xpm[] = { "22 22 5 1", " c None", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " ", " ", " BBB ", " BB BB ", " BB BB ", " BB BB ", " B_ B_ BB ", " B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ BB ", " B_ B_ B_ B_ ", " B_ B_ B_ B_ ", " B_ BBBB_ B_ ", " B_ ____ B_ ", " B_ B_ ", " BBBBBBB_ ", " _______ ", " ", " "}; vm-8.2.0b/pixmaps/mime/message.xpm0000755000175000017500000000135111676442161017354 0ustar srivastasrivasta/* XPM */ static char * message_xpm[] = { "22 22 8 1", " c None", "B c #330099", "+ c #CCCCCC", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "# c #000000", " ", " ", " ", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B.............BB.B_x ", " B.............BB.B_x ", " B....BBBBBB......B_x ", " B................B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime/text.xpm0000755000175000017500000000240111676442161016711 0ustar srivastasrivasta/* XPM */ static char * document_xpm[] = { "32 32 5 1", " c None", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " ", " ", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B..........B.B.B.B_x ", " B................B_x ", " B..BB.BB.........B_x ", " B................B_x ", " B..B.BBB.........B_x ", " B................B_x ", " B................B_x ", " B..BB.BB.B.B.BB..B_x ", " B................B_x ", " B..B.B.BBB.BB.B..B_x ", " B................B_x ", " B..BB.BB.BB.B.B..B_x ", " B................B_x ", " B..B.BB.B..BBBB..B_x ", " B................B_x ", " B................B_x ", " B.........B.BBB..B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime/image.xpm0000755000175000017500000000127211676442161017014 0ustar srivastasrivasta/* XPM */ static char * image_xpm[] = { "22 22 5 1", " c None", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " ", " ", " ", " ", " xxx ", " ___ ", " BBBBBBBBBBBBBBBB ", " B B_ ", " B x x__x BBB B_ ", " B x x_.._x B.B B_ ", " B x _.BB._x BBB B_ ", " B x _.BB._x B_ ", " B x x_.._x B_ ", " B x x__x B_ ", " B B_ ", " BBBBBBBBBBBBBBBB__ ", " _________________ ", " ", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime/audio.xpm0000755000175000017500000000132511676442160017031 0ustar srivastasrivasta/* XPM */ static char * clip_xpm[] = { "22 22 5 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " BB ", " BBBB ", " B BBB ", " B B ", " B B ", " B B ", " BBBB B ", "_BBBBB____B___________", " BBB BBBB ", " BBBBB ", " BBB ", "______________________", " BBB ", " BBBBB ", " BBBB ", "_______________B______", " B ", " B ", " B ", "_______________B______", " B ", " B "}; vm-8.2.0b/pixmaps/mime/video.xpm0000755000175000017500000000127211676442161017040 0ustar srivastasrivasta/* XPM */ static char * video_xpm[] = { "22 22 5 1", " c None", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " ", " ", " ", " ", " ", " ", "BBBBBBBBBBBBBBBBBBBBBB", "B B B B B B B B B B B ", "BBBBBBBBBBBBBBBBBBBBBB", " B B B ", "_ B _ B ___ B _", " _ B __ B _ B ", "_ B _ B ___ B _", " B B B ", "BBBBBBBBBBBBBBBBBBBBBB", "B B B B B B B B B B B ", "BBBBBBBBBBBBBBBBBBBBBB", " _____________________", " ", " ", " ", " "}; vm-8.2.0b/pixmaps/mime/multipart.xpm0000755000175000017500000000240211676442161017747 0ustar srivastasrivasta/* XPM */ static char * documents_xpm[] = { "32 32 5 1", " c None", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B..........B.B.B.B_ ", " B................B_BBBB ", " B..BB.BB.........B_...B_ ", " B................B_.B.B_ ", " B..B.BBB.........B_...B_BBBB ", " B................B_...B_...B_ ", " B................B_...B_.B.B_x", " B..BB.BB.B.B.BB..B_...B_...B_x", " B................B_...B_...B_x", " B..B.B.BBB.BB.B..B_...B_...B_x", " B................B_B..B_...B_x", " B..BB.BB.BB.B.B..B_...B_...B_x", " B................B_B..B_...B_x", " B..B.BB.B..BBBB..B_...B_B..B_x", " B................B_B..B_...B_x", " B................B_...B_B..B_x", " B.........B.BBB..B_B..B_...B_x", " B....BBBBB.......B_...B_B..B_x", " B................B_...B_...B_x", " BBBBBBBBBBBBBBBBBB_B..B_B..B_x", " __________________...B_...B_x", " B................B_...B_x", " BBBBBBBBBBBBBBBBBB_B..B_x", " __________________...B_x", " B................B_x", " BBBBBBBBBBBBBBBBBB_x", " __________________x", " xxxxxxxxxxxxxxxxxx", " "}; vm-8.2.0b/pixmaps/file-dn.xpm0000755000175000017500000000253011676442161016317 0ustar srivastasrivasta/* XPM */ static char * file_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "= c #666666", "# c #808080", " ", " ", " ", " BBBBBBBBBBBBBB ", " B B......B B_ ", " B B......B_BB_x ", " B B.%%%%%B_xB_x ", " B B.%++++B_xB_x ", " B B.%++++B_xB_x ", " B BBBBBBBB_xB_x ", " B ________xB_x ", " B xxxxxxxxB_x ", " B BBBBBBBB B_x ", " B B====B.B B_x ", " B B====B.B B_x ", " xB B====B.B B_x ", " _BBBBBBBBBBBB_x ", " x_____________x ", " xxxxxxxxxxxxxx ", " ", " ", " ", " #### # ", " # # ", " # # # ## ", " ### # # # ", " # # # #### ", " # # # # ", " # # # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/getmail-up.xpm0000755000175000017500000000256411676442161017054 0ustar srivastasrivasta/* XPM */ static char * getmail_up_xpm[] = { "32 32 9 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "+ c #CCCCCC", "x c #AAAAAA", "% c #EEEEEE", ": c #F2F2F2", "# c #000000 s foregroundToolBarColor", " ", " ", " BBBBBBBBBBBBBBBBBB ", " B................B_ ", " B.BB..........BB.B_# ", " B.............BB.B_# ", " B....BBBBBB......B_# ", " B................B_# ", " B....BBBBBB......B_# ", " B.....B%%%B_.....B_# ", " BBBBBBB++%B_#BBBBB_# ", " _____B++%B_#______# ", " ####B++%B_######## ", " BBBB++%BBBB ", " B:++++%%B_# ", " B:++%%B_# ", " B:%%B_# ", " B:B_# ", " B_# ", " # ", " ", " ", " ### # ", " # # # ", " # ## ### ", " # ### # # # ", " # # #### # ", " # # # # ", " ### ### # ", " ", " ", " "}; vm-8.2.0b/pixmaps/delete-up.xpm0000755000175000017500000000254411676442161016672 0ustar srivastasrivasta/* XPM */ static char * delete_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " BBBBB ", " BB B...BB BB_x ", " _BB B%%%B.B BB___x ", " x__BB%++BBBBB__xxxx ", " xx_BBB++BBB_xx ", " xB__BB__B_x ", " BBB__BBB_x ", " BB__..__BBx ", " BB_B..%%%%B_BB ", " BB__xB%%++++B___BB_x ", " _xx BBBBBBBB_xx___x ", " ________x xxxx ", " xxxxxxx ", " ", " ", " ", " ", " #### # # ", " # # # # ", " # # ## # ## ### ## ", " # # # # # # # # # # ", " # # #### # #### # #### ", " # # # # # # # ", " #### ### # ### # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/reply-up.xpm0000755000175000017500000000254311676442161016562 0ustar srivastasrivasta/* XPM */ static char * reply_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "_ c #888888", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " ", " ", " B ", " BB BBBBBBBBBBBBBBBBBB ", " B.B B................B_ ", " B.%BBBBBB..........BB.B_x ", " B.%+%%%%%B..........BB.B_x ", " B.%+++++++BxBBBBBB......B_x ", " B%+++++++B_............B_x ", " x_B%+BBBBBB_BBBBB.......B_x ", " x_B%B______............B_x ", " x_BB_BBBBBBBBBBBBBBBBBB_x ", " x_B_ __________________x ", " x__ xxxxxxxxxxxxxxxxxx ", " x_ ", " x ", " ", " ", " ", " #### # ", " # # # ", " # # ## # # # # # ", " #### # # ## # # # # ", " # # #### # # # # # ", " # # # ## # # # # ", " # # ### # # # ### ", " # # ", " # ### ", " "}; vm-8.2.0b/pixmaps/print-up.xpm0000755000175000017500000000254311676442161016563 0ustar srivastasrivasta/* XPM */ static char * print_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", ". c #FFFFFF", "% c #EEEEEE", "x c #AAAAAA", "+ c #CCCCCC", "_ c #888888", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " BBBBBBBBB ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " B.BBBBB%B ", " B.%%%%%%B ", " BBBBBBBBBBBBBBB ", " B.............Bx ", " B. ++++++++++B_x ", " B.++++++++++++B_x ", " B.++++++++++++B_x ", " BBBBBBBBBBBBBBB_x ", " B+_+_+_+_+_+B__x ", " BBBBBBBBBBBBB_xx ", " x____________x ", " xxxxxxxxxxxxx ", " ", " ", " ", " #### # ", " # # # # ", " # # # # # # ### ", " #### ## # # ## # # ", " # # # # # # ", " # # # # # # ", " # # # # # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/compose-dn.xpm0000755000175000017500000000251411676442161017047 0ustar srivastasrivasta/* XPM */ static char * compose-up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", "+ c #CCCCCC", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "# c #808080", " ", " ", " B ", " B B B ", " B B B ", " BBB ", " BBBBBBBBB ", " BBB ", " B B_B_BBBBBBBBBBBBBBB ", " B B_.B..............B_ ", " Bx.............BB.B_x ", " x.............BB.B_x ", " B....BBBBBB......B_x ", " B................B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " # # ", " ## # ", " # # # ## # # ", " # ## # # # # # ", " # # #### # # # ", " # # # # # # ", " # # ### # # ", " ", " ", " "}; vm-8.2.0b/pixmaps/recover-up.xpm0000755000175000017500000000243211676442161017071 0ustar srivastasrivasta/* XPM */ static char * recover_up_xpm[] = { "32 32 3 1", " c #B2B2B2 s backgroundToolBarColor", "R c #FF0000", "# c #000000 s foregroundToolBarColor", " ", " ", " ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRRRRRRRRRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " RRRRR ", " ", " ", " ", " ", " #### ", " # # ", " # # ## ## ## # # ", " #### # # # # # # # # ", " # # #### # # # # # ", " # # # # # # # # # ", " # # ### ## ## # ", " ", " ", " "}; vm-8.2.0b/pixmaps/delete-dn.xpm0000755000175000017500000000251311676442161016643 0ustar srivastasrivasta/* XPM */ static char * delete_up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #666666", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "+ c #CCCCCC", "# c #808080", " ", " ", " ", " ", " ", " BBBBB ", " BB B...BB BB_x ", " _BB B%%%B.B BB___x ", " x__BB%++BBBBB__xxxx ", " xx_BBB++BBB_xx ", " xB__BB__B_x ", " BBB__BBB_x ", " BB__..__BBx ", " BB_B..%%%%B_BB ", " BB__xB%%++++B___BB_x ", " _xx BBBBBBBB_xx___x ", " ________x xxxx ", " xxxxxxx ", " ", " ", " ", " ", " #### # # ", " # # # # ", " # # ## # ## ### ## ", " # # # # # # # # # # ", " # # #### # #### # #### ", " # # # # # # # ", " #### ### # ### # ### ", " ", " ", " "}; vm-8.2.0b/pixmaps/compose-up.xpm0000755000175000017500000000254511676442161017076 0ustar srivastasrivasta/* XPM */ static char * compose-up_xpm[] = { "32 32 8 1", " c #B2B2B2 s backgroundToolBarColor", "B c #330099", "+ c #CCCCCC", ". c #FFFFFF", "_ c #888888", "x c #AAAAAA", "% c #EEEEEE", "# c #000000 s foregroundToolBarColor", " ", " ", " B ", " B B B ", " B B B ", " BBB ", " BBBBBBBBB ", " BBB ", " B B_B_BBBBBBBBBBBBBBB ", " B B_.B..............B_ ", " Bx.............BB.B_x ", " x.............BB.B_x ", " B....BBBBBB......B_x ", " B................B_x ", " B....BBBBB.......B_x ", " B................B_x ", " BBBBBBBBBBBBBBBBBB_x ", " __________________x ", " xxxxxxxxxxxxxxxxxx ", " ", " ", " ", " # # ", " ## # ", " # # # ## # # ", " # ## # # # # # ", " # # #### # # # ", " # # # # # # ", " # # ### # # ", " ", " ", " "}; vm-8.2.0b/src/0002755000175000017500000000000011676442161013360 5ustar srivastasrivastavm-8.2.0b/src/qp-decode.c0000755000175000017500000000427111676442161015372 0ustar srivastasrivasta/* public domain */ /* Quoted Printable on stdin -> converted data on stdout */ #include #include #include #ifdef _WIN32 #ifndef WIN32 #define WIN32 #endif #endif #ifdef WIN32 #include #include #endif char *hexdigits = "0123456789ABCDEF"; char *hexdigits2 = "0123456789abcdef"; int main() { char line[2000], *start, *stop, *copy; char *d1, *d2, c; int lineno; #ifdef WIN32 _setmode( _fileno(stdout), _O_BINARY); #endif line[sizeof line - 1] = 0; lineno = 1; while (fgets(line, sizeof line - 1, stdin)) { lineno++; start = line; keep_processing: for (stop = start; *stop && *stop != '=' && *stop != '\n'; stop++) ; if (stop != line && *stop == '\n') { copy = stop; do { copy--; if (*copy != ' ' && *copy != '\t') { copy++; break; } } while (copy != line); } else { copy = stop; } while (start != copy) { putchar(*start); start++; } if (*stop == '\n') { putchar(*stop); lineno++; continue; } else if (*stop == 0) { continue; } else { /* *stop == '=' */ stop++; if (*stop == 0) { continue; } else if ((d1 = strchr(hexdigits, *(stop))) && (d2 = strchr(hexdigits, *(stop+1)))) { c = (d1 - hexdigits) * 16 + (d2 - hexdigits); putchar(c); stop += 2; } else if ((d1 = strchr(hexdigits2, *(stop))) && (d2 = strchr(hexdigits2, *(stop+1)))) { c = (d1 - hexdigits2) * 16 + (d2 - hexdigits2); putchar(c); stop += 2; } else if (*stop == '\n') { /* soft line break */ stop++; } else if (*stop == '\r') { /* * Assume the user's lousy delivery software * didn't convert from Internet's CRLF newline * convention to the local LF convention. */ stop++; } else if (*stop == ' ' || *stop == '\t') { /* garbage added in transit */ for (stop++; *stop && (*stop == ' ' || *stop == '\t'); stop++) ; } else { fprintf(stderr, "Error: line %d: '%c' is something other than line break or hex digit after = in quoted-printable encoding\n", lineno, *stop); putchar('='); putchar(*stop); stop++; /* exit(1); */ } start = stop; goto keep_processing; } } exit(0); } vm-8.2.0b/src/base64-encode.c0000755000175000017500000000244211676442161016046 0ustar srivastasrivasta/* public domain */ /* * arbitrary data on stdin -> BASE64 data on stdout * * UNIX's newline convention is used, i.e. one ASCII control-j (10 decimal). */ #include #include #ifdef _WIN32 #ifndef WIN32 #define WIN32 #endif #endif #ifdef WIN32 #include #include #endif unsigned char alphabet[64] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; int main() { int cols, bits, c, char_count; #ifdef WIN32 _setmode( _fileno(stdin), _O_BINARY); #endif char_count = 0; bits = 0; cols = 0; while ((c = getchar()) != EOF) { if (c > 255) { fprintf(stderr, "encountered char > 255 (decimal %d)", c); exit(1); } bits += c; char_count++; if (char_count == 3) { putchar(alphabet[bits >> 18]); putchar(alphabet[(bits >> 12) & 0x3f]); putchar(alphabet[(bits >> 6) & 0x3f]); putchar(alphabet[bits & 0x3f]); cols += 4; if (cols == 72) { putchar('\n'); cols = 0; } bits = 0; char_count = 0; } else { bits <<= 8; } } if (char_count != 0) { bits <<= 16 - (8 * char_count); putchar(alphabet[bits >> 18]); putchar(alphabet[(bits >> 12) & 0x3f]); if (char_count == 1) { putchar('='); putchar('='); } else { putchar(alphabet[(bits >> 6) & 0x3f]); putchar('='); } if (cols > 0) putchar('\n'); } exit(0); } vm-8.2.0b/src/qp-encode.c0000755000175000017500000000257611676442161015412 0ustar srivastasrivasta/* public domain */ /* * arbitrary data on stdin -> Quoted-Printable data on stdout * * UNIX's newline convention is used, i.e. one ASCII control-j (10 decimal). */ #include #include #ifdef _WIN32 #ifndef WIN32 #define WIN32 #endif #endif #ifdef WIN32 #include #include #endif char *hexdigits = "0123456789ABCDEF"; int main() { int c; int cols = 0; #ifdef WIN32 _setmode( _fileno(stdout), _O_BINARY); #endif while ((c = getchar()) != EOF) { if (c == '\n') { putchar(c); cols = 0; } else if (c == ' ') { int nextc = getchar(); if (nextc != '\n' && nextc != EOF) { putchar(c); cols++; } else { putchar('='); putchar(hexdigits[c >> 4]); putchar(hexdigits[c & 0xf]); cols += 3; } if (nextc != EOF) ungetc(nextc, stdin); } else if (c < 33 || c > 126 || c == '=' || /* these are for RFC 2047 Q encoding */ c == '?' || c == '_') { putchar('='); putchar(hexdigits[c >> 4]); putchar(hexdigits[c & 0xf]); cols += 3; } else if (c == '.' && cols == 0) { int nextc = getchar(); if (nextc == EOF || nextc == '\n') { putchar('='); putchar(hexdigits[c >> 4]); putchar(hexdigits[c & 0xf]); cols += 3; } else { putchar(c); cols++; } if (nextc != EOF) ungetc(nextc, stdin); } else { putchar(c); cols++; } if (cols > 70) { putchar('='); putchar('\n'); cols = 0; } } exit(0); } vm-8.2.0b/src/vm-mail0000755000175000017500000000217511676442161014653 0ustar srivastasrivasta#!/bin/sh # -*- shell-script -*- # Copyright (C) 2006 Robert Widhopf-Fenk # # Author: Robert Widhopf-Fenk # Status: Tested with XEmacs 21.4.19 & VM 7.19 # Keywords: VM helpers # X-URL: http://www.robf.de/Hacking/elisp # Version: $Id$ # This is a wrapper shell script which can be used to pass mailto: links with # the mozex Firefox plugin to VM. # # Grab version 1.9.3 or higher from http://mozex.mozdev.org/installation.html # # In mozex you should give the path to this script with the %a and %s args, e.g. # # /home/yourlogin/bin/vm-mail %a %s # # Set "cmd" below to your Emacs binary. You have three choices. # 1) XEmacs uncomment the next line #cmd=xemacs # 2) GNU Emacs uncomment the next line #cmd=emacs # 3) If you always have a VM-Emacs running you might consider to start gnuserv, # by adding the following to the end of your ~/.vm # # (if (not (gnuserv-running-p)) (gnuserv-start)) # # This will allow you to connect to your running XEmacs with gnuclient and brings up a # composition buffer really instantly. cmd=gnuclient $cmd -eval "(let (vm-frame-per-composition) (vm-mail \"$1\" \"$2\"))" vm-8.2.0b/src/Makefile.in0000755000175000017500000000231411676442161015426 0ustar srivastasrivasta@SET_MAKE@ ############################################################################## # no csh please SHELL = /bin/sh SOURCES = $(wildcard *.c) OBJECTS = $(SOURCES:.c=.o) ############################################################################## # location of required programms prefix = @prefix@ exec_prefix = @exec_prefix@ MKDIR = @MKDIR@ RM = @RM@ INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ prefix = @prefix@ top_srcdir = @top_srcdir@ srcdir = @srcdir@ bindir= @bindir@ ############################################################################## all: $(SOURCES:.c=) install: @mkdir -p -m 0755 "$(DESTDIR)$(bindir)"; \ for i in $(SOURCES:.c=) ; do \ echo "Installing $$i in $(DESTDIR)$(bindir)" ; \ $(INSTALL_PROGRAM) $$i "$(DESTDIR)$(bindir)" ; \ done ; @echo VM helper binaries successfully installed\! ############################################################################## Makefile: @srcdir@/Makefile.in cd ..; ./config.status ############################################################################## clean: -$(RM) -f $(SOURCES:.c=) distclean: clean -$(RM) -f Makefile vm-8.2.0b/src/base64-decode.c0000755000175000017500000000256111676442161016036 0ustar srivastasrivasta/* public domain */ /* BASE64 on stdin -> converted data on stdout */ #include #include #ifdef _WIN32 #ifndef WIN32 #define WIN32 #endif #endif #ifdef WIN32 #include #include #endif unsigned char alphabet[64] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; int main() { static char inalphabet[256], decoder[256]; int i, bits, c, char_count, errors = 0; #ifdef WIN32 _setmode( _fileno(stdout), _O_BINARY); #endif for (i = (sizeof alphabet) - 1; i >= 0 ; i--) { inalphabet[alphabet[i]] = 1; decoder[alphabet[i]] = i; } char_count = 0; bits = 0; while ((c = getchar()) != EOF) { if (c == '=') break; if (c > 255 || ! inalphabet[c]) continue; bits += decoder[c]; char_count++; if (char_count == 4) { putchar((bits >> 16)); putchar(((bits >> 8) & 0xff)); putchar((bits & 0xff)); bits = 0; char_count = 0; } else { bits <<= 6; } } if (c == EOF) { if (char_count) { fprintf(stderr, "base64 encoding incomplete: at least %d bits truncated", ((4 - char_count) * 6)); errors++; } } else { /* c == '=' */ switch (char_count) { case 1: fprintf(stderr, "base64 encoding incomplete: at least 2 bits missing"); errors++; break; case 2: putchar((bits >> 10)); break; case 3: putchar((bits >> 16)); putchar(((bits >> 8) & 0xff)); break; } } exit(errors ? 1 : 0); } vm-8.2.0b/example.vm0000755000175000017500000002702211676442160014573 0ustar srivastasrivasta;;; .vm --- Example ~/.vm ;;; ;;; -*- emacs-lisp -*- ;;; ;;; Copyright (C) 2007 Robert Widhopf-Fenk ;;; ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 1, or (at your option) ;;; any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;;; ;;; You may use this file as a starting point for setting up and customizing ;;; VM to your own needs. ;;***************************************************************************** ;; Make VM your default mail agent in Emacs (setq mail-user-agent 'vm-user-agent) ;;***************************************************************************** ;; Two ways of using VM: ;; - downloading mail to local folders ;; - reading mail on mail servers from anywhere on the internet ;; For local folders, set these variables: (setq vm-folder-directory "~/mail") (setq ;; vm-primary-inbox is the filesystem path to where VM stores ;; downloaded messages: vm-primary-inbox "~/INBOX" ;; vm-crash-box is where messages are stored temporarily as it is moved into ;; your primary inbox file (vm-primary-inbox). Here we just tack on a ;; .crash to name it separately: vm-crash-box (concat vm-primary-inbox ".crash")) ;; vm-spool-files is a list of lists, each sublist should be of the form ;; (INBOX SPOOLNAME CRASHBOX) (setq vm-spool-files (list ;; You can drop mail to the same inbox from different spool files. (list vm-primary-inbox "/var/spool/mail/username1" vm-crash-box) (list vm-primary-inbox "/var/spool/mail/username2" vm-crash-box) ;; Another spool file (list "spam" (expand-file-name "~spam/drop") (concat vm-folder-directory "spam.crash")) ;; POP (list "gmail.pop" "pop:pop.google.com:110:pass:YourEmailAddress:*" (concat vm-folder-directory "gmail.pop.crash")) ;; POP-SSL (list "gmail.pop" "pop-ssl:pop.google.com:995:pass:YourEmailAddress:*" (concat vm-folder-directory "gmail.pop.crash")) ;; IMAP (list "gmail.imap" "imap:imap.google.com:143:inbox:login:YourEmailAddress:*" (concat vm-folder-directory "gmail.imap.crash")) )) ;; For server folders, set these variables: (setq vm-primary-inbox ;; use one of these two ;; for POP server "pop:pop.google.com:110:pass:YourEmailAddress:*" ;; for IMAP server "imap:imap.google.com:143:inbox:login:YourEmailAddress:*" ) (setq vm-pop-folder-cache-directory "~/mailcache") (setq vm-imap-folder-cache-directory "~/mailcache") (setq vm-pop-folder-alist ;; for other POP servers '(("pop:pop3.blueyonder.co.uk:110:pass:YourEmailAddress:*" "blueyonder") ("pop:mailhost.cs.bham.ac.uk:110:pass:YourEmailAddress:*" "bham"))) (setq vm-imap-account-alist ;; for other IMAP servers '(("imap:imap4.blueyonder.co.uk:143:*:login:YourEmailAddress:*" "blueyonder") ("imap:mailhost.cs.bham.ac.uk:143:*:login:YourEmailAddress:*" "bham") )) ;;***************************************************************************** ;; Summary ;; See the recipients for emails you sent instead of yourself. (setq vm-summary-uninteresting-senders (regexp-opt '("@robf.de" "Robert Widhopf-Fenk"))) ;; Change the summary format by setting `vm-summary-format'. ;; Run "M-x vm-fix-my-summary!!! RET" to fix existing summaries. ;;***************************************************************************** ;; Viewing messages ;; ;; HTML messages can be converted to text or the w3 resp. w3m Emacs viewers ;; can be used for displaying. (setq vm-mime-type-converter-alist '(("text/html" "text/plain" "lynx -force_html -dump /dev/stdin") ("message/delivery-status" "text/plain") ("application/zip" "text/plain" "listzip") ("application/x-zip-compressed" "text/plain" "zipinfo /dev/stdin") ("application/x-www-form-urlencoded" "text/plain") ("message/disposition-notification" "text/plain") ("application/mac-binhex40" "application/octet-stream" "hexbin -s")) ;; Set up w3m (you should check if it exists) (require 'vm-w3m) (setq vm-included-mime-types-list '("text/plain" "text/html" "text/enriched" "message/rfc822")) ;;***************************************************************************** ;; Composing email (setq mail-default-headers "From: Robert Widhopf-Fenk \n") (vmpc-my-identities "me@company1.nil" "me@home.nil" "me@alterego.nil") (require 'vm-pcrisis) ;;***************************************************************************** ;; A hook function to setup mail-composing buffers (defun robf-vm-mail-mode-hook () "Robert Widhopf-Fenks `vm-mail-mode-hook'." (interactive) (when (string-match "received" (buffer-name)) (make-local-variable 'vm-confirm-quit) (setq vm-confirm-quit t)) (setq fill-column 60 comment-start "> " indent-line-function 'indent-relative-maybe) ;; mark lines longer than `fill-column' chars red (add-to-list 'mail-font-lock-keywords (list (concat "^" (make-string fill-column ?.) "\\(.+$\\)") '(1 font-lock-warning-face t))) (ispell-change-dictionary "deutsch8") (font-lock-mode 1) (turn-on-auto-fill) (turn-on-filladapt-mode) (flyspell-mode 1) ; (enriched-mode 1) ; (auto-capitalize-mode) ; (vm-mail-subject-prefix-cleanup) ) (add-hook 'vm-mail-mode-hook 'robf-vm-mail-mode-hook) ;; Do you like boxquotes? (require 'boxquote) (defun boxquote-region-and-edit-title (s e) (interactive "r") (boxquote-region s e) (call-interactively 'boxquote-title)) ;;***************************************************************************** ;; Sending email via SMTP. ;; ;; This is not done by VM, but by separate packages. The standard package is ;; smtpmail.el and it should come with your Emacs. If you have more than one ;; email address and have to send them using different SMTP servers, the you ;; might want to take a look at esmtpmail.el a fork from smtpmail.el targeted ;; to deal with personal crisis support. (require 'esmtpmail) (setq send-mail-function 'esmtpmail-send-it esmtpmail-default-smtp-server "smtp.someprovider.com" ;; trace buffers help debugging problems esmtpmail-debug-info t) ;; Select the SMTP server based on the From: header, i.e. the email address of ;; the author. There are also other authentication methods, see the docs. (setq esmtpmail-send-it-by-alist (list '("YourEmaiAddress1" "SMTPSERVER1" (vm-pop-login "pop:SMTPSERVER1:110:pass:YourEmailAddress:*")) '("YourEmaiAddress2" "SMTPSERVER2" (vm-after-pop "pop:SMTPSERVER2:110:pass:YourEmailAddress:*")))) ;;***************************************************************************** ;; Feed mail to a local queue if you are offline (require 'feedmail) (setq send-mail-function 'vm-mail-send-or-feed-it feedmail-enable-queue t feedmail-ask-before-queue nil feedmail-buffer-eating-function 'feedmail-buffer-to-smtpmail feedmail-queue-directory (expand-file-name "~/Mail/QUEUE")) (define-key vm-mode-map "Qr" 'feedmail-run-the-queue) (define-key vm-mode-map "Qc" 'vm-smtp-server-online-p) (define-key vm-mode-map "Qw" 'feedmail-queue-reminder-medium) (setq auto-mode-alist (cons '("\\.fqm$" . mail-mode) auto-mode-alist)) ;; Check the queue on startup (when (and (> (car (feedmail-look-at-queue-directory feedmail-queue-directory)) 0)) (feedmail-queue-reminder-medium) (sit-for 2) (if (y-or-n-p "Send messages now? ") (feedmail-run-the-queue))) ;;***************************************************************************** ;; BBDB - the address book for Emacs (require 'bbdb) (require 'bbdb-autoloads) (bbdb-initialize 'vm 'sendmail) (bbdb-insinuate-vm) ;; create records for people you reply to (add-hook 'vm-reply-hook 'bbdb-force-record-create) ;;***************************************************************************** ;; Now change some keyboard bindings (define-key vm-mode-map [(meta up)] 'vm-previous-unread-message) (define-key vm-mode-map [(meta down)] 'vm-next-unread-message) (define-key vm-mode-map "\C- " 'vm-scroll-backward) (define-key vm-mode-map " " 'vm-scroll-forward) (define-key vm-mode-map "c" 'vm-continue-what-message-other-frame) (define-key vm-mode-map "C" 'vm-continue-postponed-message) (define-key vm-mode-map "R" 'vm-reply-other-frame) (define-key vm-mode-map "r" 'vm-reply-include-text-other-frame) (define-key vm-mode-map "\C-R" 'vm-followup-other-frame) (define-key vm-mode-map "\C-r" 'vm-followup-include-text-other-frame) (define-key vm-mode-map "f" 'vm-forward-message-other-frame) (define-key vm-mode-map "m" 'vm-toggle-mark) (define-key vm-mode-map "d" 'vm-delete-message-action) (define-key vm-mode-map "s" 'vm-virtual-save-message) (define-key vm-mode-map "w" 'vm-save-message-preview) (define-key vm-mode-map "lr" 'vm-delete-message-labels) (define-key vm-mode-map "li" 'rf-vm-label-toggle-important) (define-key vm-mode-map "ls" 'rf-vm-label-toggle-spam) (define-key vm-mode-map "W" 'vm-save-message-sans-headers) (define-key vm-mode-map "W" (make-sparse-keymap)) (define-key vm-mode-map "WW" 'vm-apply-window-configuration) (define-key vm-mode-map "WS" 'vm-save-window-configuration) (define-key vm-mode-map "WD" 'vm-delete-window-configuration) (define-key vm-mode-map "W?" 'vm-window-help) (define-key vm-mode-map "x" 'vm-expunge-folder) (define-key vm-mode-map "X" 'vm-expunge-pop-messages) (define-key vm-mode-map "#" nil) (define-key vm-mode-map "/" 'bbdb) (define-key vm-mode-map [(control return)] 'vm-edit-init-file) (define-key vm-mode-map "S" 'vm-save-everything) (define-key vm-mode-map "\C-a" 'vm-mime-auto-save-all-attachments) (define-key vm-mode-map "VO" 'vm-virtual-omit-message) (define-key vm-mode-map "VU" 'vm-virtual-update-folders) (define-key vm-mode-map [(control s)] 'isearch-forward) (define-key vm-mode-map "o" 'vm-switch-to-folder) (define-key vm-summary-mode-map [(control up)] 'previous-line) (define-key vm-summary-mode-map [(control down)] 'next-line) (define-key vm-summary-mode-map [(control s)] 'vm-isearch-forward) (define-key vm-mail-mode-map [tab] 'indent-relative) (define-key vm-mail-mode-map [(control tab)] 'mail-interactive-insert-alias) (define-key vm-mail-mode-map [return] 'newline-and-indent) (define-key vm-mail-mode-map "\C-c\C-i" 'vm-serial-yank-mail) (define-key vm-mail-mode-map "\C-c\C-o" 'vm-serial-expand-tokens) (define-key vm-mail-mode-map [(control c) (control I)] 'vm-serial-insert-token) (define-key vm-mail-mode-map [(control meta delete)] 'kill-this-buffer) (define-key vm-mail-mode-map "\C-c\C-c" 'vm-mail-mode-comment-region) (define-key vm-mail-mode-map "\C-c\C-d" 'vm-mail-mode-elide-reply-region) (define-key vm-mail-mode-map "\C-c\C-k" 'vm-mail-mode-citation-clean-up) (define-key vm-mail-mode-map "\C-c\C-a" 'vm-mime-attach-file) (define-key vm-mail-mode-map "\C-c\C-b" 'boxquote-region-and-edit-title) ;;; Local Variables: *** ;;; mode:emacs-lisp *** ;;; End: *** ;;; .vm ends here vm-8.2.0b/configure.ac0000755000175000017500000002312011676442160015055 0ustar srivastasrivasta# configure.ac --- configuration setup for VM # Author: Robert Widhopf-Fenk # Copyright (C) 2006-2007 Robert Widhopf-Fenk # Copyright (C) 2010 Uday S Reddy # VM is free software; you can redistribute it and/or modify it under the # terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2 of the License, or (at your option) # any later version. # VM is distributed in the hope that it will be useful, but WITHOUT ANY # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # You should have received a copy of the GNU Library General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # Process this file with autoconf to produce a new configure script # VM_ARG_SUBST(VAR, OPTION, VAL, DESC[, DEFAULT[, ACTION]]) # # Substitute the autoconf variable VAR to a value specified by the user # option --with-OPTION[=VAL] (described by DESC), or with a DEFAULT value. # If an additional ACTION is given, it is executed at the top of the # ACTION-IF-FOUND part of AC_ARG_WITH. # #### WARNING: pay attention to the quoting of ACTION if given !!!!! AC_DEFUN([VM_ARG_SUBST], [ AC_SUBST([$1]) AC_ARG_WITH([$2], AC_HELP_STRING([--with-][$2]ifelse($3, [], [], [=$3]), [$4]ifelse($5, [], [], [ [[[$5]]]])), [ ifelse($6, [], [], $6) $1="${withval}" ], ifelse($5, [], [], [$1="$5"])) ]) # Find a (g)tar program and make sure it is GNU one. A failure is not fatal # since tar is needed for non critical targets only. AC_DEFUN([VM_PROG_GNU_TAR], [ AC_CHECK_PROGS(TAR, gtar tar) if test "x${TAR}" = "xtar" ; then AC_MSG_CHECKING([that tar is GNU tar]) ${TAR} --version > /dev/null 2>&1 || TAR= if test "x${TAR}" = "x" ; then AC_MSG_RESULT(no) else AC_MSG_RESULT(yes) fi fi if test "x${TAR}" = "x" ; then AC_MSG_WARN([*** No GNU tar program found.]) AC_MSG_WARN([*** Some targets will be unavailable.]) fi ]) # Find an xargs program. A failure is not fatal, only clean/tarball will not # work AC_DEFUN([VM_PROG_XARGS], [ AC_CHECK_PROG(XARGS, xargs, xargs) if test "x${XARGS}" = "x" ; then AC_MSG_WARN([*** No xargs program found.]) AC_MSG_WARN([*** make clean/tarball will not work.]) fi ]) # Find a makeinfo program. A failure is not fatal, only info files won't be # built. AC_DEFUN([VM_PROG_MAKEINFO], [ AC_CHECK_PROG(MAKEINFO, makeinfo, makeinfo) if test "x${MAKEINFO}" = "x" ; then AC_MSG_WARN([*** No makeinfo program found.]) AC_MSG_WARN([*** Info files will not be built.]) fi ]) # Find a texi2dvi program. A failure is not fatal, only dvi and pdf files # won't be built. AC_DEFUN([VM_PROG_TEXI2DVI], [ AC_CHECK_PROG(TEXI2DVI, texi2dvi, texi2dvi) if test "x${TEXI2DVI}" = "x" ; then AC_MSG_WARN([*** No texi2dvi program found.]) AC_MSG_WARN([*** DVI and PDF files will not be built.]) fi ]) # Choose an Emacs flavor according to the --with-emacs user option, or try # emacs and xemacs. # We use EMACS_PROG instead of EMACS to avoid colliding with Emacs' own # internal environment. AC_DEFUN([VM_PROG_EMACS], [ AC_ARG_WITH([emacs], AC_HELP_STRING([--with-emacs=PROG], [choose which flavor of Emacs to use]), [ EMACS_PROG="${withval}" ], [ AC_CHECK_PROGS(EMACS_PROG, emacs xemacs) ]) if test "x${EMACS_PROG}" = "x" ; then dnl This is critical enough to generate an error and not a warning... AC_MSG_ERROR([*** No Emacs program found.]) fi # EMACS TYPE ################################################## AC_MSG_CHECKING([checking emacs-type of ${EMACS_PROG}]) cat > conftest.el < conftest.el < conftest.el <]) AC_CONFIG_SRCDIR([configure.ac]) AC_CONFIG_FILES([Makefile lisp/Makefile info/Makefile src/Makefile pixmaps/Makefile vm-load.el]) # Common system utilities checking: AC_PROG_MAKE_SET AC_PROG_INSTALL AC_PROG_LN_S AC_PATH_PROG(RM, rm, /bin/rm) AC_PATH_PROG(LS, ls, /bin/ls) AC_PATH_PROG(MKDIR, mkdir, /bin/mkdir) AC_PATH_PROG(GREP, grep, /bin/grep) # External programs checking: VM_PROG_XARGS VM_PROG_GNU_TAR VM_PROG_MAKEINFO VM_PROG_TEXI2DVI VM_PROG_EMACS VM_BUILD_FLAGS VM_PATH_INFO_DIR VM_OTHERDIRS # is there a sane way to set this to a useful default? VM_ARG_SUBST([PACKAGEDIR], [package-dir], [DIR], [set the Emacs package directory to DIR],) VM_ARG_SUBST([SYMLINKS], [symlinks], [], [install VM by linking instead of copying], [no]) VM_ARG_SUBST([LINKPATH], [linkpath], [PATH], [path to symlink from if `pwd' does not work]) AC_OUTPUT # configure.ac ends here vm-8.2.0b/COPYING0000755000175000017500000004310311676442161013626 0ustar srivastasrivasta GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. vm-8.2.0b/Makefile.in0000755000175000017500000000530511676442160014641 0ustar srivastasrivasta@SET_MAKE@ # location of required programms BZR = bzr --no-plugins prefix = @prefix@ MKDIR = @MKDIR@ TAR = @TAR@ RM = @RM@ XARGS = @XARGS@ prefix = @prefix@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ srcdir = @srcdir@ datadir= @datadir@ datarootdir= @datarootdir@ etcdir = @etcdir@ pixmapdir = @pixmapdir@ docdir = @docdir@ SUBDIRS = lisp info src pixmaps # the list of source (documentation) files SOURCES = NEWS SOURCES += CHANGES SOURCES += README SOURCES += TODO SOURCES += COPYING ############################################################################## .PHONY: all install clean distclean all: vm-load.el @for i in $(SUBDIRS) ; do ($(MAKE) -C $$i) || exit 1; done Makefile vm-load.el: %: config.status @srcdir@/%.in ./config.status $@ @srcdir@/configure: @srcdir@/configure.ac cd @srcdir@ ; autoconf ./config.status --recheck config.status: @srcdir@/configure ./config.status --recheck install: install-pkg @for i in $(SUBDIRS) ; do ($(MAKE) -C $$i install) || exit 1; done install-pkg: $(MKDIR) -p "$(DESTDIR)$(docdir)" $(MKDIR) -p "$(DESTDIR)$(etcdir)" for i in $(SOURCES) ; do \ echo "Installing $$i in '$(DESTDIR)$(docdir)' and '$(DESTDIR)$(etcdir)'" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(docdir)" ; \ $(INSTALL_DATA) $$i "$(DESTDIR)$(etcdir)" ; \ done ; clean: @for i in $(SUBDIRS) ; do ($(MAKE) -C $$i clean) || exit 1; done distclean: @for i in $(SUBDIRS) ; do ($(MAKE) -C $$i distclean) || exit 1; done push: $(BZR) push ############################################################################## PKGDIR = $(shell pwd)/,,package/ PKGINFO = $(PKGDIR)/lisp/vm/_pkg.el xemacs-package: if [ "x@EMACS_FLAVOR@" != "xxemacs" ]; then \ echo "ERROR: Current build dir not configured for XEmacs,"; \ echo "ERROR: Please re-run configure with --with-emacs=xemacs."; \ exit 1; \ fi -$(RM) -rf ,,package cd lisp; make PACKAGEDIR=$(PKGDIR)/lisp/vm install-pkg cd info; make info_dir=$(PKGDIR)/info install-pkg cd src; make info_dir=$(PKGDIR)/bin install-pkg echo ";;;###autoload" > $(PKGINFO) echo "(package-provide 'vm'" > $(PKGINFO) echo " :version 0.7" >> $(PKGINFO) echo ' :author-version "'`$(BZR) revno "@top_srcdir@"`'"' >> $(PKGINFO) echo " :type 'regular)" >> $(PKGINFO) mkdir $(PKGDIR)/pkginfo; touch $(PKGDIR)/pkginfo/MANIFEST.vm; cd $(PKGDIR); find -type f | cut -c3- > pkginfo/MANIFEST.vm cd ,,package; $(TAR) -cvzf ../vm-pkg.tar.gz * ############################################################################## release:: ./release.sh snapshot:: ./release.sh snapshot tags:: etags lisp/*.el contrib/*.el info/vm.texinfo NEWS vm-8.2.0b/configure0000755000175000017500000032447411676442161014514 0ustar srivastasrivasta#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.68 for VM 8.2.0b. # # Report bugs to . # # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software # Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. # # Copyright (C) 2009-2010 VM Development Team ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV export CONFIG_SHELL case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org and $0: vm@lists.launchpad.net about your system, including any $0: error possibly output before this message. Then install $0: a modern shell, or manually run the script under such a $0: shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='VM' PACKAGE_TARNAME='vm' PACKAGE_VERSION='8.2.0b' PACKAGE_STRING='VM 8.2.0b' PACKAGE_BUGREPORT='vm@lists.launchpad.net' PACKAGE_URL='' ac_unique_file="configure.ac" ac_subst_vars='LTLIBOBJS LIBOBJS LINKPATH SYMLINKS PACKAGEDIR OTHERDIRS info_dir FLAGS EMACS_VERSION EMACS_FLAVOR pixmapdir etcdir lispdir EMACS_PROG TEXI2DVI MAKEINFO TAR XARGS GREP MKDIR LS RM LN_S INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM SET_MAKE target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking with_emacs with_lispdir with_etcdir with_docdir with_other_dirs with_package_dir with_symlinks with_linkpath ' ac_precious_vars='build_alias host_alias target_alias' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures VM 8.2.0b to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/vm] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of VM 8.2.0b:";; esac cat <<\_ACEOF Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-emacs=PROG choose which flavor of Emacs to use --with-lispdir=DIR where to install lisp files --with-etcdir=DIR where to install data files --with-docdir=DIR where to install doc files --with-other-dirs=DIRS set other needed lisp directories (a list of semicolon separated paths) --with-package-dir=DIR set the Emacs package directory to DIR --with-symlinks install VM by linking instead of copying [[no]] --with-linkpath=PATH path to symlink from if `pwd' does not work Report bugs to . _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF VM configure 8.2.0b generated by GNU Autoconf 2.68 Copyright (C) 2010 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. Copyright (C) 2009-2010 VM Development Team _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by VM $as_me 8.2.0b, which was generated by GNU Autoconf 2.68. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5 ; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Name of the application # Version (release) number # Contact address ac_config_files="$ac_config_files Makefile lisp/Makefile info/Makefile src/Makefile pixmaps/Makefile vm-load.el" # Common system utilities checking: { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if ${ac_cv_path_install+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in #(( ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 $as_echo_n "checking whether ln -s works... " >&6; } LN_S=$as_ln_s if test "$LN_S" = "ln -s"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no, using $LN_S" >&5 $as_echo "no, using $LN_S" >&6; } fi # Extract the first word of "rm", so it can be a program name with args. set dummy rm; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_RM+:} false; then : $as_echo_n "(cached) " >&6 else case $RM in [\\/]* | ?:[\\/]*) ac_cv_path_RM="$RM" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_RM="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_RM" && ac_cv_path_RM="/bin/rm" ;; esac fi RM=$ac_cv_path_RM if test -n "$RM"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RM" >&5 $as_echo "$RM" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "ls", so it can be a program name with args. set dummy ls; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_LS+:} false; then : $as_echo_n "(cached) " >&6 else case $LS in [\\/]* | ?:[\\/]*) ac_cv_path_LS="$LS" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_LS="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_LS" && ac_cv_path_LS="/bin/ls" ;; esac fi LS=$ac_cv_path_LS if test -n "$LS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $LS" >&5 $as_echo "$LS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "mkdir", so it can be a program name with args. set dummy mkdir; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_MKDIR+:} false; then : $as_echo_n "(cached) " >&6 else case $MKDIR in [\\/]* | ?:[\\/]*) ac_cv_path_MKDIR="$MKDIR" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_MKDIR="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_MKDIR" && ac_cv_path_MKDIR="/bin/mkdir" ;; esac fi MKDIR=$ac_cv_path_MKDIR if test -n "$MKDIR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR" >&5 $as_echo "$MKDIR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # Extract the first word of "grep", so it can be a program name with args. set dummy grep; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else case $GREP in [\\/]* | ?:[\\/]*) ac_cv_path_GREP="$GREP" # Let the user override the test with a path. ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_path_GREP="$as_dir/$ac_word$ac_exec_ext" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS test -z "$ac_cv_path_GREP" && ac_cv_path_GREP="/bin/grep" ;; esac fi GREP=$ac_cv_path_GREP if test -n "$GREP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $GREP" >&5 $as_echo "$GREP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi # External programs checking: # Extract the first word of "xargs", so it can be a program name with args. set dummy xargs; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_XARGS+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$XARGS"; then ac_cv_prog_XARGS="$XARGS" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_XARGS="xargs" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi XARGS=$ac_cv_prog_XARGS if test -n "$XARGS"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XARGS" >&5 $as_echo "$XARGS" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x${XARGS}" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** No xargs program found." >&5 $as_echo "$as_me: WARNING: *** No xargs program found." >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** make clean/tarball will not work." >&5 $as_echo "$as_me: WARNING: *** make clean/tarball will not work." >&2;} fi for ac_prog in gtar tar do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_TAR+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$TAR"; then ac_cv_prog_TAR="$TAR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_TAR="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi TAR=$ac_cv_prog_TAR if test -n "$TAR"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TAR" >&5 $as_echo "$TAR" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$TAR" && break done if test "x${TAR}" = "xtar" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking that tar is GNU tar" >&5 $as_echo_n "checking that tar is GNU tar... " >&6; } ${TAR} --version > /dev/null 2>&1 || TAR= if test "x${TAR}" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi fi if test "x${TAR}" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** No GNU tar program found." >&5 $as_echo "$as_me: WARNING: *** No GNU tar program found." >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** Some targets will be unavailable." >&5 $as_echo "$as_me: WARNING: *** Some targets will be unavailable." >&2;} fi # Extract the first word of "makeinfo", so it can be a program name with args. set dummy makeinfo; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_MAKEINFO+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$MAKEINFO"; then ac_cv_prog_MAKEINFO="$MAKEINFO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_MAKEINFO="makeinfo" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi MAKEINFO=$ac_cv_prog_MAKEINFO if test -n "$MAKEINFO"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MAKEINFO" >&5 $as_echo "$MAKEINFO" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x${MAKEINFO}" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** No makeinfo program found." >&5 $as_echo "$as_me: WARNING: *** No makeinfo program found." >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** Info files will not be built." >&5 $as_echo "$as_me: WARNING: *** Info files will not be built." >&2;} fi # Extract the first word of "texi2dvi", so it can be a program name with args. set dummy texi2dvi; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_TEXI2DVI+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$TEXI2DVI"; then ac_cv_prog_TEXI2DVI="$TEXI2DVI" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_TEXI2DVI="texi2dvi" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi TEXI2DVI=$ac_cv_prog_TEXI2DVI if test -n "$TEXI2DVI"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $TEXI2DVI" >&5 $as_echo "$TEXI2DVI" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x${TEXI2DVI}" = "x" ; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** No texi2dvi program found." >&5 $as_echo "$as_me: WARNING: *** No texi2dvi program found." >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: *** DVI and PDF files will not be built." >&5 $as_echo "$as_me: WARNING: *** DVI and PDF files will not be built." >&2;} fi # Check whether --with-emacs was given. if test "${with_emacs+set}" = set; then : withval=$with_emacs; EMACS_PROG="${withval}" else for ac_prog in emacs xemacs do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_EMACS_PROG+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$EMACS_PROG"; then ac_cv_prog_EMACS_PROG="$EMACS_PROG" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_EMACS_PROG="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi EMACS_PROG=$ac_cv_prog_EMACS_PROG if test -n "$EMACS_PROG"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $EMACS_PROG" >&5 $as_echo "$EMACS_PROG" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$EMACS_PROG" && break done fi if test "x${EMACS_PROG}" = "x" ; then as_fn_error $? "*** No Emacs program found." "$LINENO" 5 fi # EMACS TYPE ################################################## { $as_echo "$as_me:${as_lineno-$LINENO}: checking checking emacs-type of ${EMACS_PROG}" >&5 $as_echo_n "checking checking emacs-type of ${EMACS_PROG}... " >&6; } cat > conftest.el <&5 $as_echo "${EMACS_FLAVOR}" >&6; } # EMACS VERSION ############################################### { $as_echo "$as_me:${as_lineno-$LINENO}: checking checking emacs-version of ${EMACS_PROG}" >&5 $as_echo_n "checking checking emacs-version of ${EMACS_PROG}... " >&6; } cat > conftest.el <&5 $as_echo "${EMACS_VERSION}" >&6; } # Copied from gnus aclocal.m4 # Check whether --with-lispdir was given. if test "${with_lispdir+set}" = set; then : withval=$with_lispdir; lispdir=${withval} fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking where .elc files should go" >&5 $as_echo_n "checking where .elc files should go... " >&6; } if test -z "$lispdir"; then theprefix=$prefix if test "x$theprefix" = "xNONE"; then theprefix=$ac_default_prefix fi datarootdir="\$(prefix)/share" datadir="${datarootdir}" if test "$EMACS_FLAVOR" = "xemacs"; then datarootdir="\$(prefix)/lib" datadir="${datarootdir}/${EMACS_FLAVOR}/site-packages/etc" lispdir="${datarootdir}/${EMACS_FLAVOR}/site-packages/lisp/vm" else lispdir="${datarootdir}/${EMACS_FLAVOR}/site-lisp/vm" fi for thedir in share lib; do potential= if test -d "${theprefix}/${thedir}/${EMACS_FLAVOR}/site-lisp"; then if test "$EMACS_FLAVOR" = "xemacs"; then lispdir="\$(prefix)/${thedir}/${EMACS_FLAVOR}/site-packages/lisp/vm" else lispdir="${datarootdir}/${EMACS_FLAVOR}/site-lisp/vm" fi break fi done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $lispdir" >&5 $as_echo "$lispdir" >&6; } # Check whether --with-etcdir was given. if test "${with_etcdir+set}" = set; then : withval=$with_etcdir; etcdir=${withval} fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking where data files should go" >&5 $as_echo_n "checking where data files should go... " >&6; } if test -z "$etcdir"; then etcdir="${datadir}/vm" fi pixmapdir="${etcdir}/pixmaps" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $etcdir" >&5 $as_echo "$etcdir" >&6; } # Check whether --with-docdir was given. if test "${with_docdir+set}" = set; then : withval=$with_docdir; docdir=${withval} fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking where doc files should go" >&5 $as_echo_n "checking where doc files should go... " >&6; } if test -z "$docdir"; then if test "$EMACS_FLAVOR" = "xemacs"; then docdir="${etcdir}" else docdir="${datarootdir}/doc/vm" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $docdir" >&5 $as_echo "$docdir" >&6; } # if test "x${EMACS_FLAVOR}" = "xemacs" ; then # PACKAGEDIR="${prefix}/share/emacs/site-lisp" # else # PACKAGEDIR="${HOME}/.xemacs/xemacs-packages" # fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking which options to pass on to (X)Emacs" >&5 $as_echo_n "checking which options to pass on to (X)Emacs... " >&6; } if test "x$FLAGS" = "x"; then if test "x$EMACS_FLAVOR" = "xxemacs"; then FLAGS="-batch -no-autoloads -l \$(srcdir)/vm-build.el" else FLAGS="-batch -q -no-site-file -no-init-file -l \$(srcdir)/vm-build.el" fi else FLAGS=$FLAGS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $FLAGS" >&5 $as_echo "$FLAGS" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking where the TeXinfo docs should go" >&5 $as_echo_n "checking where the TeXinfo docs should go... " >&6; } if test "$infodir" = "\${datarootdir}/info"; then if test "$EMACS_FLAVOR" = "xemacs"; then info_dir="\$(prefix)/${thedir}/${EMACS_FLAVOR}/site-packages/info" else info_dir="\${datarootdir}/info" fi else info_dir=$infodir fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $info_dir" >&5 $as_echo "$info_dir" >&6; } # Check whether --with-other-dirs was given. if test "${with_other_dirs+set}" = set; then : withval=$with_other_dirs; OTHERDIRS="${withval}" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking otherdirs" >&5 $as_echo_n "checking otherdirs... " >&6; } cat > conftest.el <&5 $as_echo "$OTHERDIRS" >&6; } # is there a sane way to set this to a useful default? # Check whether --with-package-dir was given. if test "${with_package_dir+set}" = set; then : withval=$with_package_dir; PACKAGEDIR="${withval}" fi # Check whether --with-symlinks was given. if test "${with_symlinks+set}" = set; then : withval=$with_symlinks; SYMLINKS="${withval}" else SYMLINKS="no" fi # Check whether --with-linkpath was given. if test "${with_linkpath+set}" = set; then : withval=$with_linkpath; LINKPATH="${withval}" fi cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by VM $as_me 8.2.0b, which was generated by GNU Autoconf 2.68. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ VM config.status 8.2.0b configured by $0, generated by GNU Autoconf 2.68, with options \\"\$ac_cs_config\\" Copyright (C) 2010 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "lisp/Makefile") CONFIG_FILES="$CONFIG_FILES lisp/Makefile" ;; "info/Makefile") CONFIG_FILES="$CONFIG_FILES info/Makefile" ;; "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; "pixmaps/Makefile") CONFIG_FILES="$CONFIG_FILES pixmaps/Makefile" ;; "vm-load.el") CONFIG_FILES="$CONFIG_FILES vm-load.el" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5 ;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5 ;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5 ;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi # configure.ac ends here vm-8.2.0b/vm-load.el.in0000755000175000017500000000017011676442161015056 0ustar srivastasrivasta; -*- mode: emacs-lisp -*- ;; Load VM easily (add-to-list 'load-path "@abs_top_builddir@/lisp") (load "vm-autoloads") vm-8.2.0b/NEWS0000755000175000017500000013343011676442160013274 0ustar srivastasrivastaIMPORTANT If you are upgrading from a previous version of VM, please look through all the CHANGES sections below since that version to see how you might be affected. Status VM is currently being maintained by a 'VM development team' consisting of Uday S Reddy, Ulrich Müller, Tim Cross and Arik Mitschang. More volunteers to help with the maintenance are quite welcome. Project home page: http://www.nongnu.org/viewmail Mailing list: viewmail-info@nongnu.org Bug report: viewmail-bugs@nongnu.org (Please use `M-x vm-submit-bug-report' within VM) News group: gmane.emacs.viewmail on news.gmane.org (gnu.emacs.vm.info is defunct) Please DO NOT use the Usenet newsgroup gnu.emacs.vm.info because it has an unreliable mail link to the mailing list. You can however browse the archives of the newsgroup at Google Groups. VM 8.2.0b (2011-12-28) CHANGES * New customization variable `vm-spam-score-headers' allows the extraction of spam scores. (Replaces the former variable `vm-vs-spam-score-headers' used by vm-avirtual.el.) * The variable `vm-mime-alternative-select-method' renamed to `vm-mime-alternative-show-method' to make it clear that it only applies to the viewing of messages. The new variable `vm-mime-alternative-yank-method' controls the selection of alternatives for citation in replies. * `vm-submit-bug-report' now uses Emacs message-mode for composing the bug report (whereas it previously used mail-mode with VM-specific tweaks). Please do C-h m to find the functions you might need. * Terminology: Interactively created virtual folders are now called "Search Folders". They have a stronger connection to their parent folders and inherit some attributes, e.g., the read-only property. IMPROVEMENTS * New variable `vm-mail-use-sender-address' allows `vm-mail' to pick up the sender of the current message as the recipient of a new message composition. * See the new info manual section on "IMAP folders" for newly documented functions. In particular, `vm-list-imap-folders' now lists the message counts in the IMAP folders. * New variable: `vm-sort-messages-by-delivery-date' allows messages to be sorted by the date of their delivery instead of the date sent. * New virtual folder selectors added: `message-id', `uid' (for IMAP) and `uidl' (for POP). * New command `vm-create-virtual-folder-of-threads' (bound to `V T') allows you to select entire threads into a virtual folder instead of individual messages. There are also new virtual folder selectors `thread' and `thread-all'. * The trace of POP/IMAP sessions are retained in buffers named "trace of POP session..." or "trace of IMAP session...". They are useful for troubleshooting any problems with mail server connections. * Setting `vm-stunnel-program' to nil asks VM to use the built-in SSL functionality of Emacs, available in Gnu Emacs 24. * New functions `vmpc-folder-match' and `vmpc-folder-account-match' in the vm-pcrisis package. * New variable `vm-mail-auto-save-directory' where message composition buffers are auto-saved. VM 8.2.0a (2011-02-28) CHANGES * The configuration of headers-only messages, introduced in 8.1.90a, has changed. The variable `vm-load-headers-only' has been replaced by a new variable `vm-enable-external-messages'. It should be set to 'imap to allow external messages in IMAP folders and `vm-imap-max-message-size' be customized to control the size of messages that will be external. * If you download mail from IMAP spool files, the 8.1.x versions of VM had a bug which allowed the the `X-VM-IMAP-Retrieved' headers to grow unnecessarily. This can slow down the saving of folders into which you downloaded IMAP mail. To solve the problem, run the command `vm-prune-imap-retrieved-list' after installing version 8.2.0. (See the info manual under "IMAP Spool Files".) * A set of inessential key bindings (a, b, e, i, w, L, M-l, !, <, >, *, %) have been removed from the standard VM key bindings. If you would like to use them, add the line: (vm-legacy-key-bindings) to your vm-preferences-file (~/.vm.preferences). To use the current key bindings instead, use the line (vm-current-key-bindings) Or, you might bind these keys to some other operations of your choice. However, `vm-edit-message' is available via a new key binding `C-c C-e'. * The default value of `vm-url-browser-function' (invoked by mouse-2) is changed to 'browse-url, which is an Emacs standard web-browsing function. To invoke your favourite browser, customize `browse-url-browser-function'. Cf. Emacs manual. * The mouse-3 context menu for URL's in messages updated to eliminate obsolete web browsers. Entries added for Firefox, Mozilla and Opera. * The function `vm-mouse-send-url-to-konqueror-new-browser' renamed to `vm-mouse-send-url-to-konqueror-new-window', to be consistent with other similar functions. * The default settings of `vm-mime-deleteable-types' and `vm-mime-saveable-types' do not include the types listed in `vm-mime-external-content-types-alist'. You might need to add them explicitly in your vm-preferences-file. * The variable name `vm-auto-displayed-mime-content-types' changed to `vm-mime-auto-displayed-content-types' for consistency with other variable names. (The corresponding `-exceptions' variable changed as well.) * The variable name `vm-mime-attachment-infer-type-for-text-attachments' changed to `vm-infer-mime-types-for-text'. * Plain text forwarding has been extended to deal with MIME attachments. The command `vm-forward-message-plain' (bound to `Z') uses this method. (The normal `z' key forwards messages encapsulated using `vm-forwarding-digest-type'.) There are also associated variables `vm-forwarded-headers-plain' and `vm-unforwarded-header-regexp-plain', which determine the headers included in the forwards. * The meaning of the variable `vm-included-mime-types-list' is changed. It need only mention MIME type/subtype pairs that are not handled by default. The types "text/plain", "text/enriched" and "message/rfc822" are now handled by default. * The attributes vector has been expanded to 16 elements for compatibility with Mozilla Thunderbird. The first time a folder is written, this will cause extra time to be taken for "stuffing" the attributes. But this is only a one-time cost. * New variable `vm-include-mime-attachments' allows the inclusion of MIME attachments in replies. This functionality was originally part of vm-pine.el under the name `vm-mime-yank-attachments'. That functionality is now obsolete. Replace references to `vm-mime-yank-attachments' in your customization by the new variable. * The command `vm-flag-message-read' (.) introduced in 8.1.93a is renamed to `vm-mark-message-read' for consistency of terminology. IMPROVEMENTS * New option 'internal-only for `vm-mime-honor-content-disposition', which means the content-disposition will be honored for only internally displayable types. * New variable `vm-mime-alternative-yank-method' controls the selection of MIME alternatives during yanking of messages (as well as including and forwarding). * Added a variable `vm-verbosity' to control the granularity of informative messages displayed by VM. Levels 5-8 are recommended, with 8 corresponding to the current level. * New operations for manual control of thread indentation for dealing with long (and deep) message threads. See info under "Threaded Summaries". * A number of "point-to-point" attachment operations have been added: - `vm-dired-attach-file' and `vm-dired-do-attach-files' from dired buffers. - `vm-attach-message-to-composition' and `vm-reader-map-attach-to-composition' from VM folders. - a drag-and-drop feature that can be used in the window system. * New command `vm-switch-to-folder' defined to quickly return to a previously buried folder. (Originally in vm-rfaddons.) * New custom command `vm-toggle-best-mime' in vm-rfaddons to toggle between 'best and 'best-internal' MIME altrenatives. (Thanks to Alley Stoughton for this addition.) * New variable `vm-include-text-basic' can be used to enable the fallback method of quoting message text in replies. It should be normally left with the default value of nil. * VM refrains from repeatedly checking for new mail once it has found some new mail on the spool. Set `vm-mail-check-always' to override this behavior. * When a predefined virtual folder is quit, all the component folders that it depends on will also be quit automatically. * When an interactive virtual folder is quit, the message pointer in the virtual folder is transferred to the original folder. This facility can be used to search for particular messages by using virtual folders. * Restored the [Emacs] and [Undo] menu buttons that were removed in version 8.0.8. For environments that do not support such buttons, drop-down menus will be used instead. The variable `vm-use-menubar-buttons' can be used to use drop-down menus always. (Thanks to Tim Cross for the fixes.) * Hooks `vm-arrived-message-hook' and `vm-arrived-messages-hook' made to work correctly for IMAP folders. * New variable `vm-thunderbird-folder-directory' and command `vm-visit-thunderbird-folder' allow the handling of Thunderbird folders without interference with VM's own folders. * New variable `vm-sort-subthreads' allows the internal messages of threads to be sorted into subthreads (the default) or via the normal sorting criteria. * Better support for message/external-body MIME type, with external-bodies loaded on demand. If you have message/external-body as an element in `vm-mime-auto-displayed-content-types', you should remove it to access the new functionality. * Newly documented commands: `[' (`vm-previous-button') and `]' (`vm-next-button') allow navigation inside message presentation buffers. * New command: `!' (`vm-toggle-flag-message') allows you to flag a message as being important. This adds a "!" mark in the Summary line for the message and highlights it with the high-priority face. * New variable: `vm-summary-visible' specifies which messages should remain visible in folded thread summaries. * New feature: vm-mime-external-content-types-alist allows emacs-lisp functions to be used for external viewing, e.g., you can use `browse-url-of-file' to view html . VM 8.1.93a (2010-08-28) CHANGES ** New feature: Invoking vm-load-init-file with a prefix argument loads the init-file (~/.vm) without loading the preferences-file (~/.vm.preferences). This is a good way to run VM with the default settings, much like `emacs -Q'. We are advising all users to split their init-files to make use of this feature. See info section on "Starting Up". ** New feature: vm-summary-enable-faces allows summary lists with faces turned on. (This was formerly an add-on contributed by Robert Fenk under the name vm-summary-faces-mode. But there are several changes. In particular, the face names do not end in "-face" following the Emacs naming conventions.) See the info section on "Summaries" for more information. If you currently use the u-vm-color package for colorizing the Summary buffers, please remove the feature, i.e., delete a line like (add-hook 'vm-summary-mode-hook 'u-vm-color-summary-mode) from your VM initialization file. ** Commands renamed: `vm-mime-save-all-attachments' => `vm-save-all-attachments'(C-c C-s) `vm-mime-delete-all-attachments' => `vm-delete-all-attachments'(C-c C-d) IMPROVEMENTS * Sorting of messages extended to work with threads. By default, threads are sorted by "activity", i.e., the date of their most recent activity. But they can also be sorted by other sort keys. (The variable `vm-sort-threads-by-youngest-date' is now defunct.) * New feature: thread-folding in the Summary window allows message threads to be collapsed into single line summaries. The following new variables control the behavior of thread folding. `vm-summary-enable-thread-folding', `vm-summary-show-thread-count' and `vm-summary-thread-folding-on-motion' New commands: `vm-toggle-thread' (T), `vm-expand-all-threads' (E) and `vm-collapse-all-threads' (C). See the info file for details. Thanks to Arik Mitschang for this contribution. * New experimental feature: `vm-enable-thread-opeartions' enables "thread operations", a method of invoking operations (such as deleting or saving) on message threads. See the info file for details. Thanks to Arik Mitschang for this contribution. * New variables: `vm-summary-thread-indentation-by-references' controls whether threads are indented by their original nesting level or according to the nesting level within the folder. `vm-summary-maximum-thread-indentation' specifies the maximum depth of indentation to be displayed. * New command: `vm-kill-thread-subtree' (K) allows a thread subtree to be deleted. This amounts to the same thing as `vm-delete-message' invoked as a thread operation. * The calculation of threads improved using Jamie Zawinski's ideas. Threads are correctly identified even if some of the messages are missing. * Added EasyPG storage of passwords for mail server accounts. See info index under "passwords". * Virtual folder facility extended to work with POP and IMAP folders. But, there are still some outstanding problems with it. * Resolved performance problems in summary generation. It works quite fast now. * New variable: `vm-mime-parts-display-separator' allows you to insert a string as a separator between MIME parts. * New command: `vm-save-attachments' allows you to save all the attachments of a message under your own file names instead of the original file names given in the message. * New command: `vm-flag-message-read' (.) allows you to mark an unread or new message as read. BUG FIXES * Fixed various issues flagged by the Emacs 23 compiler warnings. VM 8.1.925a (2010-07-17) VM 8.1.92a (2010-07-10) IMPROVEMENTS * Headers-only mode (external messages) for IMAP folders is now completed. It operates by fetching messages into the Folder buffers, leading to a more reliable operation. * New command `vm-list-imap-folders' can be used to list the folders on an IMAP server. * In headers-only mode for external messages, a limited number of messages can be fetched on demand for message preview. New variable `vm-fetched-message-max' specifies this number. (Default is 10.) * New variable `vm-imap-default-account' allows IMAP-FCC copies to be routed there. * New variable `vm-imap-server-timeout' allows timeout during a wait for output from an IMAP server. * New variable `vm-imap-ensure-active-sessions' asks VM to ensure that an IMAP session is active before issuing commands. VM 8.1.90a (2010-05-11) IMPROVEMENTS: ** This version contains an experimental feature of using IMAP folders in "headers-only" mode for external server messages, with body loaded only on demand. This helps to keep the folder sizes small and VM to run faster. However, this code is in a preliminary stage. Please use it with CAUTION. variable: vm-load-headers-only (or vm-enable-external-messages) If set to t, all new messages will be loaded to the cache-folder in headers-only mode. The body is loaded on demand when a message is displayed in the Presentation Buffer. This is a temporary load and is lost as soon as you move to another message. To permanently load a message body into the Folder Buffer, use: command: vm-load-message (bound to 'o') This command discards the current body of the message, if any, and refreshes it from the server copy. command : vm-unload-message (bound to 'O') This command discards the current body of the message from the Folder Buffer and leaves it empty. FAILURE RECOVERY: If the cache folder gets corrupted for any reason, just delete it from the file system. A new cache folder will be generated upon the next visit. * New variable `vm-imap-refer-to-inbox-by-account-name' allows IMAP folders named "INBOX" to be referred to by their account names inside VM. * The command `vm-fix-my-summary!!!' renamed to `vm-fix-my-summary' to make it easier to type. * The chatter of minibuffer messages during paging of mail is reduced: messages about MIME decoding are emitted only if the new variable `vm-emit-messages-for-mime-decoding' is non-nil, and messages about end of messages are emitted only of `vm-auto-next-message' is non-nil. * IMAP session dialogue restructured using UID queries, which makes VM more reliable in handling real-time changes on the server side. * New variable `vm-imap-connection-mode' can be set to 'offline to allow IMAP cache folders to be used offline. After connecting to the network, do `C-u M-x vm-imap-synchronize' to force full synchronization. * Improved error messages arising in IMAP sessions wih the server. * New variable `vm-do-fcc-before-mime-encode' (formerly in vm-rfaddons) allows you to save fcc copies of messages before mime-encoding them. ** New variables `vm-expunge-before-quit' and `vm-expunge-before-save' introduced to allow automatic expunge. They are nil by default. VM 8.1.2 * VM made safe for use with Gnu Emacs 23, by removing a few calls to the `next-line' function (which was redefined in this Emacs). * Several critical problems with Thunderbird inter-operability were corrected. Manual section on Thunderbird folders added. * Extended Org mode email links to work for virtual folders. CHANGES ** The default values of `vm-pop-expunge-after-retrieving' and `vm-imap-expunge-after-retrieving' changed to nil to help new users. * `vm-fill-long-lines-in-reply' initialized to the default value of `fill-column'. * All MIME messages are now decoded in the Presentation buffer, unless they have US-ASCII as their charset. In particular, messages with 8bit charsets are treated this way. Such messages are not regarded "plain messages" any more. VM 8.1.1 (2010-04-26) ** The variable vm-always-use-presentation-buffer is deprecated. Please remove all settings for this variable in your init file. The default behaviour will be to always use the presentation buffer. Report any problems that might arise as a result. * Extended Org mode email links to handle POP and IMAP folders. (Use org-vm.el in the VM contrib directory until the Org mode distribution gets updated.) * Added autoloads for easy inter-operation with the Org mode. * Added a section on History and Administration in the info manual. * Made the autoloads compatible with VM 7.19 instructions. * Fixed the build process to treat version info better. * Removed a few incompatibilites with XEmacs. * Mode line format reverted to the original one in 7.19. The new mode line format is available in the variable `vm-mode-line-format-robf'. It can be installed by adding a vm-mode-hook. VM 8.1.0 (2010-03-21) KNOWN PROBLEMS: * Automatic filling is turned off for some plain text messages for safety reasons. Please help us by sending us sample messages for which filling fails. * IMAP folders occasionally give spurious connection errors. Doing vm-get-new-mail ('g') resumes the connection. MAJOR NEW FEATURES: * Support for reading and replying to messages in HTML. * Full support for IMAP servers. (See "IMPROVEMENTS for imap-folders" below.) CHANGES: ** New boolean variable `vm-word-wrap-paragraphs' controls the word wrapping of paragraphs in messages using the longlines library. The variable is set to nil by default. When it is set to t, paragraphs are word wrapped and the value of the variable `vm-fill-paragraphs-containing-long-lines' is immaterial (as long it is non-nil). Set vm-word-wrap-paragraphs to nil to enable the usual filling functionality. ** vm-pgg is not loaded by default because it is a set up as an add-on. Users should load it from their .emacs file by using the sequence (require 'vm-autoloads) (require 'vm-pgg) ** The variable `vm-mime-show-alternatives' is deprecated. Set the variable `vm-mime-alternative-show-method' to 'all to get the same effect. * Moved Robert's user-defined summary functions to the core: - S for human readable size - P for indication of attachments - p for indication of a postponed message IMPROVEMENTS: * Display number of drafts and postponed messages in the modeline and use a more compact modeline. To use this feature, include this line in your .vm file: (setq vm-mode-line-format vm-mode-line-format-robf) * The variable `vm-paragraph-fill-column', previously removed in earlier versions of this release, is brought back. ** The commands `vm-mime-save-all-attachments' and `vm-mime-delete-all-attachments' have been moved to the VM core (from vm-rfaddons). New variables: vm-mime-deletable-types (formerly `vm-mime-delete-all-attachments-types') vm-mime-deletable-type-exceptions (formerly `vm-mime-delete-all-attachments-types-exceptions') vm-mime-savable-types (formerly `vm-mime-save-all-attachments-types') vm-mime-savable-type-exceptions (formerly `vm-mime-save-all-attachments-types-exceptions') vm-mime-attachment-save-directory vm-mime-attachment-source-directory vm-mime-all-attachments-directory See the info file section on MIME attachments for details. The options for vm-rfaddons.el should not include `save-all-attachments' and should be removed if it is currently being used. The option `take-action-on-attachments' is not included by default. * `vm-quit-no-change' offers to delete the auto-save file if there is one. (This wasn't getting done due to a bug in FSF Emacs.) * `vm-delete-duplicate-messages' now works by comparing message ID's. (from Noah Friedman's vm-addons). * New boolean variable `vm-sort-threads-by-youngest-date' allows threads to be sorted by their youngest date or oldest date. * `vm-yank-message' function streamlined a bit. New variable `vm-include-text-from-presentation' can be used to extract the included message text from the presentation buffer. ** text/html handling controlled by a new variable `vm-mime-text/html-handler' which is set to 'auto-select by default. It causes VM to locate the best library among emacs-w3m, external w3m, w3 and lynx to display html internally. (This replaces the earlier variable `vm-mime-use-w3-for-text/html'.) ** vm-delete-duplicate-messages now works by comparing message ID's. (from Noah Friedman's vm-addons). * vm-yank-message function streamlined somewhat. New variable `vm-include-text-from-presentation' used to extract message text from presentation buffer. (This replaces the variable `vm-reply-include-presentation' used in vm-rfaddons.) * The variable `vm-mime-yank-attachments' is set to nil by default, so that we are not surprised by unexpectedly large mail messages. * The variable `vm-mime-require-mime-version-header' is set to nil by default, so that we will be tolerant of bad MIME senders. * Allow for sorting the headers of composition buffers by calling the function `vm-reorder-message-headers' interactively. You may configure the order by the new variable `vm-mail-header-order'. This can be useful if some broken MUAs (e.g. Tobit) mess up the messages due to the header order. * Added hiding and protection of headers in composition buffers. See the new variable `vm-mail-mode-hidden-headers' for customization. (Thanks to Eric Schulte for the initial code posted in gnu.emacs.vm.info) * Added the function `vm-mime-list-part-structure' to list the mime part structure of a message. * Added function `vm-mime-nuke-alternative-text/html' which can be used to get rid of alternative text/html parts. * VMPC: Better action reader and a default profile which is used if no email addresses could be found. The meaning of the arguments for `vmpc-prompt-for-profile' has been slightly simplified, see the doc string for details. * Removed `vm-paragraph-fill-column', the value is now taken from `vm-fill-paragraphs-containing-long-lines' thus allowing to fill to the available window with. * Replaced `vm-fill-paragraphs-containing-long-lines' by the faster and more flexible version from vm-rfaddons.el. Also cleaned up calls to the fill function and removed code duplication. The code using longline.el remains in vm-rfaddons.el, but it must be used explicitly now in an advice. * Moved the variable `vm-fill-long-lines-in-reply-column' from vm-rfaddons.el to VM core. It is not necessary to hook the fill function, just set the variable. * Errors caused by `vm-retrieved-spooled-mail-hook' are reported and assimilation of messages continues instead of aborting. * Handle filenames also from the disposition fields "name", "filename*" and "name*", where the latter two get decoded as they might contain 8bit chars. * Uncoupled searching of MIME images from source location. The search should be a bit smarter now allowing to place the images outside of the source tree now. * Added syncing of message status when visiting a mbox of Thunderbird. Not all message flags are interchangeable and the message summary file (.msf) of Thunderbird will get removed by VM in order to force Thunderbird to rebuild it. Also VMs folder index will be skipped if it is older than the folder in order to update VMs message status flags. * Improved text/html displaying by w3m. Inline images are now extracted correctly and they also display now. Added a generic handler code to support also other HTML handlers. * Added variable `vm-restore-saved-summary-formats' to restore each folder's summary format to what was saved previously. (Uday S. Reddy) * A prefix argument to `vm-fix-my-summary!!!' will kill a folders local summary format which was restored by `vm-restore-saved-summary-formats'. * The button for an image or PDF shows a thumbnail now when possible. This requires ImageMagick. (Thanks to Eric Schulte for the idea and initial code.) * Allow to reorder messages headers before sending by setting the new variable `vm-mail-reorder-message-headers'. * Allow UTF-8 encoded messages to be displayed on tty. (Ulrich Müller) BUG FIXES * `vm-quit-no-change' made to honour the setting of the variable `delete-auto-save-files'. (Uday S. Reddy) * Allow the use of iso-8859-1 for outgoing mail under Emacs 23 (instead of spurious iso-2022-jp). (Ulrich Müller) * Coding system set to binary when reading and writing to allow for 8-bit content. (Julian Bradfield) IMPROVEMENTS for pop-folders (Uday S. Reddy) * Added the variable `vm-pop-debug' to keep trace buffers. * New commands `vm-pop-start-bug-report' and `vm-pop-submit-bug-report' which track POP session details. IMPROVEMENTS for imap-folders (Uday S. Reddy) ** New variable `vm-imap-account-alist' allows multiple IMAP accounts to be handled uniformly. The variable `vm-imap-server-list' is now obsolete. IMAP folders should be specified in the minibuffer using the account:mailbox format. See the info node on IMAP folders. * New variable `vm-load-headers-only' to enable headers-only downloading of IMAP folders. (This is still experimental.) * IMAP-FCC is extended to work for virtual folders, but only if the real parent message is an IMAP message. * Made server expunge more robust. Added new variable `vm-imap-expunge-retries' to force retries for sluggish servers. * Allow message attributes as well as labels to be saved on server. * Changed vm-imap-get-new-mail to do synchronization: reading and writing message attributes & labels, expunge messages in the cache. Added variable `vm-imap-sync-on-get' to control this behavior. * Added command `vm-imap-synchronize' to do full synchronization. * Trapping IMAP server errors uniformly. * Added variable `vm-imap-tolerant-of-bad-imap' to allow minor violations of the IMAP spec by IMAP servers. * New commands `vm-imap-start-bug-report' and `vm-imap-submit-bug-report' which track IMAP session details. VM 8.0.14 2009-12-16 BUGFIXES * Removed an incompatibility of the mapvector procedure with XEmacs. VM 8.0.13 2009-11-29 MANAGEMENT CHANGES: * VM being maintained by "VM development team", vm@lists.launchpad.net, consisting of Robert Fenk, Uday Reddy and Ulrich Müller. BUGFIXES: * VM-Cache entries were broken by encoding the pretty printed cache string instead of the individual strings. This bug was introduced in 8.0.10 by the bug fix for correctly storing the cached multibyte summary entries. It causes building of the summary to fail. Broken cache entries are now detected and removed while loading a folder. VM 8.0.12 2008-11-05 IMPROVEMENTS: * Display version info when calling `vm-version' interactively. (Thanks to Ulrich Müller) * Yanking of messages uses the same MIME decoding as the presentation now. See the new variable `vm-mime-yank-attachments' to configure if attachments are also yanked. * `u-vm-color.el' is bundled and maintained with VM now. Ulf Jasper handed it over to me as he switched to Gnus. BUGFIXES: * Detect w3 by using `locate-library' instead of checking for a bound `w3-about'. (Thanks to Klaus Straubinger) * vm.revno.el was not installed anymore b "make install". (Thanks to Ulrich Müller for reporting) * Insert `emacs-version' instead of creating wrong version string for XEmacs, i.e. the patch level was the major version. (Thanks to Stephen Turnbull) * Correctly locate the data directory for the pixmaps when running as a XEmacs package. * Check for some MIME character sets that may be available in recent XEmacs. (Thanks to Aidan Kehoe for the patch) * Some documentation fixes. (Thanks to Michael Ernst for the patches) * Fixed infinite loop in vm-mime-encode-words on XEmacs 21.5-b28. (Thanks to Aidan Kehoe for the patch) * Detect "score" (additionally to "hits") in "X-Spam-Status:" headers in `vm-su-spam-score-aux'. (Patch from Michael Ernst) * Typo fix in vm-pcrisis.texinfo. (Patch from Michael Ernst) * Header encoding was BASE64 instead of QP by default and it was not encoding whole words, but only the 8bit chars instead. (Thanks to Ulrich Müller for reporting) * MIME text parts interleaved by attachments are now correctly yanked, e.g. when replying to a message. * Limit the buffer-name length and sanitize the used characters. (Thanks to Mark Diekhans for reporting) * Do not fail on corrupted address headers. (Reported by John Covici) * Fixed GTK detection and toolbar handling for newer Emacs 22 versions. Public bug reported: VM 8.0.11 2008-08-11 BUGFIXES: * Removed dependency of vm-revno.el to other lisp sources to avoid building it in a release bundle. (Thanks to Ralf Fassel) VM 8.0.10 2008-07-22 NOTES: * This is the first version of VM 8.* to be also released as a XEmacs package. IMPROVEMENTS: * Added missing documentation for `vm-user-agent', "?" binding and 'vm-delete-duplicate-messages'. (Thanks to Alan Wehmann) * `vm-message-history.el' now uses a buffer similar to the summary for browsing the history. The buffer replaces the summary buffer when present. Duplicate history entries will be removed. * Define and use `vm-replace-in-string' which is `replace-in-string' from XEmacs to avoid clashes with other GNU Emacs packages defining it differently. Unfortunately, GNU Emacs still does not provide this handy function. (Thanks to José Miguel Figueroa) * MIME encoding of header will automatically happen now and has been moved from `vm-rfaddons.el' to `vm-mime.el' and `vm-vars.el'. BUGFIXES: * Rewrote `vm-message-history.el' to also work for XEmacs. * Leading lines of a yanked message were accidently taken as headers and got removed if `vm-reply-include-presentation' was t. * Fixed encoding of headers for trailing 8 bit characters. (Thanks to Lutz Euler for the patch) * Decode (QP-)encoded clear text before decrypting it. * Use nil as default for `vm-mime-8bit-composition-charset' and thus enable proper detection of right charset. (Thanks to Naoki Saito for reporting and debugging) * Fixed bug in `vm-mime-display-external-generic' for GNU Emacs 23 causing corrupted content in the output file. The old code has been replaced by a call to `vm-mime-send-body-to-file' which avoids duplication and works. There has been some special handling for `vm-fsfemacs-mule-p', but the actual reason for this was unclear so it has been removed. * Correctly handle `vm-enable-addons' being t. * Correctly store UTF-8 strings in the X-VM-v5-Data header to avoid corruption of summary lines. (Thanks to Yuning Feng for reporting) * Correctly encode multibyte subjects. (Thanks to Yuning Feng for the patch) * Use BASE64 for header encoding when there are special chars not quoted by QP normally. You may configure this by `vm-mime-encode-headers-type'. * qp-decode program handles premature end of QP-encoded stream now gracefully. (Thanks to Ralf Fassel for the bug report, fix and testing) * Added missing newline after "Content-Type" when using the command `vm-mime-attach-object-from-message'. (Thanks to Dan Freed) VM 8.0.9 2008-02-20 BUGFIXES: * Added documentation to `vm-mime-external-content-types-alist' that no extra single quotes should be used around %f as the file name is already quoted for the shell. (Thanks to Martin Schwenke) * Fixed version number generation in release script. It was broken for 8.0.8, i.e. it was showing 8.0.x-xemacs-542 instead. Now also other branch related information is stored in the file vm-revno.el. VM 8.0.8 2008-02-11 IMPROVEMENTS: * Reactivated "Allow defadvice on function `vm' by recursing on session start". It should work correctly now. * Added interactive `vm-pipe-message-to-command-discard-output' and the non-interactive `vm-pipe-message-to-command-to-string' for using it in own functions. * Added `vm-pipe-messages-to-command*' for bulk piping messages to a single command, i.e. like saving to a pipe. This is substantially faster than `vm-pipe-message-to-command*' which call the command on each message separately. You may want to use it to feed spamassasin. * Modified key bindings for piping messages, i.e. "|" is a prefix key now. Type it twice to get the old pipe command, "|d" will call the discard the output, just display some infos in the mode line. "|s" will call `vm-pipe-messages-to-command' and "|n" will also call it but discard the output. * Removed vm-easymenu.el and use easymenu.el instead. * In `vm-save-message-preview', ask the user if the output file already exists instead of silently overwriting it. BUG FIXES: * Moved [Undo] to Dispose menu and [Emacs] to Help menu as these do not work in Emacs 22 anymore when on the menu bar. * Fixed intermixing of signature and quoted text in reply if `vm-reply-include-presentation' is t. (Thanks to Roland Winkler for debugging and reporting) * Fixed yanking of presentation from wrong folder when folder is virtual. (Thanks to Roland Winkler for reporting) * Redistributed flag not displayed in presentation buffer mode line. https://bugzilla.redhat.com/show_bug.cgi?id=428248 (Thanks to Jonathan Underwood for the fix) * `vm-submit-bug-report' gets the variables dynamically now and thus does not miss new ones or references old ones anymore. * Correctly determine the real folder when postponing compositions started from a virtual folder. (Thanks to Uday S. Reddy for reporting and debugging) * Avoid crash when `vm-mouse-set-mouse-track-highlight' is not called within a summary buffer or without a valid message pointer. * Do not disable modes which do not exist. (Thanks to Uday S. Reddy for reporting) * Set correct coding-system-for-read for the real messages of virtual folders. (Thanks to Julian Bradfield) VM 8.0.7 2008-01-05 BUG FIXES: * Disable only those minor modes listed in the variable `vm-disable-modes-before-encoding' before encoding a composition. (Thanks to Alley for reporting and debugging) * Removed recursion from function `vm' added by 8.0.6, as it causes startup troubles. * Removed extra newline before attachment buttons. (Thanks to Alley for reporting) * Removed wrongly used calls to `interactive-p'. (Thanks to Alley for reporting and debugging) VM 8.0.6 2008-01-02 IMPROVEMENTS: * Rewrote INSTALL to be more consistent and more understandable. * Allow defadvice on function `vm' by recursing on session start. (Thanks to Blueman for the code) BUG FIXES: * Ignore empty reply-to in `vm-ignored-reply-to'. * Quoted the variable `vm-summary-format' in a doc string. * Fixed typos in the docstring of `vm-mail-send-and-exit'. * Disable all minor modes before encoding a composition. This results in faster encoding when font-lock was enabled and avoids problems when parts of a MIME object button get expanded due to an abbrev and thus the extent/overlay gets split into two separate parts causing an encoding error. * Avoid duplicate mime buttons during decoding. (Thanks to Alley for reporting) * Mask 8 bit chars by 0xff in `vm-mime-qp-encode-region' to avoid crash for those with all higher order bits set (negative ones?) (Thanks to Blueman for the fix.) VM 8.0.5 2007-11-03 BUG FIXES: * Fixed bug caused by fixing `vm-drop-buffer-name-chars' in 8.0.4. There is a 20-40% chance to create a new bug when fixing one. Regression tests would be nice, but we do not have any for VM ;-/ VM 8.0.4 2007-11-02 IMPROVEMENTS: * Require cl.el at compile-time only. (Thanks to John J. Foerch) * Quiet compiler warning about old style backquotes. (Thanks to John J. Foerch) BUG FIXES: * Correctly call custom-add-load. (Thanks to John J. Foerch and Jonathan.underwood) * Fixed building of vm-cus-load.el for Emacs 21. * Use the old default for `vm-primary-inbox', i.e. "~/INBOX". * Honor a t in `vm-drop-buffer-name-chars' as documented. VM 8.0.3 2007-08-15 IMPROVEMENTS: * Unified `vm-continue-what-message', i.e. first check for composition buffers, if none exist then for saved drafts. Also added new variable `vm-zero-drafts-start-compose'. BUG FIXES: * Fixed building of autoloads for GNU Emacs. * Docfixes for vm-pine.el (Thanks to Stephen Eglen). * Resurrected `vm-add-reply-subject-prefix' which was lost by the commit of revno 91. * Search for BZR only if bzrdir exists and use locate-file only when defined. * Use vm-mime-8bit-composition-charset as a fallback also for MULE Emacs. * Fixed defcustom of vm-keep-crash-boxes and vm-spool-files. * Fixed the section headers of the NEWS file. VM 8.0.2 2007-07-25 IMPROVEMENTS: * Added --with-pixmapdir to configure the location of the pixmaps. * DESTDIR-Patch (Ulrich Müller). BUG FIXES: * Avoid overflow of `buffer-undo-list' when inserting or encoding big attachments. * defcustom of `vm-mime-all-attachments-directory' should list nil. * Honor pre VM 8.0.0 values of `vm-folder-directory' and `vm-primary-inbox'. This should eliminate problems with users which never changed the defaults. * Use "cygwin-mount" to fix paths when available. * Activate summary faces only when requested by vm-enable-addons. * Fixed defcustom of `vm-enable-addons' and added documentation. * "make install" creates $(bindir) now. * Separate paths (e.g. otherdirs) only by semicolons to avoid problems on Win32. * Handle paths with spaces correctly. * Install also pixmaps for GTK enabled Emacs. * Just use the first subject when replying/forwarding to a set of messages. This avoids long filenames for saved composition buffers. * Ensure we are compiling with an emacs version >= 21. * Encode headers regexp and case-fold-search corrected. (Ulrich Müller) * vm-summary-faces-mode does not leak extents anymore. VM 8.0.1 2007-06-29 NOTES: In order to get more features from vm-rfaddons set the variable `vm-enable-addons' in your ~/.vm. BUG FIXES: * A saner default for vm-shrunken-header-face. * Added documentation on vm-shrunken-headers-face and vm-shrunken-headers-keymap. * Added a new custom group `vm-faces' for faces. * Added autoload token for vm-user-agent. * Use INSTALL_PROGRAM instead of INSTALL_DATA for programs. * Do not set vm-folder-directory if there is ~/INBOX. If VM does not get mail after upgrading from 7.19 it is probably due to the new default for vm-folder-directory, which was nil before. * Revised the bindings and enabled features to a hopefully less controversial setting. VM 8.0.0 2007-05-31 NOTES: VM is now in my hands and I will do my best to keep it alive! -- Robert ,-------------------------------------------------------------------------- | From: Kyle Jones | To: Robert Widhopf-Fenk | Date: Wed, 21 Feb 2007 13:11:32 -0800 | Subject: Handing over VM? | | Robert Widhopf-Fenk writes: | > Hi Kyle, | > | > I have been maintaining VM "unofficially" for the last few | > years and now I want to become the official maintainer of | > VM. | > | > Do I get your OK? | | Yes. Obviously I've moved on, though I've been slow to admit it | to myself. Good luck. `-------------------------------------------------------------------------- * My (robf) VM extensions are now activated by default, where it makes sense to me. * Releases are numbered now MAJOR.MINOR.PATCHLEVEL, where MAJOR is increased when fundamental changes occur, MINOR for new features and PATCHLEVEL for bugfix releases. * New cleaner source tree layout. * Better built system based on configure. Autoloads are generated only for those functions marked with the autoload token now, which are mainly interactive function. Thus, loading occurs only on demand and startup should be faster. BUG FIXES: * All bugs reported to gnu.emacs.vm.bugs, gnu.emacs.vm.info and directly to me are fixed either by the patches posted by others or me. * If there are any missing autoloads, please report them and add a (require 'vm-SOURCE) to your ~/.vm! * Probably added numerous new bugs. IMPROVEMENTS: compared to 7.19 (not vmrf) * A new icon set based on vm-small-pixmaps.tgz which was floating around. This one should fit by height to the one used in XEmacs and Emacs 22, but it is slightly larger than those used in Emacs 21. If you see the old icons, the please set the variables `vm-image-directory' and `vm-toolbar-pixmap-directory' to nil in your ~/.vm! * vm-mime-type-converter-alist now also works when replying to messages, i.e. for text/html one can use lynx or w3m for the conversion. (setq vm-mime-type-converter-alist '(("text/html" "text/plain" "lynx -force_html -dump /dev/stdin"))) * Postponing (draft handling) of compositions and continuing of drafts, in fact any messages also those from other people. (Info node: Sending Messages) * New mail header insertion functions for return-receipts, mail-priority and FCC. * More virtual folder selectors and replacements of other functions based on selectors. (Info node: Virtual Folders) * vm-serial.el provides message templates for composition and personalizes mass emails. (Info node: TODO) * vm-biff.el for popups with a list of new messages. * vm-rfaddons.el has various stuff, look at the source if you are curious or miss some VM feature, as it might already be there! VMRF 7.19.187 2006-10-12 VMRF 2006-09 Mentioned on gnu.emacs.vm.info as a fork. Local Variables: mode: text coding: utf-8 End: vm-8.2.0b/contrib/0002755000175000017500000000000011676442161014231 5ustar srivastasrivastavm-8.2.0b/contrib/org-html-mail.el0000755000175000017500000000676211676442160017237 0ustar srivastasrivasta;; Copyright © 2008 Eric Schulte ;; ;; WYSWYG, html mail composition using orgmode ;; ;; For mail composed using the orgstruct-mode minor mode, this ;; provides the option of sending the mail in html format using ;; org-export-as-html. ;; ;; To use place this file in your path, and add the following to you ;; .emacs file ;; ;; ;; org-mode in my mail ;; (defun turn-on-full-org-mailing () ;; ;;(turn-on-orgstruct) ;; (turn-on-orgstruct++) ;; (turn-on-orgtbl) ;; (load "org-html-mail.el")) ;; (add-hook 'mail-mode-hook 'turn-on-full-org-mailing) ;; ;; Then when composing mail send as an html message by using a prefix ;; argument on the send command, so "\C-u\C-c\C-c". Your mail will be ;; converted to html using org's export command, the appropriate mime ;; headers will be attached, and then your normal send command will be ;; executed. ;; ;; For discussion see "sending html mail using VM" at ;; http://groups.google.com/group/gnu.emacs.vm.info/browse_frm/month/2008-01 (defun orgstruct-hijacker-command-21 (arg) "In Structure, run `org-ctrl-c-ctrl-c'. Outside of Structure check for a prefix argument and if buffer name contains `mail', and run orgstruct-send-as-html, or run the binding of `\C-c\C-c'." (interactive "p") (vm-inform 6 "calling html send mail") (save-excursion (if (org-context-p (quote headline) (quote item)) (org-run-like-in-org-mode (quote org-ctrl-c-ctrl-c)) (if (orgstruct-send-as-html-should-i-p arg) (progn (vm-inform 6 "sending as html mail") (orgstruct-send-as-html)) (let (orgstruct-mode) (call-interactively (key-binding "\C-c\C-c"))))))) (defun orgstruct-send-as-html-should-i-p (arg) "lets be pretty sure we have a prefix argument and are actually in a mail buffer" (goto-char (point-min)) (if (and arg (> arg 1) (equal major-mode 'mail-mode)) t)) (defun orgstruct-send-as-html () "Export the body of the mail message to html using `org-export-as-html' then send the results as a text/html Content-Type message" ;; adjust mime type (goto-char (point-min)) (insert "MIME-Version: 1.0\n") (insert "Content-Type: text/html\n") (search-forward mail-header-separator) (let* ((mail-text-point (point)) (mail-buffer (current-buffer)) ;; have to write the file because org needs a path to export (tmp-file (make-temp-name (expand-file-name "mail" temporary-file-directory))) ;; because we probably don't want to skip part of our mail (org-export-skip-text-before-1st-heading nil) ;; makes the replies with ">"s look nicer (org-export-preserve-breaks t) ;; takes care of setting all my org-local-vars, if no ;; previous org usage (org-local-vars (or org-local-vars (org-get-local-variables))) (html (progn (write-file tmp-file) ;; convert to html ;; mimicing org-run-like-in-org-mode (eval (list 'let org-local-vars (list 'org-export-region-as-html 'mail-text-point '(point-max) 't ''string)))))) (switch-to-buffer mail-buffer) (set-visited-file-name nil) (delete-file tmp-file) ;; replace text with html (goto-char mail-text-point) (delete-region (point) (point-max)) (insert "\n") (insert html) ;; send the mail (let (orgstruct-mode) (call-interactively (key-binding "\C-c\C-c"))))) vm-8.2.0b/contrib/vm-blueman.el0000755000175000017500000000771111676442160016624 0ustar srivastasrivasta;From: blueman ;Subject: Function to fit displayed mime images to width ;Newsgroups: gnu.emacs.vm.info ;Date: Tue, 12 Dec 2006 18:07:44 GMT ;Was going through some old code and would like to share this helpful ;function.. ;; Stretch/Shrink mime image to fit exactly in frame width. ;; The shrink functionality is particularly helpful since images displayed ;; by emacs look wacked when they extend past a line width (defun vm-mime-fitwidth-image (extent) "Stretch/Shrink mime image to fit exactly in frame width (JJK)." (let* ((layout (vm-extent-property extent 'vm-mime-layout)) (blob (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx)) dims tempfile factor) ;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+. ;; The cache blob is a list in that case. (if (consp blob) (setq tempfile (car blob)) (setq tempfile blob)) (setq dims (vm-get-image-dimensions tempfile)) (setq factor (/ (float (* (1- (frame-width)) (frame-char-width))) (car dims))) (vm-mime-frob-image-xxxx extent "-scale" (concat (int-to-string (* factor (car dims))) "x" (int-to-string (* factor (nth 1 dims))))))) ;; Functionality to add above function to standard attachment menu (add-hook 'vm-menu-setup-hook (lambda () (require 'easymenu) (easy-menu-add-item vm-menu-fsfemacs-image-menu nil ["Fit to width" (vm-mime-run-display-function-at-point 'vm-mime-fitwidth-image) (stringp vm-imagemagick-convert-program)] "4x Larger" ) (easy-menu-add-item vm-menu-fsfemacs-attachment-menu nil ["Save attachment..." (vm-mime-run-display-function-at-point 'vm-mime-send-body-to-file) t ] "Set Content Disposition..." ) (easy-menu-add-item vm-menu-fsfemacs-attachment-menu nil ["Delete attachment..." (vm-delete-mime-object) t ] "Set Content Disposition..." ) (easy-menu-add-item vm-menu-fsfemacs-attachment-menu nil ["Attach to message..." (vm-mime-run-display-function-at-point 'vm-attach-object-to-composition) t ] "Set Content Disposition..." ) (easy-menu-add-item vm-menu-fsfemacs-attachment-menu nil ["Display as Ascii" (vm-mime-run-display-function-at-point 'vm-mime-display-body-as-text) t ] "Set Content Disposition..." ) (easy-menu-add-item vm-menu-fsfemacs-attachment-menu nil ["Pipe to Command" (vm-mime-run-display-function-at-point 'vm-mime-pipe-body-to-queried-command-discard-output) t ] "Set Content Disposition..." ) )) ;From: blueman ;Subject: Function to retrieve mail via fetchmail from emacs/vm ;Newsgroups: gnu.emacs.vm.info ;Date: Tue, 12 Dec 2006 18:31:57 GMT ;Was going through some old code and would like to share this helpful ;function.. ;Note this runs the users local fetchmail process as configured by ;~/.fetchmailrc (defun vm-fetchmail () "*Fetch mail asynchronously from remote server (JJK)" (interactive) (cond ((file-executable-p vm-fetchmail-function) (set-process-sentinel (start-process "Fetchmail" "*Fetchmail*" vm-fetchmail-function) 'vm-fetchmail-sentinel) (vm-inform 5 "Fetching new mail...")) (t (error "Error: Fetchmail not found on system!")))) (defvar vm-fetchmail-function "/usr/bin/fetchmail" "Function used to fetch remote mail (JJK)") (defun vm-fetchmail-sentinel (process status) (beep t) (setq status (substring status -2 -1)) (vm-inform 5 "Finished fetching... %s" (if (string= status "d") "*New mail*" (setq status (string-to-number status)) (cond ((= status 1) "No new mail") ((= status 2) "Error opening socket") ((= status 3) "User authentication failed") ((= status 4) "Fatal protocol error") ((= status 5) "Syntax error") ((= status 6) "Bad permissions on run control file") ((= status 7) "Error condition reported by server") ((= status 8) "Client-side exclusion error") ((= status 9) "Lock busy") (t "Other error"))))) vm-8.2.0b/contrib/vm-sumurg.el0000755000175000017500000010731611676442160016525 0ustar srivastasrivasta;; $Header: /home/jcb/Source/Emacs/RCS/vm-sumurg.el,v 1.30 2011/12/19 14:55:59 jcb Exp $ ;;; vm-sumurg.el -- Adding urgency indicators to summary ;; ;; This file is an add-on for VM ;; ;; Copyright (C) 2011 Julian Bradfield ;; ;; Author: Julian Bradfield ;; Status: Tested for VM 8.2.x running under XEmacs ;; Keywords: VM helpers ;; X-URL: http://homepages.inf.ed.ac.uk/jcb/Software/emacs/ ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License along ;; with this program; if not, write to the Free Software Foundation, Inc., ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. ;;; Commentary: ;; This file provides an add-on to VM so that messages with certain ;; labels are tagged in bright colours, associated with urgency levels. ;; Messages labelled "*" (urgency level 1) are yellow; ;; Messages labelled "**" (urgency level 2) are orange; ;; Messages labelled "***" (urgency level 3) are red. ;; Messages labelled "****" (urgency level 4) are blinking magenta! ;; The summary modeline contains a count of the number of urgent messages. ;; A virtual folder with messages of urgency level n can be obtained ;; by V U n, or by middle-clicking on the count in the modeline. ;; It also puts a count of composition buffers in the modeline, in green, ;; to remind you that they're there. ;; In addition, messages can be set to become urgent in the future. ;; ;; The main interface is vm-sumurg-set-urgency, which see. ;; This is not bound to a key here, as VM binds all sensible keys ;; already. I bind it to * with ;; (define-key vm-mode-map "*" 'vm-sumurg-set-urgency) ;; but that overrides the default binding to vm-burst-digest. ;; ;; At one time, this worked on FSF Emacs, but I haven't tried it for ;; a long time; it's only known to work on XEmacs. ;;; Code: (require 'vm) (require 'vm-summary) (require 'vm-vars) (require 'vm-undo) (require 'vm-folder) (require 'vm-message) (require 'vm-macro) (require 'vm-misc) ; this is the list of colours associated with each urgency level. ; it is customizable only before loading---subsequent changes will ; not affect the faces used in the summary. ; It is an array indexed by urgency level. The 0th entry is used ; for hacky internal purposes. (defvar vm-sumurg-colarray [ nil "yellow" "orange" "red" "magenta" ]) ; colour for the composition buffer reminder (defvar vm-sumurg-compcolor "green") (make-face 'vm-sumurg-rightnow-face) (set-face-background 'vm-sumurg-rightnow-face (aref vm-sumurg-colarray 4)) (set-face-foreground 'vm-sumurg-rightnow-face "white") (set-face-blinking-p 'vm-sumurg-rightnow-face t) (make-face 'vm-sumurg-veryurgent-face) (set-face-background 'vm-sumurg-veryurgent-face (aref vm-sumurg-colarray 3)) (set-face-foreground 'vm-sumurg-veryurgent-face "white") (make-face 'vm-sumurg-urgent-face) (set-face-background 'vm-sumurg-urgent-face (aref vm-sumurg-colarray 2)) (set-face-foreground 'vm-sumurg-urgent-face "black") (make-face 'vm-sumurg-pending-face) (set-face-background 'vm-sumurg-pending-face (aref vm-sumurg-colarray 1)) (set-face-foreground 'vm-sumurg-pending-face "black") (make-face 'vm-sumurg-comp-face) (set-face-background 'vm-sumurg-comp-face vm-sumurg-compcolor) (set-face-foreground 'vm-sumurg-comp-face "black") ; stick the faces into an array for convenience ; note that this is inserting facenames, not faces (defconst vm-sumurg-facearray [ nil vm-sumurg-pending-face vm-sumurg-urgent-face vm-sumurg-veryurgent-face vm-sumurg-rightnow-face ]) ; each of these symbols holds a string to go in the modeline (defconst vm-sumurg-symarray [ nil vm-sumurg-modeline-pending vm-sumurg-modeline-urgent vm-sumurg-modeline-veryurgent vm-sumurg-modeline-rightnow ]) (defun vm-sumurg-level-of (m) (if (member "****" (vm-labels-of m)) 4 (if (member "***" (vm-labels-of m)) 3 (if (member "**" (vm-labels-of m)) 2 (if (member "*" (vm-labels-of m)) 1 0))))) ; assuming that m is a message, highlight it in yellow, orange or red ; according as it has a *, **, or *** label. (defun vm-sumurg-highlight-message () (vm-sumurg-add-highlights (string-to-number (vm-number-of m)) (vm-su-start-of m) (vm-su-end-of m) (vm-sumurg-level-of m) )) (defadvice vm-summary-highlight-region (after vm-sumurg-vshr activate compile) (vm-sumurg-highlight-message)) (defvar vm-sumurg-counter [0 0 0 0 0]) (defvar vm-sumurg-comp-counter 0) (defvar vm-sumurg-comp-counted nil) (make-variable-buffer-local 'vm-sumurg-comp-counted) ;; This is a global (not per buffer) marker of composition buffers (defvar vm-sumurg-modeline-comp nil) (defun vm-sumurg-comp-hook () ; in case mail-mode is switched off and on for some reason (if vm-sumurg-comp-counted t (setq vm-sumurg-comp-counter (1+ vm-sumurg-comp-counter)) (setq vm-sumurg-comp-counted t) ;; set the comp entry (setq vm-sumurg-modeline-comp (if (> vm-sumurg-comp-counter 0) (format "%d%s" vm-sumurg-comp-counter "C"))) (redraw-modeline t))) (add-hook 'mail-mode-hook 'vm-sumurg-comp-hook) (defun vm-sumurg-comp-end-hook () (when vm-sumurg-comp-counted (setq vm-sumurg-comp-counted nil) (setq vm-sumurg-comp-counter (1- vm-sumurg-comp-counter)) ;; set the comp entry (setq vm-sumurg-modeline-comp (if (> vm-sumurg-comp-counter 0) (format "%d%s" vm-sumurg-comp-counter "C"))) (redraw-modeline t))) (add-hook 'vm-mail-send-hook 'vm-sumurg-comp-end-hook) (add-hook 'kill-buffer-hook 'vm-sumurg-comp-end-hook) (defvar vm-sumurg-urgency-array nil) (defvar vm-sumurg-default-time "00:01" "*The time at which urgency changes happen when no specific time is given.") (defun vm-sumurg-set-modeline-entries () ;; map across urgency levels setting the modeline entry ;; and noting which is the highest we have (let ((maxl 0) count) (mapcar (lambda (level) (setq count (aref vm-sumurg-counter level)) (set (aref vm-sumurg-symarray level) (if (> count 0) (format "%d%s" count (substring "****" 0 level)))) (if (> count 0) (setq maxl level))) '( 1 2 3 4)) ;; if there's a rightnow message, enable the blinker, else disable (if (eq maxl 4) (vm-sumurg-blinker-enable) (vm-sumurg-blinker-disable)) ;; in fsfmacs, we can't set faces within the modeline, and it's ;; easy not to notice the urgent flag. So we set the modeline ;; foreground to an appropriate colour for this frame only. ;; This is pretty heavy-handed, but maybe better than nothing. ;; there seems to be no clean way to restore the original foreground. ;; So the summary mode hook stashes in colarray[0], which is then ;; right for this code. ;; ARGH ARGH ARGH FSF LOSSAGE :-) ;; this fails with virtual folders: the modeline in the frame ;; of the original folder isn't updated. ;; I can see absolutely no non-horrible solution to this. (if vm-fsfemacs-p (set-face-foreground 'modeline (aref vm-sumurg-colarray maxl) (selected-frame))))) (defun vm-sumurg-add-highlights (mnum start end level) ;; decrement the counter for the message's previous urgency level (let ((olevel (aref vm-sumurg-urgency-array mnum))) (if (> olevel 0) (aset vm-sumurg-counter olevel (1- (aref vm-sumurg-counter olevel)))) (aset vm-sumurg-urgency-array mnum level) (if (> level 0) (progn (aset vm-sumurg-counter level (1+ (aref vm-sumurg-counter level))) (cond (vm-xemacs-p ;; re-use extents, and delete them when not required (let ((e (extent-at (/ (+ start end)) (current-buffer) 'vm-sumurg))) ;; why not 1- end ? Because the extent is right-open ;; so it gets deleted any by the summary update (see code) (if e t (setq e (make-extent start end)) (set-extent-property e 'start-open t) ;; this was t. But I don't know why, and nil seems ;; to avoid the problem with the selected message ;; not updating. (set-extent-property e 'detachable nil) (set-extent-property e 'vm-sumurg t) ) (set-extent-property e 'face (aref vm-sumurg-facearray level)))) (vm-fsfemacs-p ;; why 1- ? Because then the overlay gets deleted by ;; the process of summary update. (let ((e (make-overlay start (1- end)))) (overlay-put e 'evaporate t) (overlay-put e 'face (aref vm-sumurg-facearray level)))))) ;; level 0: emacs, delete the extent (cond (vm-xemacs-p (let ((e (extent-at (/ (+ start end)) (current-buffer) 'vm-sumurg))) (if e (delete-extent e)))))) (vm-sumurg-set-modeline-entries))) (defvar vm-sumurg-check-pending-in-progress nil) ;; this holds an obarray used to record whether a message has ;; a timer set on it (defvar vm-sumurg-timer-obarray nil) (make-variable-buffer-local 'vm-sumurg-timer-obarray) ;; check a message for a future urgency level, and set a timer (defun vm-sumurg-check-future (m) (mapcar (lambda (label) (when (string-match "^\\(\\*+\\)\\([0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)\\(?:[tT]\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\)?$" label) (let* ((day (string-to-number (match-string 4 label))) (month (string-to-number (match-string 3 label))) (year (string-to-number (match-string 2 label))) (hour 0) (min 0) time tmp (hhmmregex "^\\([0-9][0-9]\\):\\([0-9][0-9]\\)$") (now (current-time)) (level (- (match-end 1) (match-beginning 1))) (vm-message-pointer (list m)) ) (if (match-beginning 5) (progn (setq hour (string-to-number (match-string 5 label))) (setq min (string-to-number (match-string 6 label)))) (when vm-sumurg-default-time (if (string-match hhmmregex vm-sumurg-default-time) (progn (setq hour (string-to-number (match-string 1 vm-sumurg-default-time))) (setq min (string-to-number (match-string 2 vm-sumurg-default-time)))) (message "Trying to fix up default time %s" vm-sumurg-default-time) (condition-case nil (progn (setq tmp (vm-sumurg-parse-date ;; avoid the "add a day to early" (concat "+0 " vm-sumurg-default-time))) (setq vm-sumurg-default-time (format-time-string "%H:%M" (car tmp))) (message "Fixed to %s" vm-sumurg-default-time) (setq tmp (decode-time (car tmp))) (setq hour (nth 2 tmp)) (setq min (nth 1 tmp))) (error (progn (message "Unable to fix - clearing") (setq vm-sumurg-default-time nil))))))) ;; it seems to be a bad move to mess with labels ;; while rebuilding a summary, so if this is called ;; from check-pending, we'll schedule a timeout immediately ;; rather than actually doing the actions now. (setq time (encode-time 0 min hour day month year)) (if (and (time-less-p time now) (null vm-sumurg-check-pending-in-progress)) (progn (save-excursion (vm-add-or-delete-message-labels label 1 nil)) ;; let's try to clear the label out of the global list ;; to avoid indefinite build-up (unintern (concat (vm-su-message-id m) label) vm-sumurg-timer-obarray) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (unintern label vm-label-obarray)) (save-excursion (vm-sumurg-set-urgency level nil 1 m)) ) ;; set a timeout ;; but not if there's already one set for this message ;; and label (when (not (and vm-sumurg-timer-obarray (intern-soft (concat (vm-su-message-id m) label) vm-sumurg-timer-obarray))) (if (null vm-sumurg-timer-obarray) (let ((o (make-vector 29 0))) (setq vm-sumurg-timer-obarray o) ;; copy it to the other buffer ;; we expect always to be in the summary ;; buffer here, but just in case... (save-excursion (set-buffer (or vm-mail-buffer vm-summary-buffer)) (setq vm-sumurg-timer-obarray o)))) (intern (concat (vm-su-message-id m) label) vm-sumurg-timer-obarray) (setq time (time-subtract time now)) (setq time (time-add time (list 0 1))) ; to avoid jiggles (setq time (+ (* 65536 (car time)) (cadr time))) (if (<= time 0) (setq time 0.1)) ;; if the time is too big to represent, set it to a week ;; then it'll get re-calculated. (if (> time (* 7 86400)) (setq time (* 7 86400))) (message "setting timer on msg %s in %.0f seconds" (vm-su-message-id m) time) (add-timeout time (lambda (arg) (when (buffer-live-p (car arg)) (save-excursion (set-buffer (car arg)) (let ((mp vm-message-list)) (while (and mp (not (equal (vm-message-id-of (car mp)) (cadr arg)))) (setq mp (cdr mp))) (if mp (vm-sumurg-check-future (car mp)))) (vm-follow-summary-cursor) (vm-select-folder-buffer) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line)))) (list (current-buffer) (vm-su-message-id m))) )) ))) (vm-labels-of m)) ) (defconst vm-sumurg-pending-extent (if vm-xemacs-p (let ((e (make-extent nil nil)) (k (make-sparse-keymap))) (set-extent-face e 'vm-sumurg-pending-face) (set-extent-keymap e k) (set-extent-property e 'help-echo "button2 selects pending messages") (define-key k [(button2)] (lambda () (interactive "@") (vm-sumurg-showurgent 1))) e ))) (defconst vm-sumurg-urgent-extent (if vm-xemacs-p (let ((e (make-extent nil nil)) (k (make-sparse-keymap))) (set-extent-face e 'vm-sumurg-urgent-face) (set-extent-keymap e k) (set-extent-property e 'help-echo "button2 selects urgent messages") (define-key k [(button2)] (lambda () (interactive "@") (vm-sumurg-showurgent 2))) e ))) (defconst vm-sumurg-veryurgent-extent (if vm-xemacs-p (let ((e (make-extent nil nil)) (k (make-sparse-keymap))) (set-extent-face e 'vm-sumurg-veryurgent-face) (set-extent-keymap e k) (set-extent-property e 'help-echo "button2 selects very urgent messages") (define-key k [(button2)] (lambda () (interactive "@") (vm-sumurg-showurgent 3))) e ))) (defconst vm-sumurg-rightnow-extent (if vm-xemacs-p (let ((e (make-extent nil nil)) (k (make-sparse-keymap))) (set-extent-face e 'vm-sumurg-rightnow-face) (set-extent-keymap e k) (set-extent-property e 'help-echo "button2 selects very urgent messages") (define-key k [(button2)] (lambda () (interactive "@") (vm-sumurg-showurgent 4))) e ))) (defconst vm-sumurg-comp-extent (if vm-xemacs-p (let ((e (make-extent nil nil)) (k (make-sparse-keymap))) (set-extent-face e 'vm-sumurg-comp-face) (set-extent-keymap e k) (set-extent-property e 'help-echo "button2 switches to a composition buffer") (define-key k [(button2)] (lambda () (interactive) (vm-continue-composing-message))) e ))) ; modeline element for xemacs (defvar vm-sumurg-modeline-element (cond (vm-xemacs-p (list (list 'vm-sumurg-modeline-comp (list vm-sumurg-comp-extent "" 'vm-sumurg-modeline-comp)) (list 'vm-sumurg-modeline-pending (list vm-sumurg-pending-extent "" 'vm-sumurg-modeline-pending)) (list 'vm-sumurg-modeline-urgent (list vm-sumurg-urgent-extent "" 'vm-sumurg-modeline-urgent)) (list 'vm-sumurg-modeline-veryurgent (list vm-sumurg-veryurgent-extent "" 'vm-sumurg-modeline-veryurgent)) (list 'vm-sumurg-modeline-rightnow (list vm-sumurg-rightnow-extent "" 'vm-sumurg-modeline-rightnow)))) (vm-fsfemacs-p (list (list 'vm-sumurg-modeline-comp (list "" 'vm-sumurg-modeline-comp)) (list 'vm-sumurg-modeline-pending (list "" 'vm-sumurg-modeline-pending)) (list 'vm-sumurg-modeline-urgent (list "" 'vm-sumurg-modeline-urgent)) (list 'vm-sumurg-modeline-veryurgent (list "" 'vm-sumurg-modeline-veryurgent)) (list 'vm-sumurg-modeline-rightnow (list "" 'vm-sumurg-modeline-rightnow)) )))) ; stick it at the end (add-hook 'vm-summary-mode-hook (if vm-xemacs-p (lambda () (setq vm-sumurg-counter (vector 0 0 0 0 0)) (if (memq vm-sumurg-modeline-element modeline-format) t (setq modeline-format (append modeline-format vm-sumurg-modeline-element)))) (lambda () (aset vm-sumurg-colarray 0 (face-foreground 'modeline)) (setq vm-sumurg-counter (vector 0 0 0 0 0)) (setq mode-line-format (append mode-line-format vm-sumurg-modeline-element))))) (make-variable-buffer-local 'vm-sumurg-counter) (make-variable-buffer-local 'vm-sumurg-modeline-pending) (make-variable-buffer-local 'vm-sumurg-modeline-urgent) (make-variable-buffer-local 'vm-sumurg-modeline-veryurgent) (make-variable-buffer-local 'vm-sumurg-modeline-rightnow) (make-variable-buffer-local 'vm-sumurg-urgency-array) ;; takes a modeline format, and returns the same with any ;; substantive occurrence of vm-ml-labels prefixed by ;; the extent (at function call time) vm-ml-sumurg-extent (defvar vm-ml-sumurg-extent nil) (make-variable-buffer-local 'vm-ml-sumurg-extent) (defun vm-sumurg-munge-modeline (x) (if (consp x) (cons (car x) (mapcar 'vm-sumurg-munge-modeline (cdr x))) (if (eq x 'vm-ml-labels) (list vm-ml-sumurg-extent "" 'vm-ml-labels) x))) ;; hook into vm mode to set the modeline format (defun vm-sumurg-vm-mode-hook-fn () (setq vm-ml-sumurg-extent (make-extent nil nil)) (setq modeline-format (vm-sumurg-munge-modeline modeline-format))) (add-hook 'vm-mode-hook ' vm-sumurg-vm-mode-hook-fn) (add-hook 'vm-presentation-mode-hook ' vm-sumurg-vm-mode-hook-fn) (require 'advice) (defadvice vm-do-needed-mode-line-update (before vm-sumurg-dnmlu activate compile) (when (and vm-message-pointer vm-ml-sumurg-extent) (set-extent-face vm-ml-sumurg-extent (aref vm-sumurg-facearray (vm-sumurg-level-of (car vm-message-pointer)))) (if vm-presentation-buffer (save-excursion (set-buffer vm-presentation-buffer) (set-extent-face vm-ml-sumurg-extent (aref vm-sumurg-facearray (vm-sumurg-level-of (car vm-message-pointer)))))))) ; given a pointer into a message list, return the first element (defun vm-first (mp) (let (prev) (while (setq prev (vm-reverse-link-of (car mp))) (setq mp prev)) mp)) ; this assumes that m-list points to the message list being summarized (defun vm-sumurg-check-pending () (let ((vm-sumurg-check-pending-in-progress t)) (if (null m-list) (vm-sumurg-set-modeline-entries) (let* ((this (string-to-number (vm-number-of (car m-list)))) (last (string-to-number (vm-number-of (car (vm-last m-list))))) (curlen (length vm-sumurg-urgency-array)) (newlen (1+ last)) i l ) (when (> newlen curlen) (setq newlen (+ newlen (/ newlen 20))) (setq vm-sumurg-urgency-array (vconcat vm-sumurg-urgency-array (make-vector (- newlen curlen) 0)))) (setq i this) (while (< i newlen) (setq l (aref vm-sumurg-urgency-array i)) (when (> l 0) (aset vm-sumurg-counter l (1- (aref vm-sumurg-counter l))) (aset vm-sumurg-urgency-array i 0)) (setq i (1+ i))) (mapcar (lambda (m) (vm-sumurg-check-future m) (vm-sumurg-highlight-message)) m-list))))) (add-hook 'vm-summary-update-hook 'vm-sumurg-highlight-message) (add-hook 'vm-summary-redo-hook 'vm-sumurg-check-pending) ; code for blinking the rightnow messages (defvar vm-sumurg-blinker-needed nil) (make-variable-buffer-local 'vm-sumurg-blinker-needed) (defvar vm-sumurg-blinker-blink nil) (defvar vm-sumurg-blinker-timeout-id nil) (defvar vm-sumurg-blinker-in-focus nil) (defun vm-sumurg-blinker-callback (junk) (if vm-sumurg-blinker-in-focus (if vm-sumurg-blinker-blink (progn (setq vm-sumurg-blinker-blink nil) (set-face-background 'vm-sumurg-rightnow-face "magenta")) (setq vm-sumurg-blinker-blink t) (set-face-background 'vm-sumurg-rightnow-face "cyan")) (disable-timeout vm-sumurg-blinker-timeout-id) (setq vm-sumurg-blinker-timeout-id nil) (setq vm-sumurg-blinker-blink nil) (set-face-background 'vm-sumurg-rightnow-face "magenta"))) (defun vm-sumurg-blinker-select-frame-hook () (setq vm-sumurg-blinker-in-focus (and (eq (frame-type (selected-frame)) 'x) vm-sumurg-blinker-needed)) (if (and vm-sumurg-blinker-in-focus (null vm-sumurg-blinker-timeout-id)) (setq vm-sumurg-blinker-timeout-id (add-timeout 1 'vm-sumurg-blinker-callback nil 1)))) (defun vm-sumurg-blinker-deselect-frame-hook () (setq vm-sumurg-blinker-in-focus nil)) (defun vm-sumurg-blinker-enable () (setq vm-sumurg-blinker-needed t) (if vm-mail-buffer (vm-copy-local-variables vm-mail-buffer 'vm-sumurg-blinker-needed)) (if vm-presentation-buffer (vm-copy-local-variables vm-presentation-buffer 'vm-sumurg-blinker-needed)) (add-hook 'select-frame-hook 'vm-sumurg-blinker-select-frame-hook) (add-hook 'deselect-frame-hook 'vm-sumurg-blinker-deselect-frame-hook) (vm-sumurg-blinker-select-frame-hook)) (defun vm-sumurg-blinker-disable () (remove-hook 'select-frame-hook 'vm-sumurg-blinker-select-frame-hook) (remove-hook 'deselect-frame-hook 'vm-sumurg-blinker-deselect-frame-hook) (setq vm-sumurg-blinker-in-focus nil) (setq vm-sumurg-blinker-needed nil) (if vm-mail-buffer (vm-copy-local-variables vm-mail-buffer 'vm-sumurg-blinker-needed)) (if vm-presentation-buffer (vm-copy-local-variables vm-presentation-buffer 'vm-sumurg-blinker-needed)) ) ; bound to vm-virtual-folder-alist in following command (defvar vm-sumurg-urgent-folder-alist '( ;; start virtual folder definition ("pending" (nil ; no real folder (label "*") (label "**") (label "***") (label "****") )) ("urgent" (nil ; no real folder (label "**") (label "***") (label "****") )) ("very urgent" (nil ; no real folder (label "***") (label "****") )) ("right now!" (nil ; no real folder (label "****") )) ) ) ; set urgency level: clears other labels of different urgencies ; This is not bound to a key here, because I can't think of the ; right keybinding. I use *, but that's vm-burst-digest standardly. (defun vm-sumurg-set-urgency (level &optional date count msg clear) "*Set the urgency level of a message. Interactively, this prompts for an urgency level from 0 (unmarked) to 4, and sets the message's urgency accordingly. A numeric prefix argument is treated in the usual way, setting the following N messages to the given urgency level. If called with a simple prefix argument (C-u), it first prompts for a date on which the message is to be set to the given urgency level. If called with a double prefix argument (C-u C-u), it clears any pending urgency changes on the message. The date can be given in several reasonable forms: ISO: 2012-01-22 European numeric: 22/01/2012 or 22/01/12 British traditional: 22 January 2012 or 22 Jan 2012 or Jan 22, 2012 (month names can be given either in full, or as the first three letters) Except in ISO format, the year can be omitted, and the next such date will be assumed. For the next few days, there are two options: a weekday name, which may be given in full, or with the first three, or first two, letters. It may be followed by week (or wk for the really lazy), to add another seven days. For example: monday tue wed week Alternatively, a number of days in the future may be given by +N: +1 tomorrow +2 day after tomorrow + tomorrow (N.B. means +1 not +0) Any date spec may be preceded or followed by a time spec, in several reasonable formats: 19:27 19.27 19h27 7.27 pm 19h 7pm. Specifically any of h : . is recognized as a separator; am and pm are recognized in either case and with or without full stops; the separator and minutes may be omitted, provided that h or am/pm is used. (To avoid confusion with years, military format 1927 is not accepted.) A time spec normally means that time on the given date. In the special case where there is only a time spec, and the date is empty, it means the next occurrence of that time: e.g. at 19:00, a date/time spec of 09:00 means the following morning. A date spec without a time spec will become active according to the value of `vm-sumurg-default-time', which should be a string containing a time in any of the above formats. This defaults to \"00:01\"; it might be useful to set it to, say, \"08:30\", so that messages don't become urgent until you get to the office! (Note: the value of `vm-sumurg-default-time' that counts is that when the urgency is set, or when VM loads the mail folder, whichever happens later.)" (interactive (let ((prompt "Urgency level (0-4): ") level date timep count clear) (when (consp current-prefix-arg) (if (= (prefix-numeric-value current-prefix-arg) 16) (setq clear t) (setq date (vm-sumurg-parse-date (read-string "Date to set: "))) (setq timep (cadr date)) (setq date (format-time-string (if timep "%Y-%m-%dT%H:%M" "%Y-%m-%d") (car date))) (setq prompt (concat "On " date " set urgency level (1-4): "))) (setq current-prefix-arg nil)) (if clear t (setq level (read-number prompt t))) (setq count (prefix-numeric-value current-prefix-arg)) (list level date count nil clear))) (if (null count) (setq count 1)) (if (and (not clear) (or (< level 0) (> level 4))) (error "%d is not a known urgency level" level)) (when (null msg) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (let ((vm-message-pointer vm-message-pointer)) (if msg (setq vm-message-pointer (list msg))) (if clear (mapcar (lambda (label) (when (string-match "^\\*+[-0-9:t]+$" label) (vm-add-or-delete-message-labels label count nil) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of (car vm-message-pointer)))) (unintern label vm-label-obarray)))) (vm-labels-of (car vm-message-pointer))) (if date (progn (vm-add-or-delete-message-labels (concat (substring "****" 0 level) date) count 'all) (vm-sumurg-check-future (car vm-message-pointer))) (vm-add-or-delete-message-labels "* ** *** ****" count nil) (vm-add-or-delete-message-labels (substring "****" 0 level) count 'all))) ; ;; for reasons I don't understand, the display of the selected message ; ;; doesn't get updated - some interaction with the highlight face, ; ;; I guess. So call highlight message explicitly ; (let ((m (car vm-message-pointer))) ; (save-excursion ; (set-buffer vm-summary-buffer) ; (vm-sumurg-highlight-message)))) ; (let ((modified (buffer-modified-p))) ; (set-buffer-modified-p t) ; (vm-do-needed-mode-line-update) ; (set-buffer-modified-p modified)) )) ; form a buffer with pending messages (defun vm-sumurg-showurgent (level) "Make a virtual folder containing messages whose urgency is greater than or equal to the given value (prompted for, when interactive)." (interactive "nUrgency level (1-4): ") (if (or (< level 1) (> level 4)) (error "%d is not a known urgency level")) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((vm-virtual-folder-alist vm-sumurg-urgent-folder-alist) ; scream. Problem1: these folder defns get installed ; on the menu bar; problem2: vm-install-known-virtual-folders-menu ; doesn't handle empty alists correctly, so we can't ; just run it again after exiting the let form ; (and anyway, we don't want them on the new folder's menu) ; Therefore: hackety hack HACK: ; somebody tell me how to do this right (keepfn (symbol-function 'vm-menu-install-known-virtual-folders-menu))) (unwind-protect (progn (fset 'vm-menu-install-known-virtual-folders-menu (lambda () nil)) (vm-apply-virtual-folder (cond ((= level 1) "pending") ((= level 2) "urgent") ((= level 3) "very urgent") ((= level 4) "right now!") ))) (fset 'vm-menu-install-known-virtual-folders-menu keepfn)))) (define-key vm-mode-map "VU" 'vm-sumurg-showurgent) ; add item to the virtual menu (require 'vm-menu) (let ((mp vm-menu-virtual-menu) mprev (item (vector "Make Urgent Virtual Folder" 'vm-sumurg-showurgent t))) (while (and mp (or (not (stringp (car mp))) (not (string-match "^--*$" (car mp))))) (setq mprev mp) (setq mp (cdr mp))) (if mprev (setcdr mprev (cons item mp)) (setq vm-menu-virtual-menu (cons item mp)))) ; routines to parse dates in a reasonable format. ; Returns a list (TIME TIMEP). ; The TIME is a time value, corresponding to the given date string. ; If the date string contains no time specifier, the time is zero hours, ; and TIMEP is nil. If the date string contained a time value, ; TIMEP is t. ; Time specifiers have the form hh:mm or hh.mm, optionally ; preceded by a T (for the benefit of ISO format), and optionally ; followed by am or pm (which we handle correctly). (defun vm-sumurg-parse-date (s) (let ((now (current-time)) (case-fold-search t) (ts) (hh 0) (mm 0) (xm) (timep) (timeregexp (eval-when-compile (concat ;; XEmacs bug: ^ not recognized after shy group open, so ;; put it as second alternative "\\(?:[_t]\\|^\\|\\s-\\)\\s-*" ; start with beginning, T ; or whitespace "\\([0-9][0-9]?\\)" ; the hours ;; now either we have minutes followed by an optional ;; am/pm, or we have a compulsory h/am/pm ;; open, and first alternative "\\(?:[h:.]\\([0-9][0-9]\\)\\s-*\\(?:\\([ap]\\)\\.?m\\.?\\)?" ;; second alternative "\\|\\s-*\\(?:h\\|\\([ap]\\)\\.?m\\.?\\)\\)")) ) (date)) (setq date (decode-time now)) ;; look for and remove a time string ;; we want to allow either minutes or h/am/pm to be omitted, ;; but not both. Unfortunately, there's no way to avoid writing ;; the pm/am twice. (when (or (when (string-match timeregexp s) (setq ts s) (setq s (replace-match "" nil nil s)) (setq timep t)) (and vm-sumurg-default-time (setq ts vm-sumurg-default-time) (or (string-match timeregexp ts) (error 'invalid-argument "vm-sumurg-default-time not in a valid time format" 'vm-sumurg-default-time)))) (setq hh (string-to-number (match-string 1 ts))) (if (match-beginning 2) (setq mm (string-to-number (match-string 2 ts)))) (setq xm (or (match-string 3 ts) (match-string 4 ts))) (when xm (if (or (equal xm "a") (equal xm "A")) (if (equal hh 12) (setq hh 0)) (if (< hh 12) (setq hh (+ hh 12)))))) (list (apply 'encode-time (cond ;; +n or empty ((string-match "^\\s-*\\(?:\\+\\([0-9]*\\)\\)?\\s-*$" s) (list 0 mm hh (+ (nth 3 date) (if (null (match-beginning 1)) ;; empty, today. If a time was given, and ;; it's before now, then make it tomorrow (if (and timep (or (< hh (nth 2 date)) (and (= hh (nth 2 date)) (< mm (nth 1 date))))) 1 0) (if (equal (match-beginning 1) (match-end 1)) 1 (string-to-number (match-string 1 s))))) (nth 4 date) (nth 5 date))) ;; fooday week ((string-match (eval-when-compile (concat "^\\s-*" ; white space at beginning "\\(?:" ; start of day match ;; given a string, build a regexp that matches ;; the first 2 letters, ;; the first three letters, or the whole ;; string. I.e. monday will ;; match mo, mon, monday (mapconcat (lambda (d) (concat "\\(" (substring d 0 2) "\\(?:" (substring d 2 3) "\\(?:" (substring d 3) "\\)?\\)?\\)") ) '("sunday" "monday" "tuesday" "wednesday" "thursday" "friday" "saturday") "\\|") "\\)" ; end of day match "\\s-*" ; white space "\\(w\\(?:ee\\)?k\\)?" ; week match "\\s-*$" ; white space to end )) ; end of constructed regexp s) (let* ((week (match-string 8 s)) (wdaynum (let ((i 1)) (while (and (< i 8) (null (match-beginning i))) (setq i (1+ i))) (if (>= i 8) nil (1- i)))) (todaynum (nth 6 date)) ) (if (> wdaynum todaynum) t ; do nothing: the day's coming up (setq wdaynum (+ 7 wdaynum))) (if week (setq wdaynum (+ 7 wdaynum))) (list 0 mm hh (+ (- wdaynum todaynum) (nth 3 date)) (nth 4 date) (nth 5 date)) )) ; end of first clause ;; iso date, nice and easy ((string-match "^\\s-*\\([12][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)\\s-*$" s) (list 0 mm hh (string-to-number (match-string 3 s)) (string-to-number (match-string 2 s)) (string-to-number (match-string 1 s)))) ;; and traditional dates ((string-match "^\\s-*\\([0-9][0-9]?\\)/\\([0-9][0-9]?\\)\\(?:/\\([0-9]+\\)\\)?\\s-*$" s) (let ((d (string-to-number (match-string 1 s))) (m (string-to-number (match-string 2 s))) (y (if (match-beginning 3) (string-to-number (match-string 3 s))))) (when (null y) (setq y (nth 5 date)) (if (or (< m (nth 4 date)) (and (= m (nth 4 date)) (<= d (nth 3 date)))) (setq y (1+ y)))) (if (< y 100) (setq y (+ 2000 y))) (list 0 mm hh d m y))) ;; 5 jan yy ((string-match (eval-when-compile (concat "^\\s-*\\([0-9][0-9]?\\)\\s-*\\(?:" ; initial white ; space and number ;; construct a month matcher: bracket n is month n-1 (mapconcat (lambda (m) (concat "\\(" (substring m 0 3) "\\(?:" (substring m 3) "\\)?\\)")) '("january" "february" "march" "april" "may" "june" "july" "august" "september" "october" "november" "december") "\\|") "\\)\\s-*\\([0-9]+\\)?\\s-*$" ; end of month group, and year )) s) (let ((d (string-to-number (match-string 1 s))) (m (let ((i 2)) (while (and (< i 14) (null (match-beginning i))) (setq i (1+ i))) (if (>= i 14) (error 'internal-error "matched impossible month in vm-sumurg-parse-date") (1- i)))) (y (if (match-beginning 14) (string-to-number (match-string 14 s))))) (when (null y) (setq y (nth 5 date)) (if (or (< m (nth 4 date)) (and (= m (nth 4 date)) (<= d (nth 3 date)))) (setq y (1+ y)))) (if (< y 100) (setq y (+ 2000 y))) (list 0 mm hh d m y))) ;; and the same, for jan 5, yy ((string-match (eval-when-compile (concat "^\\s-*\\(?:" ; initial white space ;; construct a month matcher: bracket n is month n-1 (mapconcat (lambda (m) (concat "\\(" (substring m 0 3) "\\(?:" (substring m 3) "\\)?\\)")) '("january" "february" "march" "april" "may" "june" "july" "august" "september" "october" "november" "december") "\\|") "\\)\\s-*\\([0-9][0-9]?\\)\\(?:,\\s-*\\([0-9]+\\)\\)?\\s-*$" ; end of month group, day and year )) s) (let ((d (string-to-number (match-string 13 s))) (m (let ((i 1)) (while (and (< i 13) (null (match-beginning i))) (setq i (1+ i))) (if (>= i 13) (error 'internal-error "matched impossible month in vm-sumurg-parse-date") i))) (y (if (match-beginning 14) (string-to-number (match-string 14 s))))) (when (null y) (setq y (nth 5 date)) (if (or (< m (nth 4 date)) (and (= m (nth 4 date)) (<= d (nth 3 date)))) (setq y (1+ y)))) (if (< y 100) (setq y (+ 2000 y))) (list 0 mm hh d m y))) (t (error 'invalid-argument (concat s " is not a recognized date format")))) ; end of cond ) timep))) ; end of defn (provide 'vm-sumurg) vm-8.2.0b/contrib/vm-bogofilter.el0000755000175000017500000003551111676442160017334 0ustar srivastasrivasta;;; vm-bogofilter.el version 1.1.4 ;; ;; An interface between the VM mail reader and the bogofilter spam filter. ;; ;; Copyright (C) 2003-2006 by Bjorn Knutsson ;; ;; Home page: http://www.cis.upenn.edu/~bjornk/ ;; ;; Bjorn Knutsson, CIS, 3330 Walnut Street, Philadelphia, PA 19104-6389, USA ;; ;; ;; Based on vm-spamassassin.el v1.1, Copyright (C) 2002 by Markus Mohnen ;; ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2 of the License, or ;; (at your option) any later version. ;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ;; ;;; Version history: ;; v 1.1.4: Change in the way bogofilter is called ;; * No longer uses formail to process mails ;; * Slightly improved error handling ;; v 1.1.3: Minor edits ;; * Documentation updates ;; * Error checking for bogofilter calls. ;; * vm-bogofilter-delete-spam variable. ;; Set to cause spam to be automatically deleted. ;; * vm-bogofilter-setup function. ;; Automatically called on loading, but can be called again ;; to re-initialize the vm-bogofilter setup ;; v 1.1.2: Borg assimilation version (12-Sep-2003) ;; * Great minds think alike. Olivier Cappe independently ;; created his own version of vm-bogofilter.el based on ;; vm-spamassassin.el with the same basic functions. ;; He submitted a patch to my version to harmonize them. ;; * Added comment about vm-delete-after-archiving, as suggested ;; by Olivier. ;; v 1.1.1: minor edits ;; * Chris McMahan submitted a patch that disables running ;; bogfilter on incoming mail. While at first potentially ;; confusing, this means that you can run bogofilter via ;; e.g. procmail filters, and then use vm-bogofilter.el to ;; (re-)educate bogofilter about false positives/negatives. ;; * Documentation of a folder problem added ;; v 1.1: functional update ;; * Changed re-training functions to also re-tag the the message ;; in the VM folder, thus making the tag on the message in VM ;; be consistent with bogofilter's opinion about the message. ;; Notice!! If you use the tag in the message, you should be ;; aware that a message re-classified as spam may still not ;; be tagged as spam by bogofilter, and vice versa, if the ;; bogofilter database contains too many counter-examples. ;; The old re-training functions are still present, if you ;; prefer not to muck around with your inbox. They've been ;; renamed vm-bogofilter-is-spam-old/vm-bogofilter-is-clean-old ;; and works as before. ;; v 1.0.1: update ;; * Very minor edits of texts, no functional changes. ;; v 1.0: initial release ;; * First release, based on Markus Mohnen's vm-spamassassin ;; ;; ;; To use this program, you need reasonably recent versions of VM from ;; http://www.wonderworks.com/vm) and bogofilter from ;; http://sourceforge.net/projects/bogofilter/ ;; ;; This version of the interface has been developed for, and tested ;; with, VM version 7.17 and later, and bogofilter version 0.17.4 and ;; later. Some features used /require/ bogofilter version 0.15.0 and ;; later but no testing of versions earlier than 0.17.4 has been done. ;; It has been tested with bogofilter versions up to 0.93.2 ;; ;; (Former RMAIL-users should read the BUGS-note about the BABYL-format) ;; ;;; Installation: ;; ;; Put this file on your Emacs-Lisp load path and add following into your ;; ~/.vm startup file ;; ;; (require 'vm-bogofilter) ;; ;; ;;; Usage: ;; ;; Whenever you get new mail bogofilter will be invoked on them. Mail ;; detected as spam will be tagged by bogofilter, and you can use ;; existing mechanisms to dispose of them. ;; ;; For example, if you append this line to your .vm (or modify your ;; existing auto-folder-alist), you could then have messages tagged as ;; spam automatically saved in a separate 'spam' folder: ;; ;; (setq vm-auto-folder-alist '(("^X-Bogosity: " ("Yes," . "spam")))) ;; ;; If you want your auto-folder to be used every time you've received ;; new mail, just add the following to your .vm: ;; ;; (add-hook 'vm-arrived-messages-hook 'vm-auto-archive-messages) ;; ;; You can also set (setq 'vm-delete-after-archiving t) to make VM ;; automatically delete archived spams from the main folder. ;; ;; ;; If a message is tagged as spam incorrectly, you can re-train ;; bogofilter by calling the function vm-bogofilter-is-clean on that ;; message. Similarly, calling vm-bogofilter-is-spam will re-train ;; bogofilter to recognize a clean-marked message as spam. ;; ;; These functions can be bound to keys in your .vm, for example: ;; ;; (define-key vm-mode-map "K" 'vm-bogofilter-is-spam) ;; (define-key vm-mode-map "C" 'vm-bogofilter-is-clean) ;; ;; would define K (shift-k) as the key to declare the current message ;; as spam, while C (shift-c) as the key to declare the current ;; message as clean. ;; ;; Re-training with the old functions (still available) would not ;; re-tag messages, while the new ones will. Re-training may or may ;; not change the spam-status of a message. Because of the way ;; bogofilter works, even a message explicitly declared as spam may ;; not be tagged as spam if there are enough similar non-spam ;; messages. Remember, bogofilter is not trained to recognize ;; individual messages, but rather patterns. You may have to train ;; bogofilter on a number of spam messages before it recognizes any of ;; them as spam. See the documentation for bogofilter. Notice also ;; that even if the tag changes, this will not undo actions previously ;; taken based on the tag, e.g. moving spam to a spamfolder with ;; auto-folders. ;; ;; If you have a small database, running bogofilter without '-u' may ;; be better in the beginning. If you want to run without '-u', it ;; can easily be accomplished. Just: ;; ;; M-x customize vm-bogofilter ;; ;; Then change the Program Options to just '-p -e' and the Unspam to ;; '-n' and Spam to '-s'. ;; ;; Now, bogofilter will not auto-train, and you must instead use the ;; vm-bogofilter-is-spam and vm-bogofilter-is-clean to manually tag ;; messages. (If you've bound them to keys, it will be quite simple.) ;; ;;; BUGS: ;; ;; One know bug is that formail will not like it if the input is not ;; in the format it expects and knows. Even though it's supposed to ;; know BABYL, this does not work. ;; ;; A related problem is that if you have the wrong folder type ;; selected, then sometimes, VM will merge messages. You can check the ;; raw folder to see if you have a blank line before the "From "-line ;; separating messages. See the documentation for vm-default-folder-type ;; ;; vm-bogofilter is not very smart about errors. If an error occurs ;; during any operation that tags or re-tags messages, the message(s) ;; being processed will be *lost*. If errors occur during initial ;; processing, the lost mails can sometimes be recovered since VM will ;; save the folder *after* receiving new mails, but *before* ;; processing hooks, e.g. vm-bogofilter. If you notice the errors ;; before saving the folder, you can copy the old file, close VM, ;; rename your copy to the original folder name and then start VM ;; again. Naturally, anything that happened to the folder after ;; fetching new mail will be lost, e.g. bogofilter tagging etc. ;; ;;; Customization: ;; ;; M-x customize RET vm-bogofilter ;;; Code: (eval-when-compile (require 'vm)) ;;; Customisation: (defgroup vm-bogofilter nil "VM Spam Filter Options" :group 'vm) (defcustom vm-bogofilter-program "bogofilter" "*Name of the bogofilter program." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-program-options "-u -p -e" "*Options for the bogofilter program. Since we use bogofilter as a filter, '-p' must be one of the options, while '-e' tells bogofilter that it is embedded, and thus should not signal spam/ham with return values. * The flag '-u' controls if bogofilter automatically learns from its own classification. You may not want to use this flag if bogofilter still is learning to classify, or if you do not have the discipline to correct every mis-classification." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-program-mbox "-M" "*Options for the bogofilter program. This flags tells bogofilter how to process mailboxes, i.e., multiple messages." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-program-options-unspam "-Sn" "*Options for the bogofilter program when declaring a spam-marked message as clean. The default, '-Sn', assumes that bogofilter already has trained itself on the message, e.g. by running it with '-u' during classification. If this is the initial training, use '-n' instead." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-program-options-spam "-Ns" "*Options for the bogofilter program when declaring a clean-marked message as spam. The default, '-Ns', assumes that bogofilter already has trained itself on the message, e.g. by running it with '-u' during classification. If this is the initial training, use '-s' instead." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-program-options-reclassify "-p -e" "*Options for the bogofilter program when declaring a clean-marked message as spam. *See vm-bogofilter-program-options for a discussion of the options." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-formail-program "formail" "*Name of the program used to split a sequence of mails." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-formail-program-options "-s" "*Options for the 'vm-bogofilter-formail-program'. After this arguments, the name of the bogofilter program will be passed." :group 'vm-bogofilter :type 'string) (defcustom vm-bogofilter-invoke-through-vm t "*When true, bogofilter will be invoked through the vm-retrieved-spooled-mail-hook. If you have procmail or some other MTA configured to filter through bogofilter already, then set this to nil to speed vm-startup. *NOTE: This variable is only consulted on startup, so if you change it, it will take effect the next time vm-bogofilter is loaded, or vm-bogofilter-setup is called." :group 'vm-bogofilter :type 'boolean) (defcustom vm-bogofilter-delete-spam nil "*When true, mark messages for deletion when reclassifying as spam. *NOTE: This does not affect the initial classification, only when messages are explicitly marked as spams by the vm-bogofilter-is-spam function." :group 'vm-bogofilter :type 'boolean) (defun vm-bogofilter-arrived-message () "The function used to do the actual filtering. It is used as a value for vm-retrieved-spooled-mail-hook." (save-excursion (vm-save-restriction (let ((tail-cons (vm-last vm-message-list)) (buffer-read-only nil)) (widen) (if (null tail-cons) (goto-char (point-min)) (goto-char (vm-text-end-of (car tail-cons))) (beginning-of-line) (forward-line) ) (vm-inform 5 "Filtering new messages... ") (let ((res (call-process-region (point) (point-max) (or shell-file-name "sh") t t nil shell-command-switch (concat vm-bogofilter-program " " vm-bogofilter-program-options " " vm-bogofilter-program-mbox)))) (if (and res (not (and (integerp res) (zerop res)))) (error "Something went wrong filtering new messages (exit %s)" res) (delete-region (point) (point-max)))) (vm-inform 5 "Filtering new messages... done.") ) ) ) ) (defun vm-bogofilter-is-spam-old () "Declare that a clean-marked message is spam" (interactive) (vm-follow-summary-cursor) (vm-pipe-message-to-command (concat vm-bogofilter-program " " vm-bogofilter-program-options-spam) nil) ) (defun vm-bogofilter-is-clean-old () "Declare that a spam-marked message is clean" (interactive) (vm-follow-summary-cursor) (vm-pipe-message-to-command (concat vm-bogofilter-program " " vm-bogofilter-program-options-unspam) nil) ) (defun vm-bogofilter-is-spam () "Declare that a clean-marked message is spam, and re-tag message" (interactive) (vm-bogofilter-retag "spam" vm-bogofilter-program-options-reclassify vm-bogofilter-program-options-spam) (if vm-bogofilter-delete-spam (vm-delete-message 1)) ) (defun vm-bogofilter-is-clean () "Declare that a spam-marked message is clean, and re-tag message" (interactive) (vm-bogofilter-retag "clean" vm-bogofilter-program-options-reclassify vm-bogofilter-program-options-unspam) ) ;; Based on vm-pipe-message-to-command (defun vm-bogofilter-retag (text switch &optional switch2) "Workhorse function for re-tagging of messages." (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (save-excursion (let ((message (vm-real-message-of (car vm-message-pointer))) (buffer (get-buffer-create "*Shell Command Output*")) ) (save-excursion (set-buffer buffer) (erase-buffer)) (set-buffer (vm-buffer-of message)) (vm-save-restriction (vm-save-buffer-excursion (widen) (goto-char (vm-headers-of message)) (narrow-to-region (point) (vm-text-end-of message)) (vm-inform 6 "Re-classifying message as %s." text) (if (not (eq switch2 nil)) (progn (call-process-region (point-min) (point-max) (or shell-file-name "sh") nil buffer nil shell-command-switch (concat vm-bogofilter-program " " switch2) ) (vm-inform 6 "Message re-classified as %s, updating tag." text) )) (let ((buffer-read-only nil) (buffer (get-buffer-create "*Shell Command Output*"))) (call-process-region (point-min) (point-max) (or shell-file-name "sh") nil t nil shell-command-switch (concat vm-bogofilter-program " " switch) ) (delete-region (point) (vm-text-end-of message))) (vm-discard-cached-data) (vm-inform 6 "Message re-classified and tagged as %s." text) (vm-present-current-message) (vm-update-summary-and-mode-line) ))))) ;;; Hooking into VM (defun vm-bogofilter-setup () "Initialize vm-bogofilter." (interactive) (if vm-bogofilter-invoke-through-vm (add-hook 'vm-retrieved-spooled-mail-hook 'vm-bogofilter-arrived-message) (remove-hook 'vm-retrieved-spooled-mail-hook 'vm-bogofilter-arrived-message))) (vm-bogofilter-setup) (provide 'vm-bogofilter) ;;; vm-bogofilter.el ends here vm-8.2.0b/contrib/vm-mime.el-w3m.patch0000755000175000017500000001252611676442161017733 0ustar srivastasrivasta=== modified file 'vm-mime.el' --- vm-mime.el 2006-08-21 21:17:05 +0000 +++ vm-mime.el 2006-09-18 23:09:23 +0000 @@ -2060,49 +2060,87 @@ (defun vm-mime-display-internal-text (layout) (vm-mime-display-internal-text/plain layout)) +(autoload 'w3m-region "w3m" "Render region using w3m") + +(defcustom vm-mime-renderer-for-text/html 'w3 + "The HTML renderer to use for internal display. +W3M is usually faster and better than W3." + :group 'vm + :type '(choice (const w3) + (const w3m))) + +(defun vm-mime-display-internal-text/html-with-w3m (start end) + (save-restriction + (narrow-to-region start end) + (let ((w3m-safe-url-regexp "\\`cid:") + w3m-force-redisplay) + (goto-char (point-max)) + (insert-before-markers "z") + (w3m-region (point-min) (1- (point-max))) + (goto-char (point-max)) + (delete-char -1)) + + (when (and (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) + (add-text-properties (point-min) (point-max) + (list 'keymap w3m-minor-mode-map))))) + +(defun vm-mime-display-internal-text/html-with-w3 (start end) + ;; w3-region apparently deletes all the text in the + ;; region and then insert new text. This makes the + ;; end == start. The fix is to move the end marker + ;; forward with a placeholder character so that when + ;; w3-region delete all the text, end will still be + ;; ahead of the insertion point and so will be moved + ;; forward when the new text is inserted. We'll + ;; delete the placeholder afterward. + (goto-char end) + (insert-before-markers "z") + (w3-region start (1- end)) + (goto-char end) + (delete-char -1)) + (defun vm-mime-display-internal-text/html (layout) - (if (and (fboundp 'w3-region) - vm-mime-use-w3-for-text/html) - (condition-case error-data - (let ((buffer-read-only nil) - (start (point)) - (charset (or (vm-mime-get-parameter layout "charset") - "us-ascii")) - end buffer-size) - (message "Inlining text/html, be patient...") - (vm-mime-insert-mime-body layout) - (setq end (point-marker)) - (vm-mime-transfer-decode-region layout start end) - (vm-mime-charset-decode-region charset start end) - ;; w3-region apparently deletes all the text in the - ;; region and then insert new text. This makes the - ;; end == start. The fix is to move the end marker - ;; forward with a placeholder character so that when - ;; w3-region delete all the text, end will still be - ;; ahead of the insertion point and so will be moved - ;; forward when the new text is inserted. We'll - ;; delete the placeholder afterward. - (goto-char end) - (insert-before-markers "z") - (w3-region start (1- end)) - (goto-char end) - (delete-char -1) - ;; remove read-only text properties - (let ((inhibit-read-only t)) - (remove-text-properties start end '(read-only nil))) - (goto-char end) - (message "Inlining text/html... done") - t ) - (error (vm-set-mm-layout-display-error - layout - (format "Inline HTML display failed: %s" - (prin1-to-string error-data))) - (message "%s" (vm-mm-layout-display-error layout)) - (sleep-for 2) - nil )) - (vm-set-mm-layout-display-error layout "Need W3 to inline HTML") - (message "%s" (vm-mm-layout-display-error layout)) - nil )) + (let ((render-func + (cond ((eq vm-mime-renderer-for-text/html 'w3m) + 'vm-mime-display-internal-text/html-with-w3m) + ((eq vm-mime-renderer-for-text/html 'w3) + 'vm-mime-display-internal-text/html-with-w3) + (t + (vm-set-mm-layout-display-error + layout + (concat "Inline HTML display failed: function " + (symbol-name vm-mime-inline-render-function-for-text/html) + " not found. Please bind a valid function to vm-mime-inline-render-function-for-text/html.")) + (message "%s" (vm-mm-layout-display-error layout)) + nil)))) + (if (fboundp render-func) + (condition-case error-data + (let ((buffer-read-only nil) + (start (point)) + (charset (or (vm-mime-get-parameter layout "charset") + "us-ascii")) + end buffer-size) + (message "Inlining text/html, be patient...") + (vm-mime-insert-mime-body layout) + (setq end (point-marker)) + (vm-mime-transfer-decode-region layout start end) + (vm-mime-charset-decode-region charset start end) + + (funcall render-func start end) + + ;; remove read-only text properties + (let ((inhibit-read-only t)) + (remove-text-properties start end '(read-only nil))) + (goto-char end) + (message "Inlining text/html... done") + t ) + (error (vm-set-mm-layout-display-error + layout + (format "Inline HTML display failed: %s" + (prin1-to-string error-data))) + (message "%s" (vm-mm-layout-display-error layout)) + (sleep-for 2) + nil )))))) (defun vm-mime-display-internal-text/plain (layout &optional no-highlighting) (let ((start (point)) end need-conversion vm-8.2.0b/contrib/attempted-locking.diff0000755000175000017500000000703411676442160020502 0ustar srivastasrivasta# Bazaar revision bundle v0.8 # # message: # first shot at improving the locking. # committer: rpgoldman@real-time.com # date: Sun 2006-10-08 18:19:49.986000061 -0500 === modified file vm-folder.el --- vm-folder.el +++ vm-folder.el @@ -2993,6 +2993,8 @@ buffer-file-name))) (vm-get-spooled-mail nil)) (progn + ;; if we've got new mail, then lock the buffer.... + (lock-buffer) ;; don't move the message pointer unless the folder ;; was empty. (if (and (null vm-message-pointer) @@ -3185,6 +3187,9 @@ vm-default-folder-permission-bits)) (save-buffer prefix)) (and oldmodebits (set-default-file-modes oldmodebits)))) + ;; if the folder's been locked (it should have been), then + ;; unlock it. + (unlock-buffer) (vm-set-buffer-modified-p nil) ;; clear the modified flag in virtual folders if all the ;; real buffers associated with them are unmodified. @@ -3630,6 +3635,9 @@ mail-waiting )))) (defun vm-get-spooled-mail (&optional interactive) + "Gets new spooled mail according to the folder-access method. +Returns a list of new messages \(not sure what the data type of +\"message\" is in this context\)." (if vm-block-new-mail (error "Can't get new mail until you save this folder.")) (cond ((eq vm-folder-access-method 'pop) === modified file vm-startup.el --- vm-startup.el +++ vm-startup.el @@ -153,7 +153,7 @@ (coding-system-for-read (vm-line-ending-coding-system))) (message "Reading %s..." file) - (prog1 (find-file-noselect file) + (prog1 (vm-find-file-noselect file) ;; update folder history (let ((item (or remote-spec folder vm-primary-inbox))) @@ -223,6 +223,8 @@ ;; If the buffer's not modified then we know that there can be no ;; messages in the folder that are not on disk. (or (buffer-modified-p) (setq vm-messages-not-on-disk 0)) + ;; if the buffer's been modified, it should be locked... + (and (buffer-modified-p) (lock-buffer)) (setq first-time (not (eq major-mode 'vm-mode)) preserve-auto-save-file (and buffer-file-name (not (buffer-modified-p)) @@ -393,6 +395,33 @@ (if (not (input-pending-p)) (message totals-blurb))))))) +;;; helper function +(defun vm-find-file-noselect (filename) + (let* ((buffer (find-file-noselect filename)) + (lock (file-locked-p filename))) + (cond ((null lock) + ;; not locked, no worries + buffer) + ((eq lock t) + ;; this xemacs has the buffer locked. I don't believe that + ;; this should be a problem, either. Unless it means that + ;; I've introduced a bug, and not properly unlocked things... + (warn "Buffer is locked by this emacs. Unexpected -- please report.") + buffer) + (t + ;; the lock value is the name of the locking user + (let ((query-result (ask-user-about-lock + filename lock))) + (cond ((eq query-result t) + ;; steal the lock + buffer) + ((null query-result) + (save-excursion + (set-buffer buffer) + (setq buffer-read-only t)) + (message "Opening folder read-only.") + buffer))))))) + ;;;###autoload (defun vm-other-frame (&optional folder read-only) "Like vm, but run in a newly created frame." # revision id: rpgoldman@real-time.com-20061008231949-1bd9467b25ca41b8 # sha1: 9ee06c49007ffdec241f9f0f4206dda2e327015f # inventory sha1: afad72f633b5cbae416178d327931a735786f2f0 # parent ids: # hack@robf.de-20061005191950-d7498e730daa5855 # base id: hack@robf.de-20061005191950-d7498e730daa5855 # properties: # branch-nick: vm vm-8.2.0b/contrib/vm-mime-display-internal-application.el0000755000175000017500000002246011676442160023704 0ustar srivastasrivasta;;; vm-mime-display-internal-application.el --- Display application attachments ;;; -*-unibyte: t; coding: iso-8859-1;-*- ;; Copyright © 2004 Kevin Rodgers ;; Author: Kevin Rodgers ;; Created: 11 Jun 2004 ;; Version: $Revision: 1.5 $ ;; Keywords: mail, mime ;; RCS: $Id: vm-mime-display-internal-application.el,v 1.5 2004/07/14 23:29:04 kevinr Exp $ ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as ;; published by the Free Software Foundation; either version 2 of ;; the License, or (at your option) any later version. ;; This program is distributed in the hope that it will be ;; useful, but WITHOUT ANY WARRANTY; without even the implied ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. See the GNU General Public License for more details. ;; You should have received a copy of the GNU General Public ;; License along with this program; if not, write to the Free ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, ;; MA 02111-1307 USA ;;; Commentary: ;; VM does not provide a way to display additional MIME media types ;; internally. This file defines a new user variable to control which ;; application/* subtypes can be displayed within Emacs: ;; C-h v vm-mime-internal-application-subtypes ;; ;; It also defines user commands to register a subtype and to install ;; all registered subtypes as internally displayable applications: ;; M-x vm-mime-register-internal-application ;; M-x vm-mime-install-internal-applications ;; ;; Usage: ;; (load-library "vm-mime-display-internal-application") ;; (vm-mime-register-internal-application "foo" t) ; to run foo-mode ;; (vm-mime-register-internal-application "bar" 'baz-mode) ;; (vm-mime-install-internal-applications) ;;; Code: (require 'vm) (defvar vm-mime-internal-application-subtypes ;; see http://www.iana.org/assignments/media-types/application/ '(("emacs-lisp" . t) ; lisp-mode.el ("tar" . t) ; tar-mode.el ("arc" . archive-mode) ; arc-mode.el ("lzh" . archive-mode) ; arc-mode.el ("zip" . archive-mode) ; arc-mode.el ("zoo" . archive-mode) ; arc-mode.el ;; For file-name-handler subtypes, let find-file-noselect -> ;; after-find-file -> (normal-mode t) choose the mode. Specify ;; ignore instead of normal-mode for these subtypes, so that the ;; optional FIND-FILE argument doesn't override enable-local-variables. ("gzip" . ignore) ; jka-compr.el ("bzip2" . ignore) ; jka-compr.el ("compress" . ignore)) ; jka-compr.el "List of MIME \"application/*\" subtypes that should be displayed internally. Each (SUBTYPE . MODE) element maps the \"applicaton/SUBTYPE\" MIME content type to the major MODE used to display it. Both the MODE and `vm-mime-display-internal-application/SUBTYPE' functions must be defined. If MODE is t, SUBTYPE-mode is used to display \"application/SUBTYPE\" attachments.") (defvar vm-mime-internal-application-x-subtypes nil "*If non-nil, display application/x-SUBTYPE attachments the same as application/SUBTYPE attachments. See `vm-mime-internal-application-subtypes'.") (defadvice vm-mime-can-display-internal (after application/xxxx activate compile) "Respect `vm-mime-internal-application-subtypes'." (or ad-return-value (setq ad-return-value (let* ((layout (ad-get-arg 0)) (type (car (vm-mm-layout-type layout))) (subtype (if (vm-mime-types-match "application" type) (substring type (1+ (match-end 0))))) (mode (if subtype (vm-mime-can-display-internal-application subtype)))) (if mode (let ((charset (or (vm-mime-get-parameter layout "charset") "us-ascii"))) (or (vm-mime-charset-internally-displayable-p charset) (vm-mime-can-convert-charset charset)))))))) (defun vm-mime-can-display-internal-application (subtype) "Return the Emacs mode for displaying \"application/SUBTYPE\" MIME objects." (catch 'major-mode (let ((subtypes vm-mime-internal-application-subtypes) mode) (while subtypes (if (or (equal subtype (car (car subtypes))) (and vm-mime-internal-application-x-subtypes (equal subtype (concat "x-" (car (car subtypes)))))) (cond ((and (eq (cdr (car subtypes)) 't) (fboundp (setq mode (intern (concat subtype "-mode"))))) (throw 'major-mode mode)) ((fboundp (setq mode (cdr (car subtypes)))) (throw 'major-mode mode)))) (setq subtypes (cdr subtypes))) nil))) (defun vm-mime-display-internal-application/xxxx (layout) "Display LAYOUT in its own buffer." ;; see vm-mime-display-external-generic (let* ((tempfile (or (get (vm-mm-layout-cache layout) 'vm-mime-display-internal-application/xxxx) (let ((suffix (or (vm-mime-extract-filename-suffix layout) (vm-mime-find-filename-suffix-for-type layout))) (filename (or (vm-mime-get-disposition-parameter layout "filename") (vm-mime-get-parameter layout "name")))) (vm-make-tempfile-name suffix filename)))) (type (car (vm-mm-layout-type layout))) (subtype (if (vm-mime-types-match "application" type) (substring type (1+ (match-end 0)))))) (vm-mime-send-body-to-file layout nil tempfile) (vm-register-message-garbage-files (list tempfile)) (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-application/xxxx tempfile) (let* ((inhibit-local-variables t) (enable-local-variables nil) (enable-local-eval nil) (pop-up-frames vm-mutable-frame-configuration) (pop-up-windows vm-mutable-window-configuration) (mode (vm-mime-can-display-internal-application subtype))) (pop-to-buffer (find-file-noselect tempfile)) ; (with-auto-compression-mode ...) (or (eq major-mode mode) (funcall mode)) ;; (when pop-up-frames ;; (set-window-dedicated-p (selected-window) t)) (cond (pop-up-frames (add-hook 'kill-buffer-hook 'delete-frame t t)) (pop-up-windows (add-hook 'kill-buffer-hook 'delete-window t t)))))) (defun vm-mime-register-internal-application (subtype mode) "Add (SUBTYPE . MODE) to `vm-mime-internal-application-subtypes'. Also define the `vm-mime-display-internal-application/SUBTYPE' and `vm-mime-display-button-application/SUBTYPE' functions. If MODE is nil, just define the functions." (interactive (let* ((subtype (completing-read "Subtype: " vm-mime-internal-application-subtypes)) (subtype-mode (fboundp (intern (concat subtype "-mode")))) (completion-ignore-case nil) (mode (intern (completing-read (if subtype-mode "Mode: (default t) " "Mode: ") obarray (lambda (s) (and (fboundp s) (string-match "-mode\\'" (symbol-name s)))) t nil nil (if subtype-mode "t"))))) (or (eq mode 't) (fboundp mode) ; i.e. (equal (symbol-name mode) "") (error "Undefined mode: %s" mode)) ; (unintern mode) (list subtype mode))) (if mode (setq vm-mime-internal-application-subtypes (cons (cons subtype mode) vm-mime-internal-application-subtypes))) (let ((internal (intern (concat "vm-mime-display-internal-application/" subtype))) (button (intern (concat "vm-mime-display-button-application/" subtype)))) (defalias internal 'vm-mime-display-internal-application/xxxx) (fset button (lambda (layout) (vm-mime-display-button-xxxx layout nil))) (if vm-mime-internal-application-x-subtypes (progn (defalias (intern (concat "vm-mime-display-internal-application/x-" subtype)) internal) (defalias (intern (concat "vm-mime-display-button-application/x-" subtype)) button))))) (defun vm-mime-install-internal-applications () "Define display and button functions for each registered subtype. See `vm-mime-internal-application-subtypes'." (interactive) (let ((subtypes vm-mime-internal-application-subtypes)) (while subtypes (vm-mime-register-internal-application (car (car subtypes)) nil) (setq subtypes (cdr subtypes))))) ;;; vm-mime-display-internal-application.el ends here vm-8.2.0b/contrib/org-vm.el0000755000175000017500000001265011676442160015766 0ustar srivastasrivasta;;; org-vm.el --- Support for links to VM messages from within Org-mode ;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 ;; Free Software Foundation, Inc. ;; Author: Carsten Dominik ;; Uday S Reddy ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://orgmode.org ;; Version: 6.35trans ;; ;; This file is part of GNU Emacs. ;; ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;; Commentary: ;; This file implements links to VM messages and folders from within Org-mode. ;; Org-mode loads this module by default - if this is not what you want, ;; configure the variable `org-modules'. ;; ;; This file has been enhanced with ability to store links to POP and ;; IMAP folders, and works only for VM versions 8.1.1 and up. USR 2010-04-26 ;;; Code: (require 'org) ;; Declare external functions and variables (declare-function vm-preview-current-message "ext:vm-page" ()) (declare-function vm-follow-summary-cursor "ext:vm-motion" ()) (declare-function vm-get-header-contents "ext:vm-summary" (message header-name-regexp &optional clump-sep)) (declare-function vm-isearch-narrow "ext:vm-search" ()) (declare-function vm-isearch-update "ext:vm-search" ()) (declare-function vm-select-folder-buffer "ext:vm-macro" ()) (declare-function vm-su-message-id "ext:vm-summary" (m)) (declare-function vm-su-subject "ext:vm-summary" (m)) (declare-function vm-su-to-names "ext:vm-summary" (m)) (declare-function vm-su-full-name "ext:vm-summary" (m)) (declare-function vm-summarize "ext:vm-summary" (&optional display raise)) (declare-function vm-folder-name "ext:vm-folder" ()) (defvar vm-message-pointer) (defvar vm-folder-directory) ;; Install the link type (org-add-link-type "vm" 'org-vm-open) (add-hook 'org-store-link-functions 'org-vm-store-link) ;; Implementation (defun org-vm-store-link () "Store a link to a VM folder or message." (when (or (eq major-mode 'vm-summary-mode) (eq major-mode 'vm-presentation-mode)) (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) (vm-follow-summary-cursor) (save-excursion (vm-select-folder-buffer) (let* ((message (vm-real-message-of (car vm-message-pointer))) (buffer (vm-buffer-of message)) (folder (with-current-buffer buffer (if (fboundp 'vm-folder-name) ; defined in VM 8.1.1 (vm-folder-name) (buffer-file-name)))) (subject (vm-su-subject message)) (to (vm-su-to-names message)) (from (vm-su-full-name message)) (message-id (vm-su-message-id message)) desc link) (org-store-link-props :type "vm" :from from :to to :subject subject :message-id message-id) (setq message-id (org-remove-angle-brackets message-id)) (setq folder (abbreviate-file-name folder)) (if (and vm-folder-directory (string-match (concat "^" (regexp-quote vm-folder-directory)) folder)) (setq folder (replace-match "" t t folder))) (setq desc (org-email-link-description)) (setq link (org-make-link "vm:" folder "#" message-id)) (org-add-link-props :link link :description desc) link)))) (defun org-vm-open (path) "Follow a VM message link specified by PATH." (let (folder article) (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) (error "Error in VM link")) (setq folder (match-string 1 path) article (match-string 3 path)) ;; The prefix argument will be interpreted as read-only (org-vm-follow-link folder article current-prefix-arg))) (defun org-vm-follow-link (&optional folder article readonly) "Follow a VM link to FOLDER and ARTICLE." (require 'vm) (setq article (org-add-angle-brackets article)) (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) ;; ange-ftp or efs or tramp access (let ((user (or (match-string 1 folder) (user-login-name))) (host (match-string 2 folder)) (file (match-string 3 folder))) (cond ((featurep 'tramp) ;; use tramp to access the file (if (featurep 'xemacs) (setq folder (format "[%s@%s]%s" user host file)) (setq folder (format "/%s@%s:%s" user host file)))) (t ;; use ange-ftp or efs (require (if (featurep 'xemacs) 'efs 'ange-ftp)) (setq folder (format "/%s@%s:%s" user host file)))))) (when folder (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) (sit-for 0.1) (when article (require 'vm-search) (vm-select-folder-buffer) (widen) (let ((case-fold-search t)) (goto-char (point-min)) (if (not (re-search-forward (concat "^" "message-id: *" (regexp-quote article)))) (error "Could not find the specified message in this folder")) (vm-isearch-update) (vm-isearch-narrow) (vm-preview-current-message) (vm-summarize))))) (provide 'org-vm) ;; arch-tag: cbc3047b-935e-4d2a-96e7-c5b0117aaa6d ;;; org-vm.el ends here vm-8.2.0b/CHANGES0000755000175000017500000104107711676442160013576 0ustar srivastasrivasta-*-Text-*- This file contains the list of changes up to revision 7.19, developed by Kyle Jones. For recent changes, please see the `NEWS' file. VM 7.19 released (29 September 2004) * New variables: + vm-stunnel-program-additional-configuration-file * added vm-mouse-send-url-to-safari to send URLs to Safari under Mac OS X. * added docstrings for vm-mime-reader-map-* commands. * normalized prefix key description layout in vm-mode docstring. * added some missing MIME commands to menu entries. * undo change in vm-preview-current-message that required vm-auto-decode-mime-messages to be non-nil along with vm-display-using-mime before creating the presentation copy of a message. It has the unexpected side-effect of breaking 'D' when vm-auto-decode-mime-messages is nil. VM 7.18 released (2 November 2003) * New variables: + vm-default-new-folder-line-ending-type * vm-mail-internal: use idle timers to run vm-update-composition-buffer-name instead of post command hooks * vm-decode-mime-layout: always delete a MIME object button after doing a type conversion. * vm-mail-send: bind coding-system-for-write to match the coding system of mail-archive-file-name (if set) so that mail-do-fcc writes to the file using the correct line endings. * vm-make-tempfile-name, vm-make-tempfile: accept optional second argument 'proposed-filename' which will be used if a file with that name do not exist in vm-tempfile-directory. If such a file exists, then a number and a dash will be prepended to the proposed filename and the number will be incremented until no such file exists. * don't use vm-menu-fsfemacs-image-menu unless vm-use-menus is non-nil. * vm-preview-current-message: require vm-auto-decode-mime-messages to be non-nil along with vm-display-using-mime before creating the presentation copy. This helps prevent selection of the presentation buffer when the user likely needs to do M-x recover-file. VM 7.17 released (6 July 2003) * New commands: + vm-create-imap-folder + vm-delete-imap-folder + vm-rename-imap-folder * vm-edit-message-end: try to positoin the cursor in the message window roughly where it was in the edit window. * vm-read-imap-folder-name: allow vm-imap-make-session to return nil without crashing. Also, bind vm-imap-ok-to-ask non-nil so that vm-imap-make-session will interactively prompt for a password. * added menu entry to Folder menu for vm-visit-imap-folder. * vm-imap-normalize-spec: convert auth method to * instead of the IMAP folder name. * vm-imap-get-message-flags: fixed flag retrieval so that it actually works now. * vm-handle-file-recovery-or-reversion: find an IMAP spec for the buffer so that the spec is passed to the 'vm' command instead of the buffer-file-name. This fixes a wrong-type-argument error under M-x recover-file when done on a IMAP cache folder. * tapestry.el: in tapestery-window-edges check for existence of face-width and face-height in addition to window-pixel-edges. * search for BASE64/QP encoder/decoder programs and set the encoder/decoder program variable based on what we find. * vm-mf-default-action: if object is convertible to a displayble type mention the conversion that will happen in the action string. VM 7.16 released (26 May 2003) * New commands: + vm-visit-imap-folder + vm-visit-imap-folder-other-window + vm-visit-imap-folder-other-frame + vm-save-message-to-imap-folder * New variables: + vm-imap-server-list * vm-primary-inbox can now be a POP or IMAP mailbox specification. * vm-mime-set-xxx-parameter: use the parameter name passed in instead of assuming the name is "charset". The only calls to this function passed in "charset" as the name, so this bug wasn't affecting anything. * vm-decode-mime-encoded-words: do charset conversion if needed. Forgot to add this back when vm-mime-charset-converter-alist was added. * vm-send-mail-and-exit -> vm-mail-send-and-exit in vm-user-agent definition. * vm-mail-send-and-exit: dropped first arg requirement since the argument isn't used anyway. * compute POP cache filenames based on the POP mailbox spec with the access method as "pop" and the authentication method and port as asterisks. This prevents visiting the wrong file if the user starts accessing a POP mailbox through a different port or using a different access or authentication method. Automatically migrate the old cache files to the new scheme as we go. * fixed convert -page typos. * vm-set-redistributed-flag: fourth arg of vm-set-xxx-flag call corrected to be vm-set-redistributed-flag instead of vm-set-forwarded-flag. * IMAP BYE responses are always untagged; changed code to match. VM 7.15 released (3 May 2003) * Makefile: filter echo's output through tr to avoid CRs under Cygwin. * Makefile: Use '>' instead of '>>' on first write to vm-autoload.el to truncate the file otherwise it will grow each time it is updated. * vm-mime-attach-message: arrange for forwarded flag of each attached message to be set when the composition is sent. * when cropping images call 'convert' with -page to avoid having some kind of margin tacked on to the image. The strange margin seems to be applied to GIFs but not JPGs. No idea why. * fixed some defcustom variable declarations. * vm-mime-reader-map-save-file: return the file name to which the object was saved. * vm-mime-burst-digest: remove blank lines at the beginning of message/rfc822 bodies in a multipart/digest object, since they most likely indicate an improperly packed digest rather than a message with no headers. * vm-make-tempfile: use vm-octal to clarify file mode setting. * vm-make-image-strips: when building the script for incremental display, don't quote the filenames. DJGPP cmdproxy.exe doesn't interpret single quotes and using double quotes is pointless. VM's arguments to 'convert' don't need quoting anyway. * use vm-pop-check-connection to check POP connections before trying to read data from them. The checker will signal an error if the connection is closed or the process associated with the connection has exited. * use vm-imap-check-connection to check IMAP connections before trying to read data from them, The checker will signal an error if the connection is closed or the process associated with the connection has exited. VM 7.14 released (27 March 2003) * moved (provide ...) to bottom of .el files. * Made the vm-undo command undo everything the last command did. E.g. vm-undo after vm-kill-subject undoes all of the related deletes instead of just one of them. vm-undo-boundary is only called from vm-add-undo-boundaries now. vm-add-undo-boundaries is called from post-command-hook. VM 7.13 released (19 March 2003) * '(vm-marker -> (vm-marker in vm-mime-parse-entity. VM 7.12 released (14 March 2003) * vm-pop-make-session: use new stunnel configuration code introduced in VM 7.11. This was only installed in vm-imap-make-session previously. * create MIME layout from plist instead of using a raw vector. The layout struct is still a vector. * save original layout when doing a layout conversion so that if the object needs to be deleted we still ahve the correct object endpoint in the folder buffer. In the old code the endpoints in the converted object buffer would be used in the folder buffer with disastrous results. VM 7.11 released (5 March 2003) * fixed check for usability of uncompface's -X flag, needed symbol to be unquoted. * fixed check for stunnel 4, check for non-zero exit code instead of string, moved check to the time when stunnel is first run. * vm-stunnel-configuration-args: fixed reversed v3/v4 logic. * vm-stunnel-configuration-file: reuse the stunnel configuration tempfile. * vm-parse: fourth arg limits the number of matches before returning. * vm-parse: after we quit matching add everything after the last match to the list that is returned, but do this ONLY if the fourth arg 'matches' was specified. * compute POP cache filenames based on the POP mailbox spec with the password as an asterisk. This prevents visiting the wrong file if the user has the password in the spec and later changes their password. Automatically migrate the old password-based cache files to the new scheme as we go. * vm-pop-make-session: parse POP mailbox spec in a way that permits colons in the user's password. * install .el files before .elc files to avoid "source file newer than compiled file" problems. * added ] to char class exclusion in mailto spec in vm-url-regexp to help with MS EXchange's [mailto:foo] syntax. VM 7.10 released (5 March 2003) * vm-menu-url-browser-menu: add third element to clipboard and Konqueror entries--- VM's menu code under GNU Emacs requires it. * treat device-type `gtk' like `x' under XEmacs so that VM running on GTK-XEmacs will use window system features. * vm-imap-move-mail: set use-body-peek after retrieving the CAPABILITY results. (oops) * Makeflie: default install target now installs the .el files. * added support for version 4 of stunnel. VM 7.09 released (3 March 2003) * New variables: + vm-mime-forward-local-external-bodies * vm-mime-fsfemacs-encode-composition: if object is in a buffer, write the buffer out to disk and insert the file contents instead of copuying buffer to buffer. This avoids the trademark \201 data corruption. * vm-su-thread-indent: check for vm-summary-show-threads non-nil before calling vm-th-thread-indentation. * vm-summary-compile-format-1: added %(..%) format groups. * don't forward Content-Length header. * use results of CAPABILITY command to check for authentication methods before trying to use them. * use results of CAPABILITY command to decide whether to use BODY.PEEK vs. RFC822.PEEK. * vm-mime-attach-object-from-message: move window point to beginning of the line after the inserted attachment if the compositoin buffer is being displayed in a window. * vm-mime-parse-entity-safe: set c-t-e to "7bit" if it is nil. * vm-mime-fetch-url-with-programs: erase the work buffer between tries of various URL fetch programs; this handles the case where an URL fetcher outputs part of the data and then dies. * added support for the `fetch' and `curl' URL fetch programs for message/external-body. * vm-mime-fsfemacs-encode-composition: call vm-mime-parse-entity twice for already MIME'd objects. vm-mime-xemacs-encode-composition similarly modified. * vm-mime-fsfemacs-encode-composition: don't automatically base64-encode non-composite non-text objects that already have MIME headers. Use vm-mime-transfer-encode-layout on them instead to produce the correct encoding. vm-mime-xemacs-encode-composition similarly modified. * dropped support for url-w3 retrieval method. It's interface too crusty to continue using given the wide availabity of external programs that do the job. * vm-mime-display-internal-message/external-body: pulled retrieval guts out and put into vm-mime-retrieve-external-body. * added support for simple image manipulations, supported by Imagemagick's `convert' program. Use mouse button 3 on an image to see what you can do. * added Konqueror to vm-menu-url-browser-menu. * added option to send to the X clipboard to vm-menu-url-browser-menu. VM 7.08 released (14 February 2003) * New variables + vm-mime-ignore-missing-multipart-boundary + vm-url-browser-switches * vm-mime-attach-object-from-message: decode object after stuffing it into the work buffer. Two reasons: (1) the composition encoding code doesn't expect base64 or QP encoded objects and will encode them again, and (2) we shouldn't trust that the original object was encoded properly so we should re-encode it since we're sending it. * vm-mime-display-internal-multipart/alternative: a badly formed mesage may cause VM to find no message parts so don't call vm-decode-mime-layout unless best-layout is non-nil. * vm-su-subject: compress \n[ \t]* to a single space. * README: Added (vm) to the example VM entry in the 'dir' file. Apparently the old entry won't work without it anymore. * vm-mime-parse-entity-safe: error/error MIME layout needs to be length 16; added a nil. Really need to macroize creation of the layout object someday. * vm-recover-file: call recover-file with call-interactively instead of apply. * vm-revert-buffer: call revert-buffer with call-interactively instead of apply. * vm-decode-mime-layout: check if layout has been converted and don't try to convert it again if so. * vm-vs-or, vm-vs-and: check existence of selector function and signal error if not found. * vm-md5-region: accept " -" and " *-" before the md5 checksum because md5sum stupidly produces extra output on some systems. * vm-imap-end-session: trying reading the response to the LOGOUT command and see if we start hanging in some environments. * vm-imap-make-session: don't query for password if the authentiation method is "preauth". * vm-visit-virtual-folder: select the message corresponding to the real message the user used as a basis for this folder, if there was one. Only honor the vm-jump-* variables if there's no corresponding real message to use. * vm-compose-mail: run mail-citation-hook or mail-yank-hooks or the normal VM default action after yanking the message text. Always position point in the body before running the yank action. Don't assume the yank action is smart enough to position point correctly before inserting the text. * vm-recognize-imap-maildrops,vm-recognize-pop-maildrops: changed regexp to allow colons in the last field. * dropped single quotes in const choice values in defcustom for vm-mime-alternative-select-method. * Makefile: use \015 instead of \r with tr due to bug in Solaris 8's tr which removes r's. * vm-get-mail-itimer-function: correct use of timer-set-time; set new firing time to now + vm-auto-get-new-mail instead of now with a delta of vm-auto-get-new-mail, to avoid having the timer expire repeatedly in the same second. Similar change in vm-check-mail-itimer-function which support vm-mail-check-interval. Similar change in vm-flush-itimer-function which supports vm-flush-interval. * vm-decode-mime-message: vm-preview-read-messages -> vm-preview-lines so that message previewing is turned off for the 'raw' and 'all buttons' displays. * vm-mail-send: bind select-safe-coding-system-function to nil during call to mail-send to prevent Emacs from prodding user about the FCC coding system. The coding system used should be raw-text and VM sets buffer-file-coding-system to that. * vm-stuff-attributes: don't clear modflag if stuffing for another folder, since the information stuffed in that case is missing the deleted flag if that flag was set. * use defconst to set vm-faked-defcustom so that the checking works correctly if vm-vars.el is loaded twice. * vm-mime-parse-entity: find multipart boundaries, then recurse into parts. This satisfies the new rule in RFC 2046 that outer level multipart boundaries be recognized at any level of inner nesting. * vm-mime-send-body-to-file: removed let-binding of variable file which was shadowing the function parameter of the same name. This should make the function not ask about a filename even when one has already been provided. * define vm-folder-history as a function that returns t so that when it is passed as the sixth arg to read-file-name under Emacs 21 it does not cause void-function to be signaled when completion is attempted. * vm-mime-send-body-to-folder: force conversion to target folder's type since the user doesn't know what type we're using in the temp folder. * vm-save-message: dno't try to honor vm-delete-after-saving if the folder is read-only. * vm-delete-duplicate-messages: compute hash on real folder contents rather than virtual copy. Fixes utterly brokwn behavior when run on a virtual folder. VM 7.07 released (5 June 2002) * vm-sort-messages: move first call of vm-update-summary-and-mode-line out to callers. Threading bonks if we call it in here. * vm-assimilate-new-messages: resume calling vm-update-summary-and-mode-line to clear the decks before thread sorting. * vm-toggle-threads-display: start calling vm-update-summary-and-mode-line to clear the decks before thread sorting. VM 7.06 released (3 June 2002) * vm-save-folder,vm-write-file: support vm-default-folder-permission-bits here, since a folder might be created when it is saved. * vm-save-message,vm-save-message-sans-headers: use the target folder's line ending coding system for saves. If the target doesn't exist use the local system's default. * vm-write-string: don't set an explicit coding system for writes, use the ambient value. * vm-sort-messages: call vm-update-summary-and-mode-line to clear the decks before sorting. * vm-mail-internal: UNder FSF Emacs set the coposition buffer coding system to 'raw-text' which should stop write-region from question the coding system inside mail-do-fcc. VM 7.05 released (10 May 2002) * New variables: + vm-default-folder-permission-bits * Makefile: added install-el target. * always set mode-popup-menu; it's value should not depend on the value of vm-popup-menu-on-mouse-3. * vm-stuff-folder-attributes: added status messages. * vm-mime-discard-layout-contents: call vm-set-modflag-of on the modified message. * vm-preview-composition: add a newline at end of the preview buffer if the composition lacks one. * vm-url-decode-buffer: fixed brain-o; bind case-fold-search to t instead of nil. * use new vm-octal function instead of writing out UNIX permission bits in decimal. * defcustom :type fixes. * added "image" to default value of vm-auto-displayed-mime-content-types. * vm-mime-should-display-internal: ignore Content-Disposition as it has no bearing on whether an object is displayed internally. * vm-assimilate-new-messages: build threads very early if vm-summary-show-threads is non-nil. Don't run vm-update-summary-and-mode-line before sorting threads--- this should no longer be necessary thanks to the change to to vm-set-numbering-redo-start-point. * vm-set-numbering-redo-start-point: compare message structs instead of list conses. * vm-unthread-message: only unthread if threads have been built in a particular message's buffer. * vm-thread-list: keep track of the youngest member of a thread. * vm-sort-compare-thread: sort threads by youngest member instead of by oldest member. Also sort thread siblings by date instead of by message-id; sort by messge-id if dates are equal (rare). VM 7.04 released (18 April 2002) * New commands: + vm-mime-attach-object-from-message (bound to $ a) * New variables: + vm-mime-ignore-composite-type-opaque-transfer-encoding * fixed problem with a repeated char being displayed after an X-Face when a non-MIME message is reselected. * Makefile: remove CRs from the output of make-autoloads. Emacs when run under Cygwin apparently emits them. * vm-session-initialization: create gui-button-face under XEmacs if it does not exist. * vm-mime-display-internal-text/html: don't use W3 if vm-mime-use-w3-for-text/html is nil. * recognize 'mac' as a window system with mouse, image, and multi-font support (FSF Emacs only). * put vm-update-composition-buffer-name on post-command-idle-hook instead of post-command-hook if the idle hook is available for use. * vm-menu-vm-menu: added commas to variable refernece so they would be evalled in the backquote context. * changed hook defcustoms to use 'hook instead of '(list function). * vm-read-index-file: do thread sort if necessary since vm-assimilate-new-messages isn't going to do it. * default vm-thread-obarray and vm-thread-sort-obarray to non-nil values so that if they are used as obarrays before initialization an error will be signaled. * vm-mime-pipe-body-to-queried-command: prompt with "Pipe object to command:" instead of "Pipe to command:". * make sure select-message-coding-system is fbound before overriding its definition. Apparently early Emacs 20 versions do not define it. * vm-imap-read-object: move point past closing double quote to fix parsing problem that caused VM to hang. * vm-mime-display-button-xxxx: always insert the button, even we have no method for displaying the MIME object. VM 7.03 released (4 March 2002) * fixed defcustom syntax errors. * minor compiler warning cleanup. VM 7.02 released (3 March 2002) * New variables: + vm-uncompface-program + vm-icontopbm-program * display X-Faces under Emacs 21 if necessary support programs are available. * vm-url-decode-buffer: accept lower cased hex digits in escapes as per the URL spec RFC. * map "unknown" charset to iso-8859-1 in vm-mime-mule-charset-to-coding-alist. * dropped use of defmacro in many places in favor of defsubst. * use backquote macro instead of (list ...) in many places since the old objection of differing backquote syntax between Emacs versions no longer applies. * define menu variables using defvar instead of defconst. * use vm-revert-buffer and vm-recover-file in menus instead of revert-buffer and recover-file because the menu-enabled form is global for these symbols and VM's form was overriding the one in the global Emacs menu. This problem only occur under FSF Emacs. * use defcustom instead of defvar for most user customization variables. VM 7.01 released (22 January 2002) * New variables: + vm-mime-use-w3-for-text/html * new possible values for vm-mime-alternative-select-method: (favorite ...) and (favorite-internal ...). * vm-visit-pop-folder: use value of vm-last-visit-pop-folder if interactive user entered an empty string as the folder. * vm-mail-send: bind sendmail-coding-system to the binary coding system and bind mail-send-nonascii to t so that mail-send will leave us alone. * redefine select-message-coding-system if it is fbound and we're running FSF Emacs MULE. It doesn't like no-conversion as a coding system, so we get it out of the way. * define vm-image-too-small properly as an error condition. * vm-scroll-forward-one-line, vm-scroll-backward-one-line: accept a numeric prefix arg. * vm-setup-ssh-tunnel: use copy-sequence on vm-ssh-program-switches to avoid corrupting the list tail with nconc. * vm-mime-can-convert-0: always return the conversion that produces an internally displayable type if there is one. Fallback to the externally displayable type if there is none that can be displayed internally. * vm-mime-can-convert-0: don't return a match when the target type matches the original type. * vm-mime-display-internal-image-xemacs-xxxx: wrap image extents around spaces instead of newlines. Adjust newline insertion code accordingly. Create image strips twice the default font height to avoid having to match the font ascent value. Don't use vm-monochrome-face except on XBM images. * vm-display-image-strips-on-extents, vm-display-some-image-strips-on-extents: Don't use vm-monochrome-face except on XBM images. * support completion-ignore-case variable. * block interactive use of vm-expunge-pop-messages in a POP folder. It's meant for folder linked to POP spool files, not POP folders. * use display-planes function to determine if Emacs 21 is running on a "colorful" display. * put image/xpm ahead of image/pbm in vm-mime-image-type-converter-alist. * vm-parse-date: find year even if it's at the end of line. VM 7.00 released (2 December 2001) * New commands: + vm-visit-pop-folder + vm-visit-pop-folder-other-window + vm-visit-pop-folder-other-frame * New variables: + vm-pop-folder-alist + vm-pop-folder-cache-directory * vm-parse-date: fixed search to allow monthday digits to occur at the beginning of a string. * vm-get-mail-itimer-function: skip buffer if bm-block-new-mail is set. This avoids vm-get-spooled-mail signaling "can't get new mail until you save this folder" later. Also check for mail block and folder read-only before doing the expensive file stat checks. * vm-get-image-dimensions: don't search for the filename in the 'identify' output. Apparently 'identify' will sometimes substitute a different filename than we expect. Instead just search for a space and then start looking for the image dimensions from that point. * moved setting of vm-folder-type in the POP trace buffer from vm-pop-move-mail to vm-pop-make-session so that all callers get of vm-pop-make-session get the feature. * vm-assimilate-new-messages: check for new-messages non-nil before attempting some things. Makes the function a bit more efficient if we call it and no new messages are found. * vm-pop-report-retrieval-status, vm-imap-report-retrieval-status: report "post processing" if 'need' value is nil. * vm-pop-retrieve-to-crashbox -> vm-pop-retrieve-to-target * vm-imap-retrieve-to-crashbox: use new "post processing" reporting. * vm-pop-retrieve-to-target: use new "post processing" reporting. * vm-expunge-pop-messages: record which messages were expunged by stuffing nil into the car of the cell in vm-pop-retrieved-messages. At the end strip out all the nils, leaving the data for messages that we had problems expunging from the POP server. * in vm-stuff-* functions check for vm-message-list non-nil instead of vm-message-pointer. * vm-pop-end-session: check whether the process is still open or running before attempting to send the QUIT command. Also check whether the process buffer is still alive before killing it. * vm-get-spooled-mail: gutted, with most of it going into vm-get-spooled-mail-normal. Calls vm-pop-synchronize-folder for folders that use the POP access method. * vm-session-initialization: when deciding whether to create the vm-image-placeholder face check for image-type-available-p being fbound, not vm-image-type-available-p. * use instead of as the name of the faces used to display images under Emacs 19 and 20. * vm-mime-display-internal-image-xemacs-xxxx: insert a newline before the image if point is at the same position as the beginning of the text portion of the message. Otherwise there is no visible separation between the image and the message headers. * vm-pop-report-retrieval-status, vm-imap-report-retrieval-status: record in the statblob the fact that some status was reported. * vm-pop-stop-status-timer, vm-imap-stop-status-timer: if any status was reported, do (message "") to clear the echo area. VM 6.99 released (25 November 2001) * New commands: + vm-scroll-forward-one-line + vm-scroll-backward-one-line * New variables: + vm-imagemagick-identify-program + vm-mime-display-image-strips-incrementally * vm-do-folders-summary: bind default-directory to the directory names when checking for subdirectories amongst its children with vm-delete-directory-names. * vm-get-image-dimensions: use the ImageMagick program 'identify' instead of 'convert' to get the image dimensions. * vm-thread-list: set done to t if we've run out of references and we're not threading by subject (vm-thread-using-subject == nil). Fixes infloop. * use the vm-monochrome-image face for image glyphs instead of vm-xface under XEmacs. * use a face with a background stipple (vm-image-placeholder) on the spaces used to display images in FSF Emacs 19. * vm-display-image-strips-on-overlay-regions: store modified flag value after the process buffer is selected, otherwise we're recording the state of the wrong buffer. * vm-mime-display-internal-image-fsfemacs-21-xxxx: If the image strip is the same height as the font the image ascent ratio must match font ascent ratio else the image strips will be displayed with gaps between them. There's currently no way to get font ascent information under Emacs 21. Use strips that are twice the font height and a 50/50 ascent ratio to avoid this problem. * vm-make-image-strips: remainder math was wrong; fixed. Use new remainder math in the sync branch. Use vm-make-tempfile instead of vm-make-tempfile-name. * when cutting images into strips give 'convert' an explicit target type. Otherwise it might choose some unknown new type that Emacs can't display. * vm-parse-date: simplified the search for the monthday and the year, hopefully reducing the problems with confusing 2-digit years and monthdays. * vm-thread-list: check and set 'oldest-date property on all the messages. * vm-mail-internal: eval the value of mail-signature and insert the result if its value is not nil, t or a string. Also, if mail-signature is a string, subject the result to the same check for a proper signature separator. VM 6.98 released (18 November 2001) * New variables: + vm-mime-use-image-strips + vm-imagemagick-convert-program + vm-w3m-program + vm-mime-charset-converter-alist * inline image display support for Emacs 19 and Emacs 20. * vm-md5-region: deal with the " -\n" that md5sum appends to the checksum output when summing stdin. * vm-edit-message: set buffer-offer-save to t so that if user types C-x C-c they won't lose their changes in the message edit session without warning. * vm-spool-files: remove any directories from vm-spool-files that we slurped from environmental variables. There was a case where a user's MAIL variable was set to /var/mail. I don't know how widespread this practice is. * when initializing vm-temp-file-directory check for C:\TEMP before C:\. * vm-setup-ssh-tunnel: instead of sleeping for a bit and hoping that's long enough to establish a connection, read some output from the tunnel before returning so we know that the connection is established. vm-ssh-remote-c0mmand has to provide the output, so its default value has been changed to produce output. * vm-frame-loop: don't reset the starting frame placeholder unless the starting frame was really deleted. Fixes an infloop when quitting out of VM and the VM summary is visible in multiple frames. * try to use the ImageMagick 'convert' program (if available) to convert image types that Emacs can't display internally into images that Emacs can display. * support the unregistered image/xbm, image/xpm and image/pbm types, so that we can autoconvert unsupported image types to these types under an Emacs that's compiled with minimal image support. * use w3m to retrieve URLs if specified in vm-url-retrieval-methods. * make layout cache be the property list of a symbol instead of an alist. * use vm-make-tempfile in more places to produce private tempfiles instead of vm-make-tempfile-name. * vm-preview-composition: mnuge message separators that appear in the message body. Use MMDF for the temp folder type. * all your base no longer are belong to us. VM 6.97 released (28 October 2001) * New variables: + vm-mime-require-mime-version-header * SSL support for IMAP and POP. * SSH tunnel support for IMAP and POP. * uninstall toolbar goop from vm-mode-map under FSF Emacs if we're creating a frame and vm-use-toolbar is nil. * don't use a heuristic background map in the toolbar image spec for the MIME icon. * vm-make-tempfile-name: add a random elemnt to VM's temporary file name. * vm-pop-cleanup-region, vm-imap-cleanup-region: don't emit CRLF->LF status messages. Say something about post-processing in the normal status message instead. * vm-mail-to-mailto-url: do session initialization stuff so that the function can be called from gnuclient. This is apparently useful for driving VM from a web browser that allows use of an external mailer. * vm-mime-encode-composition: undo buffer changes if an error occurs during encoding. * rename certain composition buffers on the fly as the recipient headers change to reflect the new primary recipient(s). * vm-submit-bug-report: call vm-session-initialization so the all necessary goop is loaded, rather than doing a few 'require' calls. This fixed the bug in the VM XEmacs package where calling vm-submit-bug-report immediately after starting XEmacs would cause (void-function vm-display) to be signaled. * vm-th-parent: when extracting the parent message ID from the In-Reply-To header, use the longest ID found, instead of the first ID found. Store the result in the references slot in the message struct, since that slot must be empty otherwise we would be ignoring In-Reply-To. * vm-thread-list: remove the clock skew loop-recovery-point heuristic; seems to cause more breakage than it fixes. * vm-mime-display-internal-image-fsfemacs-xxxx: use a unibyte buffer as a work buffer when unpacking an image file. Apparently needed to avoid the evil \201 corruption under Emacs 21. * accept 'name' parameter as suggested filename for all MIME types. Old broken software that sends this stuff will never go away and complaints about it will never end. * default vm-use-lucid-highlighting non-nil only if (require 'highlight-headers) doesn't signal an error. * vm-md5-region: call the MD5 program directly instead of using sh -c. * vm-pop-md5: call the MD5 program directly instead of using sh -c. * vm-check-for-spooled-mail, vm-get-spooled-mail: bind case-fold-search to nil for comparisons against vm-recognize-*. * vm-preview-current-message: do less work if the user will never see the message in the previewed state. * vm-preview-current-message: just MIME decode the headers rather than the whole message if vm-preview-lines == 0. * vm-mime-convert-undisplayable-layout: check exit status of command and if non-zero return nil. Fixed all callers to deal with this new reality. VM 6.96 released (5 September 2001) * print-autoloads: handle fset calls. There are paths through the code that reach functions that are to be defined by fset but lack autoload definitions. print-autoloads now creates autoload definitions for them. * vm-mime-encapsulate-messages: pluralization fix in MIME digest preamble. Don't output "messages" if there's only one message in the digest. * vm-display-startup-message: update copyright date. Use \251 under XEmacs to show the c-in-circle copyright glyph. Can't rely on FSF Emacs being setup to display it. * vm-mime-display-internal-application/octet-stream: honor setting of vm-mime-delete-after-saving. * vm-imap-move-mail: don't emit warning messages if BODY.PEEK fails--- no one cares. Don't retry BODY.PEEK after it fails the first time, it will never work. Use RFC822.PEEK henceforth within this IMAP session. * vm-toolbar-support-possible-p: check whether the variable tool-bar-map is bound. Apparently tool-bar-mode is fboun even when there is no toolbar support (e.g. under Windows). * moved guts of vm-discard-cached-data to vm-discard-cached-data-internal. * vm-mime-attach-message: corrected prompt in the "attach from other folder" case. * vm-summary-sprintf: decode encoded words in the final string if we're not producing a tokenized result and vm-display-using-mime is not nil. * vm-mail-to-mailto-url: support full RFC2368 mailto URL spec. * vm-pop-send-command: use one process-send-string call instead of two, which should saves some packet overhead at the expense of more string consing. * vm-imap-send-command: use one process-send-string call instead of three, which should saves some packet overhead at the expense of more string consing. * vm-imap-send-command: allow sending a string without a tag. Also allow sending a string with a caller specified tag. * vm-imap-make-session: don't send a tag with the CRAM-MD5 challenge response. * vm-do-summary: reuse the mouse-track overlays if possible, instead of generating a new one each time. The old ones apparently are never reclaimed by Emacs until the buffer is killed and degrade editing performance in that buffer. * vm-imap-ask-about-large-message: require simple "OK" response after fetching headers instead of "OK FETCH". The "FETCH" part may never come and isn't required. * vm-save-folder: sweep though virtual folder associated with the real folder and set their buffer modified flags to nil if they are none of their real folders are modified. * vm-thread-list: don't allow the first and last element of a multielement thread list to be the same message-ID. This is a thread loop that previously was previously undetected. * vm-thread-list: remember the position in the thread list where we first threaded using subject information and reset the thread list to that point if we encountered a message ID we've seen before. This is a heuristic to try to trim off parents-by-subject that are only parents due to clock skew. VM 6.95 released (23 July 2001) * New variables: + vm-mime-attachment-auto-suffix-alist * vm-guess-digest-type: require a line consisting of 30 dashes in addition to the 70 dashes line before guessing RFC 1153. * vm-md5-region: add third arg that prevents re-search-forward from signalling an error if it fails. * vm-toolbar-update-toolbar: don't use the 'getmail' icon as the helper button if 'getmail' is already on the toolbar. * vm-toolbar-update-toolbar: don't use the 'mime icon as the helper button if 'mime' is already on the toolbar. * vm-mime-attach-message: if invoked on marked messages (C-c C-v M N C-c C-m) attach the marked messages in the parent folder as a digest. * vm-mail-mode-remove-tm-hooks: remove global TM/SEMI hooks from mail-setup-hook and mail-send-hook if vm-send-using-mime is non-nil. Previously VM tried to remove the hooks locally but that doesn't work. * fixed negative Content-Length computation problem - vm-find-leading-message-separator, vm-find-trailing-message-separator: new type 'baremessage means go to point-max. - vm-pop-retrieve-to-crashbox, vm-imap-retrieve-to-crashbox: use 'baremessage as old type during header conversion. Narrow to region around message during this conversion so that folder traversal functions can safely go to point-max without moving past the end of the message. * vm-pop-make-session, vm-imap-make-session: don't sleep for 2 seconds after reporting a bad password unless the function was called synchronously, i.e. not from a timer. * vm-check-mail-itimer-function, vm-get-mail-itimer-function, vm-flush-cached-data: when traversing the buffer list, check whether a buffer is still alive before selecting it. Because the loop calls input-pending-p, a timer or process-filter could have killed one of the buffers. * vm-delete-duplicate: remove duplicate addresses case insensitively This is still sort of wrong, in that the only the right hand side of the address should be treated this way. But doing the right thing is hard. * vm-mime-display-internal-image-xemacs-xxxx: make the image extent be 'start-open' so that it is moved forward when text is inserted at its position. This fixes the image doubling problem if a mssage containing only an image is previewed with vm-mime-deocde-for-preview set non-nil. * vm-narrow-for-preview: added kludge to prevent images and button art from being displayed at the edge of a preview cutoff during MIME decode-for-preview. Everything beyond the cutoff is shifted forward one character during MIME preview. (XEmacs only for now, but might be needed for FSF Emacs 21). * vm-mime-encapsulate-messages, vm-rfc934-encapsulate-messages, vm-rfc1153-encapsulate-messages: do a better job of protecting MIME headers. Sort the MIME headers to the top of the message then skip past them before applying the user's header filter variables. VM 6.94 released (9 July 2001) * in the defconst of vm-menu-mime-dispose-menu, check whether a non-string s-expression is allowed as a menu element name before trying to use one. Versions of XEmacs prior to 21.4 don't allow expressions as item names. VM 6.93 released (23 June 2001) * New variables: + vm-folder-file-precious-flag * added CRAM-MD5 as an authentication method for IMAP. * vm-su-do-date: interpret 2-digit years in the RFC-822 matching case as 20XX if year starts with 0-6. * vm-rfc1153-or-rfc934-burst-message: skip spaces in addition to newlines that occur after a separator line. A digest has been observed with that kind of deformity. * treat enable-local-eval as we do enable-local-variables--- always bind it to nil. * vm: don't bind vm-auto-decode-mime-messages non-nil during initial message preview if it is nil. * vm-mime-display-internal-text/html: dropped (sleep-for 2). No one cares enough about the "Need W3 to inline HTML" message to wait 2 seconds afterward. * added menu entry to allow MIME objects to be converted to another type and displayed. The new type is determined by vm-mime-type-converter-alist. * added koi8-r to vm-mime-mule-charset-to-coding-alist (XEmacs only). * vm-pop-read-list-response: check for nil return of vm-pop-read-response before using return value. * vm-pop-read-stat-response: check for nil return of vm-pop-read-response before using return value. * vm-encode-coding-region: use unwind-protect to make sure (well more likely) that the work buffer always gets killed if it has been created. * vm-decode-coding-region: use unwind-protect to make sure (well more likely) that the work buffer always gets killed if it has been created. * vm-mime-convert-undisplayable-layout: put object buffer on garbage list sooner to make rarer the situation where the buffer never gets deleted. * Makefile: remove function definition of vm-its-such-a-cruel-world after it is run. * vm-md5-region: if vm-pop-md5-program exits non-zero, signal an error. Also if the work buffer is not at least 32 bytes long, signal an error. This prevents naive callers from assumption all is well and using a possibly empty string as an MD5 hash. * vm-md5-region: check the MD5 digest returned for non-hex-digit characters and signal an error if any are found. * vm-get-file-buffer: use find-buffer-visiting if it is fbound. * vm-build-threads: fixed loop that removed child messages from a parent when better information about a child's parent is found. Previously the loop attempted to remove the same message from the parent over and over. * vm-build-threads: gather thread data using References and In-Reply-To for all messages before using the Subject header. This helps prevent the case where References says A is the parent of B but because of clock skew B is older than A, which can lead to B being considered the parent of A if A and B have the same subject and vm-thread-using-subject is non-nil. VM 6.92 released (11 March 2001) * vm-imap-check-mail: throw to 'end-of-session instead of 'done. Fixes problem of vm-spooled-mail-waiting not being set. * vm-su-do-recipients: If there is no To or Apparently-To header, use Newsgroups if available. * vm-mime-display-external-generic: use a unibyte temp buffer for base64 decoding if using FSF Emacs MULE. Otherwise our old friend \201 crashes the party. * vm-mime-find-leaf-content-id-in-layout-folder: add missing layout argument to vm-mime-find-leaf-content-id. * vm-mime-parse-entity: fixed regexps that match an empty content description so that they match descriptions that only contain spaces. * vm-su-do-date: make +/- mandatory in the numeric timezone spec. First digit of numeric timezone spec must be 0 or 1. * vm-fill-paragraphs-containing-long-lines: ignore errors generated by fill-paragraph. * moved the code that catches the font-lock search bound error from the XEmacs MIME composition encoder to the FSF Emacs encoder. * vm-mime-charset-internally-displayable-p: allow variable vm-mime-default-face-charsets to apply to MULE-enabled Emacs and XEmacs. VM 6.91 released (1 March 2001) * vm-mime-can-display-internal: check charset to verify that we can display it when checking text/html. * vm-auto-archive-messages: hide value of last-command when calling vm-save-message. * vm-mime-find-leaf-content-id: removed second arg in call to vm-mm-layout-id since it only accepts one argument. * vm-mime-transfer-encode-region: \\n -> \n in armor-dot check regexp string. * vm-mime-parse-entity-safe: dropped (sleep-for 2). No one cares about syntax errors. * vm-mime-base64-encode-region: if call to base64-encode-region fails with wrong-number-of-arguments error call it with only two args and do the B encoding cleanup separately. * vm-mime-base64-decode-region: don't use the FSF Emacs base64 decoding function, since it fails completely if it encounters characters outside of the BASE64 alphabet. * vm-mime-attachment-auto-type-alist: added the usual PDF, Quicktime and Excel file extensions. * vm-imap-move-mail: trying using obsolete RFC822.PEEK if BODY.PEEK fails. * vm-imap-retrieve-to-crashbox: support use of obsolete RFC822.PEEK. * vm-so-sortable-datestring: use vm-timezone-make-date-sortable instead of the bare timezone-make-date-sortable, which is less capable of parsing badly formed Date headers. * vm-mime-convert-undisplayable-layout: save the content type parameters from the old type and give them to the new type. * all your base are belong to us VM 6.90 released (9 January 2001) * vm-compose-mail: Use apply instead of funcall to call the yank action. We aren't passing a list of arguments to the function. * vm-mark-or-unmark-messages-same-author: compare author addresses case insensitively. * vm-emit-eom-blurb: ignore case when matching against vm-summary-uninteresting-senders to match what vm-su-interesting-from does. * vm-mime-display-internal-text/html: use 'message' to display any errors encountered. * vm-mime-display-internal-text/enriched: use 'message' to display any errors encountered. * vm-yank-message: call vm-decode-mime-encoded-words in the correct buffer. * default value of vm-auto-center-summary changed from nil to 0. VM 6.89 released (22 December 2000) * vm-yank-message: MIME decode the headers of the yanked message if vm-display-using-mime is non-nil. * vm-forward-message: if MIME forwarding, switch the buffer containing the attached message to be multibyte to avoid the appearance of our old friend \201 when the buffer contents are inserted into the composition buffer. (FSF Emacs 20 only). * vm-do-folders-summary: count messages in folders that lack entries in the folders summary database using vm-grep-program. * vm-do-folders-summary: ignore index files in the folder directories. * vm-update-folders-summary-highlight: use intern-soft instead of intern, since the symbol may not be present in the obarray. * vm-mark-for-folders-summary-update: check for killed summary before selecting folders summary buffer. * vm-emit-eom-blurb: bind vm-summary-uninteresting-senders-arrow to "" around call to vm-summary-sprintf. * Makefile: Start using $(prefix) to be more GNUish. Try to create the installation directories if they don't exist. * vm-modify-folder-totals: wrong cells in the list were being updated; fixed. * vm-mime-run-display-function-at-point: return result of calling the display function because callers expect it. This wasn't happening in the FSF Emacs part of the conditional. VM 6.88 released (11 December 2000) * New variables: + vm-folders-summary-mode-hook + vm-grep-program + vm-mmosaic-program + vm-mmosaic-program-switches * vm-determine-proper-charset: don't use MULE rules if operating in a unibyte buffer. The non-MULE rules work better in that case. Dropped use of vm-with-multibyte-buffer. * use BODY.PEEK instead of RFC822.PEEK in IMAP message fetches, since RFC822.PEEK has been made obsolete in RFC 2060. * not decoding for preview if vm-preview-lines == 0 was a mistake, as the header might still need decoding, so this change was reversed. * allow 8-bit chars in IMAP atoms. Microsoft Exchange emits them, resistance is futile. * keep IMAP trace buffer if a protocol error occurs. Code for this was partially done, it's finished now. * improved folders summary, new folders summary format specifier %s. * vm-move-to-xxxx-button: fixed code assumption that buttons were contiguous. * qp-encode.c: get rid of non-constant initializers (nextc = getchar()) to avoid warnings from Sun's compiler. * vm-toolbar-fsfemacs-install-toolbar: "mime" now works in vm-use-toolbar under FSF Emacs. * don't display verbose "Waiting for POP QUIT" message unless getting mail interactively. * make vm-thread-loop-obarray a larger hash table. * use vm-global-block-new-mail to prevent async reentrance into the POP and IMAP code. Use vm-block-new-mail to prevent command-level mail retrieval buffer locally. * vm-check-mail-itimer-function: always check for mail. Now that we're updating the folders summary we need to do the check even if we know there is new mail from a previous check, so that the summary is kept up to date. * removed Mule menu from VM's commandeered menubar (FSF Emacs 20 only). * C-c C-p in composition buffer binding changed from vm-mime-preview-composition to vm-preview-composition. * vm-sort-messages: fixed paren problem that broke non-thread sorting while threading was enabled. * vm-assimilate-new-messages: don't run vm-arrived-message-hook and vm-arrived-messages-hook if being called for the first time in this folder. Old check for this didn't work properly, so now first-time status is passed in as a parameter. * vm-emit-eom-blurb: use vm-summary-sprintf on full name so that it is MIME decoded if necessary. * vm-check-for-spooled-mail: don't skip remaining spool files once we know there is mail waiting. We still need to retrieve data for the remaining folders for the folders summary. VM 6.87 released (29 November 2000) * New commands: + vm-delete-duplicate-messages * vm-toolbar-fsfemacs-install-toolbar: fix logic reversal that caused Emacs 21 toolbar to never be installed. * reviewed coding-system-for-{read,write} usage everywhere and brought it into line with current theory of how Emacs/MULE works. coding-system-for-write is bound in more places because in the Emacs 21.0.91 pretest, write-region, even when called non-interactively, will query the user if it doesn't think the buffer's coding system can be used to safely write out the data. * vm-mail-to-mailto-url: vm-url-decode -> vm-url-decode-string. * vm-move-to-xxxx-button: next-etent-change -> next-extent-change. * vm-move-to-xxxx-button: dropped point movement outside the loop as it wasn't needed and actually broke things. * vm-add-or-delete-message-labels: don't cycle through the message list if there are no labels to act upon. * vm-add-or-delete-message-labels: return a list of labels that were rejected because they are not known. vm-add-existing-message-labels expects this and it apparently hasn't been done in a long time. * call base64-encode-region and base64-decode-region only if they are subrs. * vm-check-for-spooled-mail: save-excursion around the guts of the let form that binds vm-block-new-mail to avoid the restore-the-wrong-local-variable bug. * vm-get-spooled-mail: save-excursion around the guts of the let form that binds vm-block-new-mail to avoid the restore-the-wrong-local-variable bug. * vm-determine-proper-content-transfer-encoding: changed search for non-ASCII chars from [\200-\377] to [^\000-\177] because FSF Emacs 20 re-search-forward does not match 0200-0377 unibyte chars in multibyte buffers. They only match in unibyte buffers. * vm-unbury-buffer: wrapped call to switch-to-buffer in condition-case in case it fails (dedicated window, minibuffer window) VM 6.86 released (26 November 2000) * New variables: + vm-pop-read-quit-response (default value is t) * reversed coding system changes introduced in VM 6.85 in vm-line-ending-coding-system and vm-binary-coding-system, as they were wrong. * vm-minibuffer-complete-word: use minibuffer-prompt-end function to determine where the prompt ends instead of previous-property-change. * vm-toolbar-fsfemacs-install-toolbar: use xbm images if the display is not color-capable. * vm-toolbar-fsfemacs-install-toolbar: don't use "mime-colorful" as a basename when looking for an XBM for a non-color display. * vm-toolbar-make-fsfemacs-toolbar-image-spec: use ":mask heuristic" to make the toolbar pixmap/bitmap backgrounds track the background of the tool-bar face. * vm-mime-base64-encode-region: when using base64-encode-region wrap it in a condition-case to catch errors and resignal all errors with vm-mime-error. * vm-mime-base64-decode-region: when using base64-decode-region wrap it in a condition-case to catch errors and resignal all errors with vm-mime-error. * getmail-xx.xbm was a PBM file. No one noticed. Fixed. * check for vm-fsfemacs-p before using overlay-put, overlay-get, etc. in the extent/overlay compatibility functions. We can't use the overlay emulation package's functions because VM needs the functions to be able to handle plain extents also. * vm-mime-fsfemacs-encode-composition: catch the "Invalid search bound (wrong side of point)" error that font-lock can throw and ignore it. * vm-set-window-configuration: delete windows that are over explicitly named buffers. This is meant as an aid to BBDB users who might want to include a BBDB window in a configuration but don't want the window to appear unless the displayed buffer is non-empty. * install the toolbar only once under FSF Emacs, since it will appear everywhere vm-mode-map is used thereafter. * panic buffoon's color changed from rgb:ff/7f/ff to rgb:e1/92/46 (tan). VM 6.85 released (23 November 2000) * New commands: + vm-move-to-previous-button + vm-move-to-next-button * vm-end-of-message, vm-beginning-of-message: wrap vm-save-buffer-excursion around the part of the function that does window selection since that can change the current buffer. vm-narrow-to-page was noticing the buffer change to the summary; vm-message-pointer was suddenly nil. * made vm-create-virtual-folder, and by effect its callers, honor vm-next-command-uses-marks. * vm-apply-virtual-folder: honor vm-next-command-uses-marks. * added no-suggested-filename arg to vm-mime-attach-file and vm-mime-attach-object. * vm-preview-current-message: don't decode for preview unless vm-preview-lines is non-nil, as this is extra unnecessary work. * vm-pop-end-session: read POP QUIT response; Microsoft Exchange apparently will sometimes not expunge if we close the connection without reading the response. * set reasonable default value for vm-folders-summary-directories. * vm-preview-current-message: don't block display of any type other than message/external-body and externally displayed types when supporting vm-mime-decode-for-preview. * internal image support for v21 Emacs. * toolbar support for v21 Emacs. * Makefile: for 'make autoload' compile vm.el into vm.elc instead of writing require statements directly into it, otherwise Emacs 21 bitches. * vm-binary-coding-system was returning no-conversion under FSF Emacs, which is wrong--- it now returns raw-text. * vm-minibuffer-complete-word: In Emacs 21, during a minibuffer read the minibuffer contains the prompt as buffer text and that text is read only. So we can no longer assume that (point-min) is where the user-entered text starts so we must compute this location. Calling previous-property-change is a kludge but it seems to be the only thing that does the job. * vm-mime-display-internal-message/external-body: for Emacs 21, use a multibyte work buffer, otherwise the evil \201s appear in the tempfile and utterly corrupt it. Also set buffer-file-coding-system in the work buffer, since write-region may be called in it later. * dropped use of vm-with-unibyte-buffer. I don't think it is needed any longer. * vm-assimilate-new-messages: only run vm-arrived-messages-hook if a new message has arrived. * use a normal keymap instead of a sparse keymap for vm-mode-map. VM 6.84 released (15 November 2000) * vm-submit-bug-report: mail-user-agent should be a symbol not a list--- fixed. * vm-keep-some-buffers: kill a buffer even if it is modified if it's value of buffer-offer-save is nil. * vm-pop-make-session: if APOP authentication fails, remove the saved password just like we do for PASS authentication. * new variable and function vm-xemacs-file-coding-p tells whether XEmacs was compiled with --with-file-coding=yes, which means several things need to be treated the same as if MULE were enabled. * when deciding whether to call set-buffer-file-coding-system just check fboundp instead of xemacs-mule-p or fsfemacs-mule-p. This should help XEmacs-NT+file-coding. VM 6.83 released (14 November 2000) * New variables: + vm-page-continuation-glyph + vm-folders-summary-database + vm-folders-summary-directories + vm-folders-summary-format + vm-frame-per-folders-summary * New commands: + vm-folders-summarize * Makefile: moved vm-version.el to the beginning of the SOURCES list so that "make debug" doesn't crash on unbound variables. * vm-narrow-to-page: move to beginning of line only if we're not at end of buffer. If we're at end of buffer, it usually means forward-page failed to find a page delimiter and crashed into point-max. * vm-scroll-forward: after calling vm-narrow-to-page move to either the new window start or the start of the text section of the message, whichever is the greater buffer position. This fixes the semi-broken backward paging over page delimiters and fixed the broken forward scrolling over page delimiters after scrolling backward through the same message. * vm-narrow-to-page: use overlay/extent to display a "...more..." type string at the end of a page. * vm-scroll-forward: do (sit-for 0) to refresh display early so that the end of message notice appears when it should when scrolling over page delimiters. * vm-mime-display-internal-text/html: insert placeholder character before end marker before calling w3-region to avoid end == start marker squashing problem. * vm-submit-bug-report: reporter-submit-bug-report apparently dropped support for the variable reporter-mailer in favor of using mail-user-agent instead. Bind this variable as well the old one so bug reporters can send attachments. * vm: don't decode MIME if recover-file is likely to happen, since recover-file does not work in a presentation buffer. * vm-mail-to-mailto-url: decode URL before handing it to vm-mail-internal. * vm-mime-compile-format-1: removed code to decode and reencode MIME encoded words, since these aren't needed in MIME button format tags. * give up on disabling font-lock around attachments. font-lock users will just have to lose, because I don't see a clean way to do it. Removed futile atemptes from code. * vm-preview-current-message: don't MIME decode for preview if vm-preview-lines == 0 since it's pointless in that case. * vm-select-folder-buffer: make folder buffer selection mandatory, generate error otherwise. New function vm-select-folder-buffer-if-possible is to be used for situations where buffer selection is not mandatory. * moved vm-totals computation out of vm-emit-totals-blurb and into a separate function. * vm-expunge-folder: increment vm-modification-counter in the real folder buffers to invalidate vm-totals. VM 6.82 released (10 November 2000) * New variables: + vm-url-retrieval-methods + vm-wget-program + vm-lynx-program * access-type=url support added for message/external-body. * vm-visit-virtual-folder: call vm-fsfemacs-nonmule-display-8bit-chars. This needs to be done for the same reasons as it needs to be done in 'vm'. * provide keymap prompt for # and ## (XEmacs only, unfortunately). * vm-truncate-string: fixed to once again support a negative width argument, even if we're using char-width. * vm-mime-get-xxx-parameter: don't inadvertently truncate parameter value at newline. * vm-string-width: don't use Emacs 20's string width--- it ignores buffer-display-table and thereby hoses the summary. Using char-width on each character and summing the reuslt gives the answer we want. * vm-decode-coding-region: compute old region size based on the source buffer rather than the work buffer, since they might have different unibyte/multibyte status. * vm-decode-coding-region: reverse order of insert/delete sequence at the end to delete then insert. It fixes the parsing of this header From: "Cajsa Ottesj=?ISO-8859-1?B?9g==?=" Apparently if ö is inserted before \366 in a multibyte buffer, Emacs believes that the two characters are one character and moves point forward past the \366. This loses because the \366 needs to be deleted. * vm-flush-cached-data: stuff last-modified, pop-retrieved and imap-retrieved lists. * vm-pop-move-mail: if we retrieved something, call vm-stuff-pop-retrieved. * vm-imap-move-mail: if we retrieved something, call vm-stuff-imap-retrieved. * vm-mime-display-internal-text/html: pass charset name to vm-mime-charset-decode-region instead a layout. * vm-mime-display-internal-text/enriched: pass charset name to vm-mime-charset-decode-region instead a layout. * vm-menu-mime-dispose-menu: convert extent or overlay into a layout before using layout functions on it. * vm-mime-send-body-to-folder: put leading and trailiing message separators around the message in the temp folder. * vm-mime-send-body-to-folder: clear buffer-modified flag before entering vm-mode. * call the mime-reader-map save functions from the dispose menu instead of the low-level functions, so that vm-mime-delete-after-saving is honored. * vm-mime-can-display-internal: add 'deep' flag, which indicates whether to check the subobject of a message/external-body object. * vm-mime-display-internal-multipart/alternative: use the new 'deep' flag of vm-mime-can-display-internal. VM 6.81 released (7 November 2000) * vm-menu-mime-dispose-menu: take car of vm-mm-layout-type to get type. (oops) * vm-mime-display-internal-text/html: set end position after inserting the MIME body (oops). * vm-mime-display-internal-text/html: charset decode the body after inserting it. * vm-mime-display-internal-text/enriched: set end position after inserting the MIME body (oops). * vm-mime-display-internal-text/enriched: charset decode the body after inserting it. VM 6.80 released (6 November 2000) * vm-scroll-forward: set window start to point-min if we just exposed a hidden message window and we're transitioning frmo previewing to showing a message. This fixes the buggy window start marker drift caused by replacing unibyte chars with multibyte chars (typically with decode-coding-region). * vm-fsfemacs-nonmule-display-8bit-chars: dropped use of standard-display-european and its attendant disp-table.el in favor of directly creation and manipulation of display tables. * vm: call vm-fsfemacs-nonmule-display-8bit-chars to rectify 8-bit char width conflct between summary and folder buffers and to display undeclared 8-bit chars "properly" in the folder buffer. VM 6.79 released (5 November 2000) * vm-make-presentation-copy: force use of multibyte presentation buffer. Otherwise non-ASCII characters won't be displayed properly. (FSF Emacs 20 only). * vm-summarize: force use of multibyte summary buffer. (FSF Emacs 20 only). * vm-truncate-string: use char-width to determine a character's display width when truncating a string. * use vm-truncate-roman-string instead of vm-truncate-string in various places that don't encounter non-Roman strings. (For speed.) * create vm-string-width to compute width of strings that might contain glyphs with a column width > 1. Use this function in various summary formatting functions. * vm-assert: use let to bind debug-on-error to t instead of setting it permanently with setq. * turned on 8bit character character display in summary for non-Mule FSF Emacs. * vm-mime-charset-decode-region: add a face extent or a face text property to a charset decoded region so that non-MULE XEmacs and FSF Emacs can display non-ISO-8859-1 chars in the summary. VM 6.78 released (5 November 2000) * vm-save-message-sans-headers: if target file looks like a mail folder, ask the user if they really want to append to it. * vm-mime-base64-encode-region: when using Emacs' base64-encode-region break long lines unless doing B-encoding. * vm-mime-base64-encode-region: fixed indentation error that moved kill-buffer outside the unwind-protect form, which hosed the return value of the function. * vm-decode-coding-region: mend MULE mangled end marker by an explicit set-marker call, since nothing else seems to work. Make other functions use this fixed marker as a reference so that they don't forget where they are. * vm-decode-mime-encoded-words: (goto-char end) after calling vm-mime-charset-decode-region because decode-coding-region screws with point and otherwise we will miss encoded words because of this screwage. Same fix applied to vm-decode-mime-message-headers. * vm-mime-can-display-internal: indicate that we can handle message/external-body internally. * vm-mime-display-internal-message/external-body: deal with the possibility that the specified access method is unsupported--- cleanup properly and return nil. * vm-decode-mime-layout: deal with the possible failure of a message/external-body object to be retrieved. It needs to be treated differently than a local object. Offering to save it to disk is useless. Either display a button or prevent the existing button from being removed. * new 'x' specifier for vm-mime-button-format-alist. * vm-mime-display-internal-message/external-body: fixed reversed anon-ftp/ftp logic where the user name would be requested for anon-ftp and set to "anonymous" for normal FTP. * vm-mime-display-internal-message/external-body: check for ange-ftp-hook-function and efs-file-handler-function being fbound to determine if FTP support is available. * vm-mime-display-internal-message/external-body: catch vm-mime-error signals and store error message in display-error slot of layout for later display. * vm-preview-current-message: don't auto-display message/external-body when honoring vm-mime-decode-for-preview. * vm-mime-display-internal-text/plain: drop fancy calculations to rectify the end marker's position; vm-decode-coding-region now fixes the end marker's position before returning. * vm-mime-display-internal-text/html: drop fancy calculations to rectify the end marker's position; vm-decode-coding-region now fixes the end marker's position before returning. Hopefully w3-region won't scramble the marker position... we'll see. * vm-mime-display-internal-text/enriched: dropped use of vm-with-unibyte-buffer. * vm-decode-coding-region: use temp buffer for XEmacs also; generalize code to work for XEmacs and FSF Emacs. VM 6.77 released (2 November 2000) * changed keybinding of vm-expunge-folder from # to ### so that typing it accidentally is less likely. * '$ w' now does what '$ s' used to do, i.e. saves a MIME object to a file. * '$ s' now saves the MIME object to a mail folder if the object is a message, otherwise it behaves like '$ w'. * added support for MIME type message/external-body. * fixed duplicated menu titles in Emacs 20. * use built-in base64 encoding and decoding functions if present (FSF Emacs 20 only). * moved vm-mime-delete-after-saving support out of vm-mime-send-body-to-file and into vm-mime-reader-map-save-file. * make-autoloads: recognize defsubst. * some code changes to make it possible for the mime headers and body to be in different buffers. * vm-mime-find-message/partials: recursively descend composite message/* types. * vm-gobble-crash-box: check if folder buffer is the same as the crash box buffer--- if it is, signal an error. * vm-mime-fsfemacs-encode-composition: turn off font-lock when inserting an attached file into the composition buffer. Ditto in vm-mime-xemacs-encode-composition. * vm-pop-move-mail: ask user about lack of UIDL support, and skip folder if the user absolutely wants messages left on server. * use vm-make-work-buffer to create scratch buffers in many more places. * save-excursions -> save-excursion * vm-burst-digest-to-temp-folder: use buffer-disable-undo on the temp folder buffer. * vm-make-work-buffer: always create unibyte buffers. * vm-mime-Q-encode-region: translate SPC to underscore after quoted-printable encoding is done instead of before. * vm-mime-charset-decode-region: used a wrapped version of decode-coding-region (vm-decode-coding-region) if running under FSF Emacs. The wrapped version encodes into a unibyte buffer then converts the buffer to a multibyte buffer before insert the conrtents into the region. Encoding into a unibyte buffer avoid the \201 lossage. Switching to multibyte before inserting into the region avoids corrupting some markers. * vm-mime-display-external-generic: fixed typo that discarded the message garbage list and replaced it with the folder garbage list. The result is that MIME messages that invoke multiple object viewers will now kill all the viewers when selecting a new message. * vm-preview-current-message: restrict MIME types that are auto-displayed when honoring vm-mime-decode-for-preview. The reason for this restriction is to allow a numeric vm-preview-lines to remain useful in the face of opaque transfer encodings and multipart messages, so we avoid launching external viewers until the message is opened completely. * vm-toolbar-install-toolbar: check for reasonable value of vm-toolbar-pixmap-directory before calling vm-toolbar-initialize. * vm-toolbar-initialize: remove check of vm-toolbar-pixmap-directory, which is better done before vm-toolbar-initialize is called. VM 6.76 released (5 September 2000) * New variables: + vm-movemail-program-switches * generate a random Message-ID for previewed compositions in case the user wants to resend the preview somewhere. * vm-fix-my-summary!!!: call vm-set-modflag-of on each message whose summary we whack so that the summary cache is rewritten when the folder is saved. * vm-sort-messages: if this is not a thread sort and threading is enabled, then disable threading and make sure the whole summary is regenerated (to recalculate %I everywhere). * vm-mime-display-internal-image-xxxx: set glyph baseline to 100% to add scrolling in XEmacs 21.2. * vm-generate-index-file-validity-check: set step value to 1 if buffer size is smaller than 11 bytes. Step used to be 0 in this case which led to infloop. * added base64-encode.c, base64-decode.c, qp-encode.c, qp-decode.c to the distribution. * fixed problem in qp-decode.c where lines contain a single character followed by newline would have the first character dropped. * vm-display: allow a string as a buffer argument, convert it to a buffer internally. * vm-print-message: don't set the current buffer to be the shell output buffer, as this makes vm-set-window-configuration bail out early because it wants to be in a VM related buffer. * vm-pipe-message-to-command: don't set the current buffer to be the shell output buffer, as this makes vm-set-window-configuration bail out early because it wants to be in a VM related buffer. * vm-print-message: don't use vm-display to display the shell output buffer, use display-buffer instead and only use it if the output buffer is not empty. * vm-pipe-message-to-command: don't use vm-display to display the shell output buffer, use display-buffer instead and only use it if the output buffer is not empty. * vm-print-message: use the vm-print-message config instead of the vm-pipe-message-to-command config. * vm-display: don't immediately set current buffer to be the buffer to be displayed. This behavior made vm-set-window-configuration bail out early. * vm-discard-cached-data: call vm-garbage-collect-message before flushing message caches. * look for (fboundp 'w3-about) in addition to (fboundp 'w3-region) to determine if text/html can be displayed internally. * make after-save-hook local in VM folder buffers. * vm-get-new-mail: make third arg to read-file-name nil, make fourth arg t. * vm-compose-mail: move to point-min before searching for the header separator string. * Removed bad quote in vm-delete-mime-object menu entry. * vm-match-data: replaced with version that calls match-data to figure out the number of valid \(..\) groups. Emacs 20.4 is randomly signaling args-out-of-range if the arg to match-beginning exceed the number of internally allocated registers in the regexp engine or some such nonsense. * vm-frame-loop: in the last deletion check, also check the delete-me frame with vm-created-this-frame-p before deleting it. * vm-check-index-file-validity: allow for a nil modified time, which can occur if the folder is empty. * generalized vm-keep-mail-buffer into vm-keep-some-buffers and made the former call the latter. * keep POP and IMAP trace buffers if there is trouble making a connection. * complain to user if APOP authentication is asked for but isn't supported. Previously POP retrieval silently failed. * vm-reorder-message-headers: For babyl folders, add a newline before the EOOH line if header section does not end with two newline. * macroized most uses of coding system constants 'no-conversion and 'binary, because 'no-conversion doesn't meant the same thing in Emacs and XEmacs. * vm: if buffer-file-coding-system is nil, set it to 'raw-text. (FSF Emacs MULE only). * removed duplicate (make-variable-buffer-local 'vm-pop-retrieved-messages) * vm-parse-date: assume 2-digit year specifications < 70 are in the 2000's rather than the 1900's. * vm-mm-encoded-header: bind case-fold-search to t during search for encoded words. VM 6.75 released (27 August 1999) * New variables: + vm-mail-send-hook * vm-mime-parse-entity: when checking for a content type of just "text" allow for the possibility that there was no content-type header at all. * use XEmacs built-in MD5 support. * vm-pop-md5: use shell-file-name instead of "/bin/sh". * formatting and typo fixes in the manual and docstrings from will@fumblers.org. VM 6.74 released (2 August 1999) * New variables: + vm-mime-external-content-type-exceptions * vm-mime-parse-entity: quietly treat "text" as a content type as if it were "text/plain" and US-ASCII. * vm-mime-discard-layout-contents: set m to be the layout's message, not the end of the layout's body. VM 6.73 released (27 July 1999) * New variables: + vm-mime-decode-for-preview + vm-mime-delete-viewer-processes * vm-mime-display-external-generic: put MIME temp files on the message garbage list instead of the folder's garbage list. * vm-delete-mime-object: copied check for the top-level MIME object from FSF Emacs code to XEmacs code since the former is the correct check to use. * vm-mime-discard-layout-contents: discard cached byte and line counts of the edited message. * vm-sort-compare-thread: in the case where root message IDs are different, if the message dates are identical, use string-lessp on the message IDs to break the tie. This avoids having different messages compare as equal, which makes the sort unstable. * vm-mime-discard-layout-contents: recompute Content-Length header if needed. * vm-mime-can-display-internal: consider all text types except text/html displayable if the character set is displayable. For text/html continue to require W3. VM 6.72 released (21 May 1999) * New commands: + vm-delete-mime-object * New variables + vm-mime-delete-after-saving + vm-mime-confirm-delete + vm-mime-default-face-charset-exceptions + vm-paragraph-fill-column + vm-imap-session-preauth-hook * removed old, bogus definition of vm-session-initialization from vm.folder.el * added w32 as another name for win32 as a window system type. (FSF Emacs only). * changed default value of vm-mime-default-face-charsets to include iso-8859-1 if running on a tty under FSF Emacs/Mule. * vm-mime-parse-entity: move binding of case-fold-search to a point after the set-buffer call to avoid having the binding overriden by a buffer-local value. * vm-mime-convert-undisplayable-layout: wrap call to vm-mm-layout message in a call to vm-mime-make-message-symbol; a symbol needs to be in the struct slot, not the raw message. * signal an error if mail-alias-file is set and the user is not the superuser. * broke the message ID creation code out of vm-mail-mode-insert-message-id-maybe. * vm-su-do-date: allow a RFC 822 regexp to match a timezone spec that lacks the leading plus or minus. * bind jka-compr-compression-info-list to nil in various place to avoid unwanted compression or decompression of data. * vm-mime-send-body-to-file: bind jka-compr-compression-info-list to nil instead of func-binding jka-compr-get-compression-info. * vm-sort-messages: call vm-build-thread-lists (new function) which calls vm-th-thread-list on each message in the folder. This generates keys that the thread sort needs before the sort happens instead of during it. Fixes thread sorting bugs. VM 6.71 released (8 April 1999) * vm-mime-display-internal-text/plain: get message struct from the MIME layout instead of from vm-message-pointer, since the latter is utterly the wrong place to find it in this context. Also, don't fill if no-highlighting is non-nil. * vm-add-or-delete-message-labels: propagate label additions in virtual folders to the global lists of the underlying real folders. * bind format-alist to nil around calls to insert-file-contents in MIME composition encoding functions. VM 6.70 released (21 March 1999) * New variables: + vm-fill-paragraphs-containing-long-lines * vm-mime-display-internal-text/html: moved the code that rmeoves read-only text properties into the vm-with-unibyte-buffer form. * vm-make-presentation-copy: bind inhibit-read-only before tryign to modify an existing presentation buffer. This is to avoid stumbling over read-only text properties. * vm-mime-insert-button: use 'append' instead of 'nconc' to add a keymap parent. (FSF Emacs only) This avoids modifying the child keymap and creating a circular keymap structure in a subsequent call. VM 6.69 released (16 March 1999) * moved code that sets vm-xemacs-p, vm-fsfemacs-p, etc. to vm-version.el. Moved other basic feature checking code to vm-version.el. * Makefile: make sure vm-version gets loaded first, so the version/feature checking code is run very early. Some of it is needed by other modules at load time. * added keymap for MIME buttons so you can display, save, pipe, print from a tty. * vm-mime-xemacs-encode-composition: use insert-file-contents instead of insert-file-contents-literally and see what breaks. This will allow EFS to work. * default value of vm-mime-default-face-charsets no longer contains "iso-8859-1" under FSF Emacs/Mule. 8-bit character display as octal codes in a unibyte buffer unless standard-display-europeans or equivalent is called, and we don't call this function under MULE. * vm-compose-mail: this function is a VM entry point so call vm-session-initialization. VM 6.68 released (25 February 1999) * put user specified Netscape switches before the -remote stuff in the arg list to Netscape. * vm-imap-retrieve-to-crashbox: use char-after instead of char-before since Emacs 19.34 doesn't have char-before. * use vm-coding-system-name instead of coding-system-name. fset vm-coding-system-name to coding-system-name if it exists, otherwise use symbol-name. FSF Emacs doesn't have a coding system object, so the name is the same as the coding system symbol's name. * vm-determine-proper-charset: wrap the guts of the function in a vm-with-multibyte-buffer form to ensure we're looking at characters instead of the raw encoding data when scanning for the character sets that are present. * vm-decode-mime-layout: support the old 'name' parameter when supporting vm-infer-mime-types. * vm-do-reply: don't match vm-subject-ignored-prefix against the subject to determine if we prepend vm-reply-subject-prefix to the subject or not. This reverts a change made in VM 6.47. * vm-mm-layout: call vm-mime-parse-entity-safe instead of vm-mime-parse-entity so that we get always get a layout back. This avoids a MIME part completely disappearing if we can't parse it. * vm-mime-parse-entity-safe: use type "error/error" for the layout returned if the MIME part can't be parsed. * vm-mime-qp-encode-region: hex encode _ and ? for Q encoding as required by RFC 2047. * vm-mime-send-body-to-file: Func-bind jka-compr-get-compression-info to 'ignore' to avoid double compression of saved MIME bodies that are already compressed. * vm-imap-make-session: quote (using IMAP quoting rules) login name and password that are sent as part of the LOGIN command. VM 6.67 released (7 February 1999) * vm-mime-parse-entity-safe: pass message and passing-message-only flag to vm-mime-parse-entity. * vm-mime-parse-entity: wrong number of fields in the last layout structure fixed. * make MIME transfer encoding/decoding work buffers unibyte to avoid corruption when characters are copied from them. (FSF Emacs only). * vm-mime-attach-message: store the message to attach in an unibyte buffer instead of a multibyte buffer. * vm-mime-fsfemacs-encode-composition: encode text regions using coding system selected from vm-mime-mule-coding-to-charset-alist instead of relying on buffer-file-coding-system to be set properly. * vm-mime-fsfemacs-encode-composition: when handling the attachment of a composite object, add MIME header section (if not already provided) before parsing and transfer encoding the object. vm-mime-xemacs-encode-composition similarly modified. VM 6.66 released (5 February 1999) * New variables: + vm-mime-qp-decoder-program + vm-mime-qp-decoder-switches + vm-mime-qp-encoder-program + vm-mime-qp-encoder-switches * set-file-coding-system -> set-buffer-file-coding-system. * vm-edit-message: force edit buffer to be unibyte (FSF Emacs only). * vm: force folder buffer to be unibyte (FSF Emacs only). * wrap parts of various MIME decoding and display functions in vm-with-unibyte-buffer so we can work with unwashed 8-bit data directly. (FSF Emacs only). * force some buffers we create to be unibyte buffers to avoid conflabulation of 8-bit data. (FSF Emacs only). * vm-find-trailing-message-separator: point still not moving backward all the times that it should be, so go back to ignoring the return value of vm-find-leading-message-separator and always moving backward. * vm-mail-mode-insert-message-id-maybe: use the hostname variable we so carefullly initialized, instead of just using (system-name). * vm-mime-base64-encode-region: if B encoding, strip newlines from the work buffer instead of the buffer region we're converting. * vm-mime-base64-encode-region: don't emit status message unless the region we're encoding is larger than 200 chars. * vm-mime-parse-entity: new fourth argument that tells the function whether to use the message argument for positional information or to just use it to struct in the message slot of the MIME layout struct. Same for vm-mime-parse-entity-safe. Use this new argument appropriately in various places so the message slot gets filled in more places. VM 6.65 released (29 January 1999) * New commands: + vm-mime-attach-buffer + vm-mime-attach-message * New variables: + vm-subject-significant-chars * changed vm-url-regexp to recognize file URLs. * vm-reencode-mime-encoded-words: fixed infloop problems by updating pos value to account for the insertion of the =?charset?B? stuff at the beginning of the newly encoded region. * big pile of typo fixes in the manual courtesy of Greg Shapiro. * changes for Emacs 20 Mule: recognize coding system names, bind coding-system-for-read and process-coding-system-alist to get binary I/O. * insert vm-digest-identifier-header-format header into digest message created in temp folders created to view multipart/digest. Needed to store link to parent message in MIME layout struct to make this happen. * vm-mime-attach-object: don't set 'mime-object property twice in the FSF Emacs code. * vm-so-sortable-subject: collapse consecutive whitespace chars to a single space after prefix/suffix processing. VM 6.64 released (17 January 1999) * vm-mail-mode-insert-message-id-maybe: (stringp 'mail-host-address) -> (stringp mail-host-address). * vm-imap-retrieve-to-crashbox: for From_-with-Content-Length and BellFrom_ folders, add a newline to the end of a message if the message lacks one. * vm-mime-display-internal-text/html: third arg to remove-text-properties changed to be a plist as the function requires. * new edition of the user manual. * updated README, new installation instructions for manual, mention Web site * vm-search18.el gone, vm-search19.el became vm-search.el. * vm-pop-make-session: switched to the trace buffer earlier in the function so that MULE coding system is set in correct buffer. Add connection status messages to trace buffer. * vm-imap-make-session: switched to the trace buffer earlier in the function so that MULE coding system is set in correct buffer. Added connection status messages to trace buffer. * vm-submit-bug-report: use 'vm-mail instead of 'mail for sending bug reports. Less confusing, and will work most of the time. VM 6.63 released (14 December 1998) * set selective-display to nil in various places in the code where write-region and call-process-region (which calls write-region) are called to avoid the CR -> LF translation. * vm-load-window-configurations: added bind of coding-system-for-read. * vm-store-window-configurations: removed binding of coding-system-for-read, moved coding-system-for-write binding to be ambient only during the write-region call. * removed all but one of the bindings of inhibit-read-only in the MIME code. * vm-mime-display-internal-text/html: Added a remove-text-properties call to remove read-only text properties. * vm-mime-attach-object: Don't allow attachment of object to a composition buffer that has already been encoded. * retain IMAP session trace buffer if a protocol error occurs. * removed vm-iamp-store-failed error definition since it was unused. * 'w' summary format specifier now gives full weekday name. * vm-mail-mode-insert-message-id-maybe: ensure RFC 822 compliant month and day name by indexing the names from an alist instead of relying on format-time-string. format-time-string's output can't be trusted for this because of the dubious `locale' stuff in the C library. * for non-Content-Length based From_ types, don't require a year >= A.D. 1000 at the end of the From line--- instead only require a single digit. This change to deal with some evil mailer that puts a numeric timezone at the end of the line. * vm-make-presentation-buffer: remove buffer local foreground and background colors set in the default face in the presentation buffer. * dropped the Videodrome joke from vm-submit-bug-report. * vm-mime-fsfemacs-encode-composition: bind file-name-buffer-file-type-alist so that a bit-for-bit binary file read is assured. This matters only to NTEmacs. * vm-mouse-send-url-to-netscape: Netscape 4.05 apparently doesn't like the space after the comma in openURL(..., new-window) and doesn't create a new window. So the space has been removed. * read per-folder IMAP retrieved list at startup... forgot to add code to do this. * accept lower-case hex digits in quoted-printable encoding. * vm-mime-composite-type-p: assume message/rfc822 and message/news are the only composite "message" types. New ones will have to be manually added. * vm-misc.el: moved macros to vm-macro.el. * Makefile: Preload vm-macro.el instead of vm-misc.el. VM 6.62 released (9 September 1998) * vm-mouse-send-url-to-netscape: Change commas to %2C to avoid confusing Netscape -remote. * vm-mime-display-external-generic: when searching for %f, ignore %%f. * vm-decode-mime-layoout: drop rule that causes unmatched text/* and message/* MIME objects to be displayed as text plain. * vm-mime-can-display-internal: don't load W3 just to see if w3-region gets bound. If the user wants to view inline HTML, they'll have to either load W3 explicitly or set up an autoload for w3-region. VM 6.61 released (17 August 1998) * vm-find-trailing-message-separator: point wasn't being moved backward when it should be. Change check to use the return value of vm-find-leading-message-separator. * vm-build-message-list: add the starting position of the garbage to the garbage warning. VM 6.60 released (17 August 1998) * don't use gray75 to initialize gui-button-face under Windows (FSF Emacs only). Use only primary colors instead. * vm-find-trailing-message-separator: for From_ folders, don't move point backward one char after finding the leading separator unless that char is a newline. * vm-skip-past-trailing-message-separator: for From_ folders don't move point forward one character unless we're not at end of buffer. * vm-submit-bug-report: require vm-vars and vm-version modules. * vm-visit-folder-other-frame: call vm-session-initialization even if the command is not called interactively. VM 6.59 released (24 July 1998) * New variables: + vm-default-From_-folder-type * new folder type: BellFrom_. * vm-mime-display-internal-multipart/alternative: call vm-mime-should-display-internal with two arguments, as required, instead of one. * vm-munge-message-separators: if folder type arg is From_, use BellFrom_ as type to produce folders that are less likely to be misparsed by other mailers. * quoted vm variables in docstrings in vm-vars.el with ` and ' for hyper-apropos. Change previous other uses of `foo' to ``foo''. VM 6.58 released (21 July 1998) * fixed typo in vm-mime-fsfemacs-encode-composition; e -> o. VM 6.57 released (21 July 1998) * added a defvar for timer-list in vm-folder.el. * added defvars for standard-display-table, buffer-display-table and buffer-file-type in vm-mime.el. * added a defvar for mail-personal-alias-file in vm-reply.el. * added defvars for lpr-command and lpr-switches. * rewrote text/html inline display function to not need a temp buffer, save-excursion, and save-restriction. Needed because w3-region puts markers into the buffer that can't be copied out. * don't auto-create text body attachments that contain all whitespace if the attachment will be at the beginning or end of the composition. * vm-imap-retrieve-to-crashbox: munge folder message separators so the retrieved messages will be parsed correctly in the target folder. * vm-do-reply: don't use contents of In-Reply-To in generated References header unless no References header is present. * if vm-mime-alternative-select-method is best-internal, consider a MIME object only if the user wants it displayed internally, not just if it can be displayed internally. VM 6.56 released (14 July 1998) * vm-get-spooled-mail: set the non-file maildrop flag on each pass though the loop. * vm-get-spool-mail: restore expand-file-name call on the maildrop so that tildes get expanded. * store/use the same password for IMAP mailboxes on the same host. * removed greeting block on Cyrus server. * Shapiro typo fixes. VM 6.55 released (13 July 1998) * vm-mail-mode-insert-message-id-maybe: check mail-host-address with stringp instead of boundp before using its value. * vm-rfc1153-or-rfc934-burst-message: do digest separator unstuffing on a per message basis and before message separator munging, so that message separators exposed by the unstuffing get munged. * registered vm-imap-protocol-error as a known error/exception. Use it. * vm-check-for-spooled-mail: check spool filename against the IMAP template before checking against the POP template, since the POP template will match both. * vm-imap-check-mail: bail early if message count in mailbox is zero. VM 6.54 released (13 July 1998) * first crack at IMAP support. * New commands: + vm-expunge-imap-messages * New variables: + vm-recognize-imap-maildrops + vm-imap-auto-expunge-alist + vm-imap-bytes-per-session + vm-imap-expunge-after-retrieving + vm-imap-max-message-size + vm-imap-messages-per-session * use vm-check-for-killed-folder before calling vm-select-folder-buffer in a few functions that don't necessarily need to select the folder buffer in order to run. * vm-goto-message bound to M-g. * vm-find-leading-message-separator: for From_ type folders require that end of the leading separator line match " [1-9][0-9][0-9][0-9]". Revisit in eight thousand years. * rename vm-sprintf to vm-summary-sprintf. Use alists to store compiled formats instead of using symbol property lists. * vm-mime-xemacs-encode-composition: discard all but Content-ID header in already MIME'd objects to avoid header duplication. Same for vm-mime-fsfemacs-encode-composition. * vm-mime-display-internal-text/html: If error signaled, catch it, store the error message and return nil. * more descriptive buffer name for header buffer used when asking about POP retrievals. * vm-mail-mode-insert-message-id-maybe: try harder to find a hostname that has dots in it for the Message-ID header. * made vm-pop-retrieved-messages a buffer-local variable, as the table isn't meant to be shared among folders. * vm-expunge-pop-messages: use password-less maildrop specs when doing comparisons in skip code. Changed catch tag from 'skip to 'replay to more accurately reflect what's happening. * vm-pop-end-session: delete the trace buffer. * vm-pop-make-session: generate a new buffer for each session instead of reusing the same one. * vm-expunge-pop-messages: set buffer-read-only to nil in trouble-alert buffer before trying to modify erase it. VM 6.53 released (29 June 1998) * vm-mf-default-action: needed car of vm-mm-layout-type to extract type string. * vm-mime-display-button-xxxx: don't display button unless there's a defined method for displaying the object. VM 6.52 released (28 June 1998) * New variables: + vm-auto-displayed-mime-content-type-exceptions + vm-mime-internal-content-type-exceptions * vm-find-leading-message-separator: for From_ type folders, reinstate requirement that there be two newlines before "From " message separators. * renamed vm-mime-should-display-external to vm-mime-can-display-internal. * added big5 to vm-mime-mule-charset-to-coding-alist * default value of vm-send-using-mime to always be t instead of looking to see if the TM mime-setup feature is present. * added a newline to the 'end' line of a uuencoded attachment if there isn't one already; this to cope with the usual crocked PC mail readers (may they reek). * vm-mime-text-description: further identify a text part if it has a standard signature in it. * remove TM hooks from mail mode buffers if vm-send-using-mime is non-nil. * vm-mime-send-body-to-file: if user enters a directory name, use it unconditionally. * panic buffoon's color changed from rgb:00/df/ff to rgb:ff/7f/ff. * use user-mail-address function in Bcc header (XEmacs only). * use user-mail-address variable, if bound in, Bcc headers. * replaced definition of vm-load-init-file in vm-startup.el with the one from vm-folder.el. * use vm-mime-default-action-string-alist only if VM knows how to display the MIME object. Fiddle with the strings in the list. * support foregroundToolBarColor symbol in the 'small' set of toolbar pixmaps (XEmacs only). VM 6.51 released (15 June 1998) * don't call make-face if no face support is compiled into Emacs (FSF Emacs only). * enable inline display of text/html again. * vm-mime-text-type-p: anchor string matches and add a trailing / to assure matching only the correct types. * more fiddling with newlines around the Content-Description header, hopefully getting it right this time. * correct "Display as Text" MIME menu item. * vm-mime-charset-internally-displayable-p: check vm-mime-mule-charset-to-coding-alist if vm-fsfemacs-mule-p is non-nil. VM 6.50 released (10 June 1998) * vm-rename-current-mail-buffer: changed to recognize new default composition buffer name introduced in 6.49. * vm-mime-display-external-generic: append filename when supporting COMMAND-LINE form. Copy program-list since we may need to modify it. * vm-discard-cached-data: set mime layout and mime encoded header slots to nil in virtual messages. * vm-session-initialization: initialize gui-button-face if not already initialized (FSF Emacs only). * vm-pop-move-mail: check vm-pop-auto-expunge-alist properly; defaulting did not work as you would expect. * enable image and multiple font support for Windows (XEmacs only). * provide Content-Description headers for text surrounding MIME attachments in compositions. * vm-forward-message: provide Content-Description header for a MIME forwarded message. * use same filename extension as that of the suggested attachment filename when creating a tempfile for use by an external MIME viewer. VM 6.49 released (4 June 1998) * New variables: + vm-infer-mime-types * vm-pop-check-mail: return nil if UIDL returns an empty list. * vm-mail-internal: default composition buffer name to "mail to ?" instead of "*VM-mail*". * added '$' to regexps in default value of vm-mime-attachment-auto-type-alist. * new semantics for vm-mime-external-content-types-alist: %-spec expansion, shell command line syntax allowed. * default value of vm-auto-decode-mime-messages changed from nil to t. VM 6.48 released (1 June 1998) * New variables: + vm-spooled-mail-waiting-hook + vm-mime-uuencode-decoder-program + vm-mime-uuencode-decoder-switches * vm-delete-index-file: don't try to delete the file if vm-index-file-suffix is not a string. * show completions if completion-auto-help is non-nil. Needed to replace car with caar in one place in vm-minibuffer-complete-word. * vm-startup-with-summary: handle 0 case specially so that a negative number is not passed to nth. * make vm-mime-preview-composition an alias for vm-preview-composition, fixing the typo that aliased vm-preview-mime-composition instead. * vm-auto-archive-messages: don't archive messages to the same folder that the user is visiting. * vm-mime-fsfemacs-encode-composition: encode last MIME part from point to point-max instead of point-min to point-max. (FSF Emacs/MULE only.) * fixed regexp syntax for backslashes in [..] contexts. Need four backslahses for every one to appear in the regexp. * vm-discard-cached-data: set the mime-encoded-header-flag to nil. * vm-mime-burst-message: reverse varref and funcall in `or' expression to avoid skipping the rest of the vm-mime-burst-layout calls after the first successful one. * vm-check-pop-mail: use UIDL data to determine if messages in the popdrop have been retrieved. * vm-get-spooled-mail: always set vm-spooled-mail-waiting to nil after doing a sweep through the spool files, whether mail was retrieved or not. Not really correct but it is what the user expects. VM 6.47 released (8 April 1998) * vm-write-string: bind buffer-read-only to nil before attempting to modify the buffer. * vm-auto-select-folder: Do the eval if the cdr of the alist pair is anything other than a string, instead of it it is anything other than an atom. * vm-do-reply: match vm-subject-ignored-prefix against the subject and don't prepend vm-reply-subject-prefix if there is a prefix match. * vm-buffer-to-label: map presentation buffers to the 'message label. * vm-scroll-forward: raise and select frame before setting window configuration. * vm-frame-totally-visible-p: Consider frame totally visible if return value of frame-visible-p is not equal to nil or 'hidden. * dropped `sender' synonym virtual selectors. * If prefix arg is given to vm-visit-virtual-folder-* commands, say "read only" in the prompt string. VM 6.46 released (30 March 1998) * don't clear Message-ID and Date headers after sending the message. VM 6.45 released (29 March 1998) * New variables: + vm-mail-header-insert-date + vm-mail-header-insert-message-id * insert Message-ID header when message is sent, instead of when the composition buffer is initialized. Remove any existing Message-ID header before inserting. * remove any existing Date header before inserting a new one. * vm-discard-cached-data: thread sort folders that need it one time instead of once for each message that has data discarded. * vm-vs-not: use vm-with-virtual-selector-variables. * vm-toolbar-mail-waiting-p: return t if vm-mail-check-interval is not a number, since we can't determine if mail is waiting. * drop extra space before single digit day numbers in Date headers that are inserted into compositions. * vm-edit-message: use set-keymap-parent to allow fallback to the major mode keymap after searching vm-edit-message-map. * vm-emit-eom-blurb: display information about recipients if sender matches vm-summary-uninteresting-senders. * use define-mail-user-agent to setup vm-user-agent. * vm-create-virtual-folder-same-subject: match subjects with ^$ regexp if subject is empty. * vm-create-virtual-folder-same-author: match authors with ^$ regexp if author is empty (probably not needed). * vm-build-virtual-message-list: when updating the virtual message list of the real message, copy list of virtual messages from real message instead of a virtual and potentially unmirrored message. VM 6.44 released (24 February 1998) * vm-resend-bounced-message: insert Resent-To header near the top of the composition instead of near the bottom. * provide second argument to format-time-string for older versions of XEmacs that require it. VM 6.43 released (18 February 1998) * only use char-to-int if defined, use identity function otherwise. * 0 prepended to field width means to pad with zeroes instead of spaces in vm-summary-format and vm-mime-button-format-alist. * recognize %T in MIME button format specs. * vm-mime-find-format-for-layout: fixed typo in fallback format * always save the POP password in vm-pop-passwords, even if it is listed in vm-spool-files. This is for the sake of vm-expunge-pop-messages which typically deals with password-less POP specifications. * use 'highlight extent property for summary mouse tracking, instead of mode-motion-hook. Seems to display considerably faster. (XEmacs only). * reuse summary mouse tracking extents/overlays instead of constantly making new ones. * removed autoload cookies from vm-easymenu functions. * vm-mail-internal: add a Message-ID header. * vm-mail-send: add a Date header if not already present. VM 6.42 released (16 February 1998) * New variables: + vm-pop-expunge-after-retrieving + vm-pop-auto-expunge-alist + vm-mime-button-format-alist * vm-save-message: don't set vm-last-save-folder if it is non-nil and the user selected folder matches what vm-auto-folder-alist would have chosen. Tried to do this in 6.41, but broke the setting of vm-last-save-folder instead. * vm-expunge-pop-messages: typo prngn -> progn. * vm-expunge-pop-messages: check whether vm-make-pop-session returns nil. * vm-read-attributes: allow header without a label list. The label part of the data in the header was added later and may not be in the header of some older folders. * dropped use of vm-with-virtual-selector-variables in favor of using an alist. VM 6.41 released (11 February 1998) * New variables: + vm-index-file-suffix * New commands: + vm-expunge-pop-messages * default value of vm-circular-folders changed from 0 to nil. * don't issue DELE commands on POP messages when retrieving unless POP server doesn't support UIDL. If server supports UIDL, remember what messages have been retrieved and avoid retrieving them later. * vm-save-message: don't set vm-last-save-folder if it is non-nil and the user selected folder matches what vm-auto-folder-alist would have chosen. * vm-show-list: sort list before displaying it. * vm-show-list: display list ordered top to bottom then left to right, instead of left to right and then top to bottom. * bind print-length to nil in some places to avoid truncation of Lisp Objects in folder headers. * vm-mime-encapsulate-messages: use vm-insert-region-from-buffer so we're sure to do buffer switch and unnarrowing necessary to retrieve the desired buffer contents. VM 6.40 released (30 January 1998) * New variables: + vm-mime-7bit-composition-charset * don't grey-out "Decode MIME" toolbar button after a message is first decoded. Let user use the button to rotate through decoding states like the 'D' key does. This applies only to the separate MIME button, not the one that appears as part of the `helper' button. * vm-mark-or-unmark-messages-with-selector: removed extra count argument from `message' call. * vm-build-virtual-message-list: if dont-finalize is set, don't set up the location vector or to obarray used to suppress duplicate messages. In particular the latter causing empty message lists to be returned since all the messages were considered duplicates. * support foregroundToolBarColor symbol in toolbar pixmaps (XEmacs only). * vm-rfc1153-or-rfc934-burst-message: Use current buffer as folder buffer, instead of the buffer of specified message. * vm-get-new-mail: signal error if we fail to find a folder buffer through the normal means. * sleep for 2 seconds instead of 1 second after "consider M-x revert-buffer" message and after a quit is signaled and caught in vm-get-spooled-mail. VM 6.39 released (20 January 1998) * New commands: + vm-burst-digest-to-temp-folder + vm-add-existing-message-labels * vm-vs-header-or-text: vm-header-of -> vm-headers-of. * fixed reversed fset definition of vm-vs-sender. * don't grey-out "Decode MIME" menu entry after a message is first decoded. Let user use menu entry to rotate through decoding states like the 'D' key does. * vm-check-emacs-version: Disallow running under Emacs 20. * vm-mime-display-internal-multipart/digest: generate summary if vm-startup-with-summary says so. Did the same for vm-mime-display-internal-message/partial and vm-mime-display-internal-message/rfc822. * default vm-temp-directory to (getenv "TMPDIR") if result is non-nil. * vm-undo: signal an error if the current folder is read-only. * vm-minibuffer-complete-word: set start of word to beginning of buffers if not doing a multi-word read. * vm-minibuffer-complete-word: if doing multi-word completion and the word before point exactly matches something in the completion list and the word also prefixes something else in the completion list and last-command eq vm-minibuffer-complete-word, insert a space, thereby letting the user complete the word. * vm-mime-display-internal-text/enriched: Don't assume (car errdata) is a string; it usually isn't. Format error data properly. * vm-print-message: write out the tempfile for the non-MIME lobe of the conditional in the code, since it is needed there also. * vm-read-virtual-selector: raise the selected frame before reading from the minibuffer, so the user is less likely to type into the wrong minibuffer window and hose themselves. * vm-mime-fsfemacs-encode-composition: set coding-system-for-read when inserting a file-based attachment to avoid MULE munging. Protect value of buffer-file-coding-system from possible changes by insert-file-contents. VM 6.38 released (15 January 1998) * add vm-virtual-selector-clause property to new selectors. * vm-read-virtual-selector: removed hard coded list of selectors that take an arument. Instead, read arg only for selectors that have a vm-virtual-selector-arg-type property. * fixed virtual folder numbering/infloop problem introduced in 6.37. * vm-mark-or-unmark-messages-with-virtual-folder: Mark virtual messages instead of the underlying real messages when current folder is a virtual folder. VM 6.37 released (29 December 1997) * Folders menu code: create directories by default in vm-folder-directory. * added name parameter to vm-create-virtual-folder for use by vm-create-virtual-folder-same-author and vm-create-virtual-folder-same-subject to avoid regexp-quote goop in the modeline. * make sure the -should-delete-frame variables in vm-mouse.el are initialized before use. * vm-apply-virtual-folder bound to V X. * added virtual folder selectors for all the attributes that vm-set-message-attributes accepts. Added un- selectors so that simple negations can be used with V C. Added header-or-text selector. Added aliases for some selector names. * New commands: + vm-toggle-all-marks (bound to M V). + vm-mark-matching-messages-with-virtual-folder (bound to M X). + vm-unmark-matching-messages-with-virtual-folder (bound to M x). * vm-update-summary-and-mode-line: copy value of default-directory from folder buffer to the summary and presentation buffers. * report null results in mark commands as "No message marked" instead of "0 messages marked". VM 6.36 released (19 December 1997) * vm-yank-message: commented out text/html code. * added toolbar initialization status message (XEmacs only). * allow integers in the vm-use-toolbar toolbar specification, which represent blank space in the toolbar. (XEmacs only). * allow for the possibility that lpr-command and lpr-switches are unbound. * restore binding of C-? ; binding the delete keysym doesn't affect the delete key on a dumb terminal when running FSF Emacs. * changed semantics of vm-temp-file-directory. Its value now must end with the directory separator character used by the local operating system. * vm-mime-display-internal-text/enriched: catch errors in enriched-decode and store it in the MIME layout struct for future display. * New commands: + vm-create-virtual-folder-same-subject (bound to V S) + vm-create-virtual-folder-same-author (bound to V A) * vm-write-file: If write-file renames the folder buffer, rename the summary buffer and presentation buffer to match. * vm-mime-can-display-internal: don't assume enriched.el is shipped with Emacs. Assume text/enriched is internally displayable only if enriched-mode is fbound. * vm-mime-fragment-composition: supply the "total" parameter in all message/partial parts instead of just the last one. * only delete the frame used for completion if VM created it. * vm-fsfemacs-p: Don't insist on v19. VM 6.35 released (24 November 1997) * typo fixes * Gregory Neil Shapiro's Emacs 20 MULE patches, which inserted bindings for coding-system-for-read/write in various places. * renamed vm-fsfemacs-19-p to vm-fsfemacs-p. * Bound (control /) to vm-undo, bound backspace and delete keysyms to vm-scroll-backward, dropped binding of "\C-?". * added ;;;###autoload cookies to all VM entry points. * vm-session-initialization: require 'vm first to make sure the basic things are loaded before we try to do anything. * dropped inline support for text/html. Too much pain right now. Revisit later. * recognize po:user type spool file and peaceably hand it off to movemail. * vm-mode-internal: install new fucntion vm-unblock-new-mail on after-save-hook to allow retrieval of mail after a save of an M-x recover-file'd folder. * vm-pop-make-session: first argument to buffer-disable-undo is required under XEmacs 19.14, so provide it. * Use locate-data-directory if it exists when setting vm-image-directory. * vm-mail-internal: insert an extra newline before the inserted signature so the user doesn't have to type one. (I give.) * vm-mime-transfer-encode-layout: don't add a Content-Transfer-Encoding header unless the encoding type of the layout differs from what we require it to be. * vm-mime-transfer-encode-region: downcase the return value so string comparisons don't have to worry about case. QP encode if armor-dot is set. * vm-print-message: use a tempfile under Windows 95 or NT. Apparently the losing print utils there don't understand stdin or can't read from it. * vm-mime-text-type-p renamed to vm-mime-text-type-layout-p. The new version of vm-mime-text-type-p checks the type without a layout wrapped around it. * vm-mime-xemacs-encode-composition: For MULE, use binary coding system when inserting an attached file if the type of the attachment is not a textual MIME type. VM 6.34 released (15 September 1997) * vm: use other frame if folder is visible there. * vm-auto-archive-messages: don't silently block archival attempts to /dev/null; Emacs no longer complains about writes to /dev/null. * vm-toolbar-initialize: add line for 'getmail' button support that got omitted somehow. * vm-multiple-fonts-possible-p: added win32 as a window system that supports multiple fonts. VM 6.33 released (19 July 1997) * vm-undisplay-buffer: don't delete frames unless both vm-mutable-windows and pop-up-frames are not non-nil. Loop over the remaining windows that display the target buffer and make those windows display some other buffer. * vm-mime-set-extent-glyph-for-type: use a list of instantiators, use 'xpm instead of 'autodetect and fallback to [nothing] if instantiation fails. * vm-display-face: use the [nothing] instantiator on ttys. XEmcas only. * vm-toolbar-install-toolbar: change toolbar size specifier on frame even if VM did not create the frame. This reverses the change made in 6.32. * vm-isearch: call vm-energize-urls to light up the URLs after a search completes. * vm-set-window-configuration: return the window configuration we set. A change in 6.32 caused this not to be done. This confused vm-display which relied on the return value to determine whether vm-display-buffer needed to be called. * don't recognize as an URL if it contains a newline. * vm-scroll-backward: make argument optional. VM 6.32 released (30 May 1997) * vm-toolbar-install-toolbar: don't change toolbar size specifier on frame unless VM created the frame. * vm-mail-send: move attribute change before possible deletion of the buffer due to vm-keep-sent-messages == nil. * remove references to vm-record-current-window-configuration since it is not being used and will never be used. * vm-mouse-read-file-name-event-handler: don't delete the completion frame before reading keyboard input. This should avoid making the user hunt for the frame that contains the correct minibuffer window to type into. * default value of vm-mutable-frames changed to t, and the semantics of this variable have been changed to hopefully be more like what users expect it to be. * use cache slot of MIME layout struct as an alist everywhere to avoid having display functions confuse each other with their different cache entries. * vm-mime-display-internal-image-xxxx: use device tag lists to have a text tag displayed on ttys and the image itself on image-capable devices. * added optional `to' argument to vm-mail commands. * mouse support changed so that it is installed whenever mouse support may be possible instead of only if it is possible on the current device.. Significant only under XEmacs currently. * use multiple frames on ttys, where available. * vm-scroll-forward: don't scroll if we're auto decoding MIME and the message needed to be decoded. * vm-mail-internal: support mail-personal-alias-file, fall back to ~/.mailrc if it is nil. VM 6.31 released (11 May 1997) * vm-toolbar-support-possible-p: don't check device type, install toolbar if the 'toolbar feature is present. * vm-toolbar-initialize: check for device-on-window-system-p before looking at device-bitplanes, in case the selected device is a tty. * use '(win) tag sets on toolbar specifiers to prevent toolbars from being attached to non-window system frames. * vm-multiple-fonts-possible-p: conditionalize checks on XEmacs/Emacs to avoid looking at the window-system variable under XEmacs where it should not be used. * set scrollbar height only if (featurep 'scrollbar) and under XEmacs. Previously we checked if set-specifier was fbound. * vm-mime-preview-composition: copy value of enriched-mode to the temp buffer so that the MIME encoding code knows what to do. * set perms to 600 on MIME tempfiles before writing to them. There's still a race window where access can be gained to such files, but it should be very small assuming NFS is not involved. * added new 'display-error' slot to the MIME layout struct to avoid overloading the cache slot... and fixed a bug thereby, due to vm-mime-display-external-generic trying to use the contents of the cache slot when there was an error message there. * vm-mime-display-internal-message/rfc822: bind buffer-read-only to nil before trying to insert text into the presentation buffer. * vm-burst-digest will now descend into nested MIME layouts to find digests to burst. VM 6.30 released (28 April 1997) * vm-mail-send: rename and/or delete the composition buffer before trying to make the replied/forward/etc. attribute change, since the user might abort that action. E.g. "... really edit the buffer?" * changed code to use XEmacs 20.2 MULE variables and functions instead of the 20.0 functions. * treat inlined message/rfc822 like multipart/mixed except we also insert the forwarded headers message and decode any encoded words in them. * support enriched-mode in composition buffers. * replaced some repeated calls to car with varrefs. * vm-make-presentation-copy: bind inhibit-read-only to disable read-only text properties before calling erase-buffer. * vm-rfc1153-or-rfc934-burst-message: don't insert a trailing message separator if we're bursting the first message. * rewrote vm-menu-support-possible-p to not factor device type into its decision. For a multi-device XEmacs what is not possible now might be possible later, so let the menus be instantiated even if they aren't necessarily visible on the currently selected device. VM 6.29 released (23 April 1997) * default value of vm-honor-mime-content-disposition now nil. * disable the setting of stack-trace-on-error for now. * fixed a few places where MIME layout vectors were created with too many slots and one place with too few slots. * Makefile: doc fixes * Shapiro typo fixes. VM 6.28 released (22 April 1997) * added status messages for vm-mark-all-messages and vm-clear-all-marks. * vm-mime-set-extent-glyph-for-type: don't croak on unknown types. * vm-thread-mark-for-summary-update: when skipping already marked messages don't skip the part of the loop that moves the list pointer forward. :-P * rerun vm-menu-install-known-virtual-folders-menu after creating on-the-fly virtual folders because the folder menu gets hosed by the let-bound value of vm-virtual-folder-alist. * added hack to vm-mail-send-and-exit to try and improve window configuration behavior under XEmacs when vm-keep-sent-messages is nil. * vm-mime-composite-type-p: don't consider message/partial and message/external-body as a composite types. * fixed nested MIME encoding to check types recursively all the way down to make sure the 7bit/8bit rules are followed. * vm-forward-message: use message/rfc822 instead of multipart/digest. * vm-send-digest: fixed preamble insert for MIME digests to insert into the composition buffer instead of directly into the digest buffer. VM 6.27 released (16 April 1997) * vm-mime-rewrite-failed-button: add newline to displayed error string. * vm-menu-goto-event: use event-closest-point instead of event-point so that we get locality of point when a click occurs over a glyph (XEmacs only). * vm-mime-display-button-xxxx: say "attempt to display" instead of "display", as the button doesn't know if there is a functional display function for the type. * vm-mime-xemacs-encode-composition: dropped calls to encode-coding-region for now. They were screwing up marker positions. * vm-mime-xemacs-encode-composition: protect value of file-coding-system from changes when inserting attachment file contents. * vm-mime-display-internal-text/html: don't call w3-region if it isn't bound, just set error string and return nil. * vm-thread-mark-for-summary-update: don't mark if vm-thread-list-of slot is nil; use nil in this slot to mean we've already marked this message. VM 6.26 released (13 April 1997) * added missing application/octet-stream button display function. * Shapiro typo fixes VM 6.25 released (13 April 1997) * copied vm-note-emacs-version to vm-menu.el so that it is available at load time for use there. * converted mona stamps to XPMs as XEmacs can't display the GIF versions. * vm-mime-transfer-encode-layout: mark encoding in transfer encoded leaves, forgot this previously (oops). * default value of vm-mime-ignore-mime-version now t. * restored vm-xemacs-p, vm-xemacs-mule-p and vm-fsfemacs-19-p functions to avoid breaking third party code that rely on them being present (sigh). * dropped vm-mime-attach-mime-file from the vm-mail-mode keymap and menu. * vm-show-list: binding to button release events in XEmacs didn't work. Should probably use mouse-track hooks instead of binding keys but until we do that go back to binding button press events. * vm-mouse-get-mouse-track-string: check whether we're running Emacs/XEmacs rather than whether functions are defined to avoid using the wrong overlay/extent interface. * initialize mail-default-reply-to from REPLYTO environmental variable if value is nil (used to be if value is t). * vm: moved call to vm-preview-current-message after the summary generatation/display code. The summary might completely obscure the view of the message buffer, so previewing should occur after that so that vm-show-current-message knows whether the message was visible and therefore also knows whether to mark the message as read. * vm-keep-mail-buffer: don't kill a buffer if it marked as modified, even if the number of `kept' messages would be exceeeded by keeping it. Presumably if a buffer is modified the user has resumed composing in it and so we should not delete it. * added vm-mouse-send-url-to-netscape-new-window and vm-mouse-send-url-to-mosaic-new-window functions for use as values of vm-url-browser. * dropped use of vm-check-for-killed-folder in menubar and toolbar enabled-p functions. We wrap troublesome calls to vm-select-folder-buffer in (condition-case ...) now to avoid a "Folder has been killed" error from hosing the toolbar/mnunebar and XEmacs permanently. * don't use application/octet-stream's button function for all application subtypes. Added a separate function to be used for subtypes other than octet-stream. * vm-mime-attach-object: if type is nil, use text/plain as the type when calling vm-mime-set-extent-glyph-for-type. * don't fold content-disposition headers if vm-mime-avoid-folding-content-type is non-nil. * don't add an extra newline after the unfolded content-type of the last text subpart. * vm-mime-preview-composition: remove mail header separator after the message is encoded since the encoder won't work without it. VM 6.24 released (9 April 1997) * default value of vm-mime-avoid-folding-content-type now t due to pervasive broken Solaris sendmail installations that mangle the headers of messages with folded Content- headers. * vm-mime-make-multipart-boundary: shortened multipart boundaries to avoid long header lines when vm-mime-avoid-folding-content-type is t. * include the missing audio_stamp images in the distribution. * set version variables at startup and refer to them rather than calling vm-xemacs-p, etc. repeatedly. * vm-summary-highlight-region: overlays and extents aren't interchangable in this context, so behave based on Emacs/XEmacs version to avoid any overlay/extent emulations, and also to avoid having make-overlay's sudden appearance give us heartburn. * don't fset vm-extent-property, vm-make-extent, etc. unless they are undefined. This is to avoid changing their definition in the middle of an Emacs session and thereby mixing usage the overlay/extent interfaces. * vm-mime-set-extent-glyph-for-layout: fixed reversed colorfulness test. * vm-mime-set-extent-glyph-for-type: mona_stamp is a GIF not an XPM. * more overlay/extent interface cleanup. * reenabled internal text/html code. * vm-yank-message: decode text/html and text/enriched in the composition buffer. * attach image glyphs to attachment tags in composition buffers (XEmacs only). * print a warning and continue if x-vm- header seems corrupted. old behavior was to just croak an error and wedge the mailer. * vm-print-message: default count to 1 if passed no arguments. VM 6.23 released (4 April 1997) * default value of vm-honor-mime-content-disposition now t. * Makefile: default VM build type is now back to `autoload'. * vm-rfc1153-or-rfc934-burst-message: use point instead of (match-end 0) when deleting the message separator. * vm-rfc1153-or-rfc934-burst-message: trim excessive newlines only after we know that we are looking at a valid message separator. * vm-su-message-id: discard chaff preceding message ID. * vm-mime-fragment-composition: 'send -> '8bit to match documentation of vm-mime-8bit-text-transfer-encoding. * vm-mime-fragment-composition: call vm-add-mail-mode-header-separator at the end so the buffer could be sent again. * vm-mime-preview-composition: call vm-remove-mail-mode-header-separator. * avoid starting new timers if old timers are still active (FSF Emacs only). * vm-mime-encode-composition: split code into FSF Emacs and XEmacs functions. This should avoid mixing usage of the extent and overlay interfaces, which loses with Nuspl's overlay.el emulation. * default vm-temp-file-directory to C:\ if /tmp is not a directory and C:\ is. * use insert-file-contents instead of insert-file-contents-literally when inserting MIME attachments into compositions when encoding. insert-file-contents-literally bypasses CRLF -> LF processing under NTEmacs, apparently. * if vm-auto-displayed-mime-content-types or Content-Disposition says to display message/rfc822 or message/news inline and immediately display them as text/plain. If displaying them due to button activation, use a folder instead. * use different menu for mailto: URLs since the old one didn't really do what it advertised, i.e. didn't allow mailto URLs to be send to other browsers. * added reduced color MIME art for 8-bit displays that used to only be used with displays with 16-bit or better displays. * cache MIME art image glyphs for reuse to save load time. * wrap calls to timezone-make-date-sortable in (condition-case ...) to avoid crashing on bad dates. * gave up on using frame-totally-visible-p since it is still broken in 19.15. VM 6.22 released (22 March 1997) * vm-mime-encode-composition: insert-file-contents-literally doesn't move point. the code assumed it does and corrupted attachments as a result. * vm-gobble-crash-box: remove/rename crash box even if it is zero-length. VM 6.21 released (21 March 1997) * vm-save-folder: call clear-visited-file-modtime if folder was deleted to avoid "File changed on disk" warnings later. * vm-mime-qp-encode-region: bounds check (1+ inputpos) before using it to avoid referencing outside a clipping region. * vm-mime-encode-composition: do the insert/delete dance to avoid text leaking into overlays in the file insertion case. VM 6.20 released (18 March 1997) * vm-menu-support-possible-p: allow menu code to operate under NextStep. window-system == ns. * New variables: + vm-mosaic-program-switches + vm-netscape-program-switches + vm-mime-ignore-mime-version + vm-presentation-mode-hook (you were right, i was wrong) * vm-decode-mime-messages: run the highlighting code * vm-mime-display-internal-multipart/digest: copied folder display code from the message/rfc822 handler since they should work the same and message/rfc822 works properly with vm-mutable-windows == nil. * make gui-button-face be the unconditional default value for vm-mime-button-face. * vm-virtual-quit: make sure vm-message-pointer is non-nil before trying to run vm-message-id-number-of on it. * vm-howl-if-eom: don't search other frames for the buffer's window. Under XEmacs calling select-window on such a window causes its frame to be selected and it stays selected despite the call being wrapped in a save-window-excursion. I don't think we really want to report end of message status in a window in a non-selected frame anyway. * removed reference to user-mail-address variable, because it might be set to nil. * vm-show-list: bind command to mouse release events instead of mouse press events in XEmacs. * vm-preview-current-message: set vm-mime-decoded to nil; it is not enough to just let vm-make-presentation-copy do this. * use full contents of References headers to avoid holes in threads due to missing parent messages. * insert an X-Mailer in composition buffers. Music! Fun! Horoscopes! And bug tracking. * removed "Parsing MIME message..." status messages until I come up with a better way to write these status message only when we're doing something that might take a while. VM 6.19 released (8 March 1997) * New user data functions: + vm-user-composition-folder-buffer + vm-user-composition-real-folder-buffers * vm-print-message: make printing of MIME message work more like non-MIME messages; print visible headers, print tags for non-textual body parts. * vm-mime-insert-button: don't set keymap parent to be the current local map unless that map exists (i.e. is non-nil). * catch errors when decoding encoded words and substitute an error indicator for the string that we could not parse. * vm-set-xxxx-flag: don't set attribute flag until after the undo information is recorded. The buffer modification might be nixed by the user via the clash detection query, so we need to be sure we're past that code before committing to the attribute change. * vm-set-labels: same as vm-set-xxxx-flag and for same reason. VM 6.18 released (4 March 1997) * New variables: + vm-mime-composition-armor-from-lines * use Dispose menu as the mode menu in the presentation buffer. * vm-mime-encode-composition: do insert/delete dance to avoid inserting into attachment overlays. * vm-print-command now decodes the MIME message before printing. * vm-determine-proper-charset: use assoc instead of vm-string-assoc when searching MULE alists since symbosl are used tor charsets there. * added 'print' item to mime dispose menu. * vm-display: make buffer current buffer running vm-undisplay-buffer-hook. * vm-make-presentation-copy: don't set frame deletion hooks unless multiple frames are possible. * fixed bug where X-Faces were unrecognized if the X-Face header name used DiFfErEnT case than XEmacs' autodetect code expected. * returned to using the day's date as part of the saved crash box name used when vm-keep-crash-boxes is set. * somehow we didn't get scroll-in-place turned off in presentation buffers; done now. * added support for message/news type, which is handled mostly like message/rfc822. * new mime-dispose menu entries. * don't check again for new mail if we already know some is waiting. * add extended status reporting during POP message retrieval. * vm-get-spooled-mail: if we know we've already retrieved some mail, catch keyboard-quit from vm-spool-move-mail and vm-pop-move-mail, so crash box contents can be processed immediately after the quit. VM 6.17 released (27 February 1997) * vm-pop-read-past-dot-sentinel-line: use re-search-forward instead of search-forward (oops). * don't use match-string; it is a macro in XEmacs 19.14 and this makes byte compiled code that doesn't know this fact blow up under 19.14. * added content disposition popup menu on attachment tags. * don't use intangible text property on attachment tags (breaks menu code). * set zone-of message slot to "" if timezone missing from a Date header that looks like UNIX-ctime format. * avoid using the symbol name `obarray'. * treat consecutive rfc934 message boundaries as one boundary when bursting. * fixed boundary test in rfc934/rfc1153 digest bursting code to requires the headers only if not looking at the last boundary. should have been doing this already, but the boolean logic was wrong. * skip >From lines when reordering headers. * added assert statement to vm-mime-encode-composition to try to track the disappearing attachment bug. * vm-preview-current-message: unbury folder or presentation buffer depending on which one we use for the current message. This is a further effort to improve vm-mutable-windows == nil behavior. VM 6.16 released (25 February 1997) * check for vm-xemacs-mule-p before using file-coding-system and friends, and also strengthen the checks that vm-xemacs-mule-p does. * vm-mime-fake-attachment-overlays: don't use `pos' twice in a let statement. * still more coding system fiddling; use get-coding-system to normalize coding-system values before comparing with eq. * bind buffer-read-only to nil when encoding/decoding folder for MULE. * make timers go away if interval vars indicate this should be done, or if all vm-mode buffers are gone. * vm-run-command-on-region: bind binary-process-input for DOS/Windows. * vm-mime-base64-encode-region: if B encoding, strip out line breaks after encoding if using an external encoder. * vm-resend-bounced-message: use Resent- headers. * extend mail mode menu. * put VM mail mode menu on menubar (FSF Emacs). * display content type information in the MIME button even if Content-Description is present. * retire vm-unsaved-message. * vm-run-command-on-region: don't visit file to determine how large it is. VM 6.15 released (20 February 1997) * move start of attachment tag out of header section. * vm-mime-preview-composition: don't copy extents under XEmacs. * use text properties for attachment tags in FSF Emacs. * vm-mime-attach-file: pass description from interactive spec into function. * better handling of M-x vm-mode w.r.t. coding systems under Mule. * Shapiro typo fixes. VM 6.14 released (19 February 1997) * New variables: + vm-pop-max-message-size + vm-mail-check-interval + vm-pop-messages-per-session + vm-pop-bytes-per-session + vm-image-directory + vm-mime-default-face-charsets + vm-mime-charset-font-alist * vm-get-spooled-mail: ncons -> nconc. * vm-mime-parse-entity: allow trailing LWSP-chars on boundary lines. * vm-make-presentation-copy: don't bury folder buffer when displaying presentation buffer. * vm-get-spooled-mail: block signaling of errors if mail has already been appended to the folder. Just display a message and continue. * vm-gobble-crash-box: don't try to rename the crash box unless we actually put something into it. * vm-pop-move-mail: don't use a filter function. This should avoid consing and discarding big strings while downloading a maildrop and avoid swamping Emacs' heap with them. * fixed a couple of attachment tag seepage problems. * for subpart parse errors cram (car (cdr data)) into the description slot rather than the car; braino... the string is further down the list. * vm-delete-duplicates: don't croak if vm-chop-full-name-function can't extract an address. * vm-yank-message: search more than one level deep for textual MIME part when yanking a message into a composition buffer. * added image stamps for MIME types that are displayed with the MIME buttons under XEmacs (> 15bit displays only). * vm-pop-retrieve-to-crashbox: don't search from the beginning of message each time new output is added to the POP buffer. * suppress prompt for POP password unless the user ran a command that caused mail to be retrieved. * vm-auto-select-folder: pass clump argument to vm-get-header-contents. * don't let attachment be inserted into the header section of a message. * should-use-dialog-box -> use-dialog-box * simplify crashbox renaming to just use "Z" + a random number and check for existence of the destination file before renaming. This avoids the need for a one second sleep to avoid name collisions. * Makefile: use -insert in rule to build vm.info to support XEmacs 19.14's broken command line parsing. * new `getmail' toolbar button available under XEmacs. * vm-mime-send-body-to-file: reread file name if user inputs a directory name, using the dir plus the default filename as the new default filename. * default value of vm-flush-interval now 90, was `t'. * require at least one valid header and a From header in messages in RFC1153 and RFC934 digests. If the requirement is not met, assume the prior message boundary was not valid unless it was the boundary at the end of the digest. * ignore line lengths when doing "Q" and "B" encoded word encoding. * reverted to pre-6.05 version of vm-scroll-forward-internal. The pos-visible-in-window-p check still doesn't work correctly in the face of window size changes. Only scrolling the buffer is an accurate indicator of whether we're on the last page. * Makefile: default VM build type is now `noautoload'. * vm-decode-mime-messages: if called interactively and we're previewing, call vm-show-current-message so the body will be displayed. * set timer to delete POP processes two seconds after the session ends to try to evade a race condition in the TCP protocol that causes long delays when closing a socket. * give up on using mail-extract-address-components. * use proper file coding systems for reading and writing for XEmacs/MULE. * vm-mime-encode-composition: prefer params attached to the extent over parameters in the body of the an already-MIMEd object, since the information is guaranteed valid. It also avoids losing the quotes on boundary parameters. * vm-show-current-message: check value of vm-mime-decoded in correct buffer, i.e. the folder buffer not the presentation buffer. * stopped using w3-region. * put MIME encoded words in the summary cache instead of decoded words to avoid losing Kanji and other long coded char types on saves. * set scroll-in-place to nil in VM folder and presentation buffers. * keep quoted copy of some structured fields of MIME headers for later use. Useful if we want to inherit the type and parameters of a subpart. * vm-mail-internal: set vm-mail-mode-map-parented for the XEmacs case as well as the FSF Emacs case. * trimmed vm-mail-mode-map of some key bindings that already appear in mail-mode-map. * replace some FSF Emacs menubar command entries in Mail mode. * vm-kill-subject: type fix vm-move-after-deleting -> vm-move-after-killing VM 6.13 released (7 February 1997) * set file-precious-flag to t in vm-mode buffers. * vm-mime-qp-encode-region: call vm-insert-char properly when inserting linebreaks (sigh). * vm-menu-toggle-menubar: save-excursion around recursive calls to avoid a buffer change. Symptom of bug was that menubar toggling didn't work if the presentation buffer was the current buffer. * don't use 'replicating property on attachment tag extents under XEmacs as they tend to make XEmacs crash. * vm-forward-message: don't use vm-forward-list in temp buffer when miming; it has a nil value there instead of the needed message list. * signal an error if the user tries to attach a directory, nonexistent file or unreadable file to a MIME composition. * stuff attributes by reverse physical order. This should decrease the amount of gap motion when stuffing attributes in folders that have been sorted by some key other than physical-order (thank you Bob Glickstein for this speedup idea). * vm-thread-list: don't remove the head of thread-list when a loop is detected. Symptom was that threading without using the Subject header was often broken. I guess vm-thread-using-subject == nil is not a popular setting. * vm-show-current-message: moved setting of vm-system-state back inside the conditional that checks whether the folder or presentation buffer is visible. Having it outside seemed to be causing pain for vm-preview-lines == nil users, bane of life. :-/ * vm-delete-buffer-frame: removes itself from vm-undisplay-buffer-hook, as it did before some recent changes. VM 6.12 released (6 February 1997) * New commands: + vm-mime-encode-composition + vm-mime-preview-composition * New variables: + vm-mime-avoid-folding-content-type + vm-mime-display-function * Retired variables: + vm-summary-subject-no-newlines * replace newlines with spaces in all subjects and full names displayed in the summary. * vm-guess-digest-type: listp -> vectorp. The MIME layout struct type changed since this code was last looked at. * don't let subpart parse errors make the parse of the whole MIME message fail. Return a default type upon encountering a non-top-level parse error. * vm-forward-message: like vm-send-digest, use an attachment in the composition buffer if vm-send-using-mime is non-nil. * more status messages for things that take a while to execute. * set default value of vm-send-using-mime based of featurep 'mime-setup to try and avoid bad interaction with TM. * vm-mime-qp-encode-region: don't use insert-string, since it does different things in Emacs and XEmacs * MIME header-decode strings that go into the summary cache that are taken from headers that can contain encoded words. * add "MIME-Version:" and "Content-" to the default list of headers (vm-resend-bounced-headers) that are kept when resending a bounced message. * don't treat multiple occurrences of all headers like the multiple occurrence of a recipient header. Old behavior was to clump all header instance contents together separated by ", ". Now some headers clump, some don't, and some clump with a different separator string. * don't move message pointer if deleting after archiving even if vm-move-after-deleting is non-nil. VM 6.11 released (3 February 1997) * vm-mime-encode-composition: don't encode the whole message when trying to encode the last text part. * vm-yank-message: use (car parts) instead of `o' inside the MIME part insertion loop. Symptom, nothing was inserted when yanking a multipart message * changed default value of vm-auto-displayed-mime-content-types to ("text" "multipart"). VM 6.10 released (3 February 1997) * New variables: + vm-honor-mime-content-disposition + vm-mime-attachment-save-directory * vm-mime-display-internal-message/partial: changed incorrect reference to layout to (car p-list). Symptom of the bug was the "total" parameter would not be found unless it was present in the message that was current when the message/partial button was activated. * vm-check-emacs-version: allow VM to run on v20 Emacs/XEmacs. * removed bogus default value of vm-frame-parameter-alist. * vm-yank-message: when yanking a MIME message, don't yank non-text parts. * fixed problem with vm-show-current-message being called twice if you put the cursor on a non-current MIME message in the summary and hit RET. The symptom was that you would get the `all button' MIME display instead of the `decoded' display. * discard any directory components from default filename provided via a MIME object. * fixed buggy handling of multipart/alternative to pick the best part rather than the last displayable part. * vm-decode-mime-message: when doing the `buttons' display, display buttons for all non-composite objects, i.e. make all multipart types transparent. * treat multipart/parallel exactly like multipart/mixed. * vm-mail-send: take precautions so that VM doesn't manhandle the wrong buffer if the composition buffer is killed inside mail-send. * vm-mime-qp-decode-region: treat CR after = like a soft local line break. The message is supposed to be written in the local newline convention (LF only) by the time VM sees it, but when was life ever easy? Why am I sure that I'll be visiting this again? * run w3-region in its own buffer and wrap it in save-excursion / save-window-excursion to prevent it from fiddling with VM's window environment, clip region and point. * make sure the presentation buffer has a license to kill frames if vm-frame-per-folder is non-nil. * put quotes around boundary parameters in multipart messages that VM creates, since the random boundary strings might contain a /, which requires quoting. VM 6.09 released (30 January 1997) * MIME composition (support for vm-send-using-mime) * New commands: + vm-mime-attach-file + vm-mime-attach-mime-file * New variables: + vm-mime-8bit-composition-charset + vm-mime-8bit-text-transfer-encoding + vm-mime-attachment-auto-type-alist + vm-mime-max-message-size * fixed range check bug in vm-mark-or-unmark-summary-region. * don't ignore whether the text/plain internal display function fails when used as a fallback display function for textual types. Unsupportable charsets might make it fail; should default to application/octet-stream in that case. * fixed MIME parsing in virtual folders. * don't move window point when decoding MIME messages if the presentation buffer's window is the selected window. * added a third state for vm-decode-mime-messages to show all buttons before going back to the raw data. * fixed frame-iconified-p typos. * fixed vm-mime-convert-undisplayable-layout to return a layout instead of a status message :-P. * avoid using make-local-variable on kill-buffer-hook in some buffers since this is now apparently a no-no. * check Emacs version and signal an error if the version the user is using is too old to run VM. * fixed really doof bit shift and masking errors in vm-mime-qp-encode-region. VM 6.08 released (26 January 1997) * New commands: + vm-mark-summary-region + vm-unmark-summary-region * New variables: + vm-spool-file-suffixes + vm-crash-box-suffix + vm-make-spool-file-name + vm-make-crash-box-name * vm-mime-base64-encode-region: fixed typo base64-decoder -> base64-encoder. * save-excursion around switch-to-buffer in 'vm and 'vm-visit-virtual-folder startup code to avoid possibly switching to the summary or presentation buffer. * don't propagate vm-ml-sort-keys to the presentation buffer. * make sure buttons start at the beginning of a line after the first decoding pass. * support the native-sound-only-on-console variable under XEmacs. * added image/tiff support for XEmacs. * vm-mail-send-and-exit: respect the buffer stack; don't make VM buffers rise in the stack after sending a message by forcing the display of a VM buffer with vm-display. * vm-mail-send-and-exit: don't attach VM buffers to the unsuspecting frame that we land on after deleting the composition frame. * vm-mail-send: protect the value of this-command in a couple of places. * Under XEmacs, give the vm-summary-overlay extent a `t' start-open property to avoid text leaking into that extent from summary entries earlier in the buffer when such entries are updated. VM 6.07 released (23 January 1997) * New variables: + vm-raise-frame-at-startup + vm-mouse-track-summary * vm-goto-new-frame: ditch the sit-for code; it screws with window-start. * vm-display: always raise frame if doing a buffer display, unless invoker says not to. * vm-preview-current-message: run the select-message hooks before copying to the presentation buffer. Maybe this will allow the font-lock stuff that users put on these hooks to work. * fixed bug where application subtypes were ignored. * mark folder buffer for update after displaying raw MIME data with 'D'. The toolbar wasn't being updated. * add enabled-p function for Quit and Helper toolbar buttons. * set default values for vm-toolbar-helper-icon and vm-toolbar-delete/undelete-icon so that greyed buttons are displayed when a non-VM mode buffer is current. * vm-inhibit-startup-message variable retired. * added XEmacs support for audio/basic. * vm-mime-send-body-to-file: show default filename, if any, in prompt. * vm-build-virtual-message-list: make virtual folder inherit the global label lists of all the associated real folders. * fixed totally gubbed handling of multipart/parallel. * use shell-command-switch instead of "-c" when running shell command lines. VM 6.06 released (21 January 1997) * New variables: + vm-mime-type-converter-alist + vm-move-after-killing * fixed matching of tags under FSF Emacs to ignore the bracketing. * narrow to the message clip region in both the folder and presentation buffers to avoid confusing peripatetic users who insist on looking at the wrong buffer. * bury the folder buffer when using the presentation buffer. Again this is to make it harder for users to stumble over it. * changed "Click" to "Click mouse-2" in the buttons so users won't try mouse-1. * added support for deprecated "name" parameter of application/octet-stream to specify a default filename. * added support for image/png under XEmacs. * added support for message/partial assembly. * added support for message/parallel display. * default charset to us-ascii is some places where it was not being done. * set frame deletions hook in the presentation buffer. * ignore Content-Description header if it is empty or all whitespace. * fixed vm-mouse-3-help so that balloon help is displayed; first sexp in a function apparently is always considered to be a docstring and is not returned. * be more verbose when doing MIME decoding and display so the user knows what's going on. * evade the awful XEmacs file dialog box. * vm-mouse-send-url-at-position: call `widen' to avoid referencing a positon outside the clip region. * complain about invalid virtual selectors if the user enters one. * keep track of the frames that VM creates so that we don't delete frames that VM didn't create. * don't delete frames that VM did not create. * do a sit-for immediately after creating a frame so that the status messages will appear in the new frame. This is mostly for XEmacs. * vm-make-presentation-copy: don't leave the folder buffered unnarrowed * filled in some gaps in vm-supported-window-configurations. * stopped passing vm-Next-message and vm-Previous-message to vm-display; we use the official names now. * set buffer-file-type to t temporarily when writing POP transcript buffer contents to crashbox. * attach toolbar to frame as well as to buffer if VM created the frame we're displaying the toolbar on. * run vm-menu-setup-hook under XEmacs also. * (require 'disp-table) before calling standard-display-european to insure that standard-display-table gets initialized _before_ lambda-binding it (FSF Emacs only). * vm-options-file -> vm-preferences-file. * vm-mouse-button-2: don't call vm-preview-current-message; vm-follow-summary-cursor already does this. * default value of vm-forwarding-digest-type changed to "mime". * default value of vm-digest-send-type changed to "mime". * vm-decode-mime-messages: if message is already decoded, then display the raw MIME data instead. * use vm-chop-full-name-function in vm-su-do-recipients instead of the home brewed regexps. * vm-display: don't call raise-frame unless either a) the window's frame we want displayed is not visible, i.e. is unmapped or iconified, or b) the invoker specifically demands that we raise the frame. * vm-scroll-forward/vm-scroll-backward: demand that the folder buffer frame be raised. * Shapiro typo fixes VM 6.05 released (15 January 1997) * New variables: + vm-popup-menu-on-mouse-3 + vm-frame-per-completion + vm-burst-digest-messages-inherit-labels * fixed bug in vm-set-summary-redo-start-point and vm-set-numbering-redo-start-point that caused expunges in virtual folders to have screwy numbering and summary entries that don't correspond to real messages. * display MIME messages using non-US-ASCII character sets. (Only ISO-8859-1 for Emacs 19.34 and XEmacs 19.14, many more for XEmacs 20.0. * decode MIME headers, e.g. =?ISO-2022-JP?B?GyRCPGkyLBsoQiAbJEJDTkknGyhC?= * set buffer-file-type, binary-process-input, and binary-process-output correctly for DOS and Windows systems. Hopefully this will cure the MIME decoding problems seen there. * copy current menubar before toggling menubar to the XEmacs global menu when running under XEmacs. This is done to avoid discarding menu entries added by minor modes like mailcrypt. * support mailto: URLs internally. * support RFC 1738 style tags. * changed some virtual folder selector functions to handle being passed a virtual message instead of a real message. This allowed virtual messages to be passed to all selectors, which is what selectors like vm-vs-marked needed to work properly. * default value of vm-digest-burst-type changed from "rfc934" to "guess". * vm-set-window-configuration: if current buffer is a mail-mode buffer, use it for the `composition' buffer for window configuration purposes instead of the one found by vm-find-composition-buffer. Proximity implies affinity, I hope. * typo fix: vm-mm-mime-layout should have been vm-mm-layout in vm-guess-digest-type. * vm-scroll-forward-internal: check for vm-text-end-of visible before attempting to scroll, signal end-of-buffer if it is visible. * vm-mime-parse-entity: set buffer to real message's folder buffer * added extra save-excursion to various functions to protect against point motion in the buffer to which the function temporarily switches. * force display of either the folder buffer or the presentation buffer after creating the temp folder in the message/rfc822 internal handler. * force display of either the folder buffer or the presentation buffer after sending a message and undisplaying the composition buffer... this before trying for a window configuration that is indifferent about displaying any particular buffer. This should allow the vm-mutable-windows == nil crowd to see the correct buffer more often after sending a message. * vm-guess-digest-type: limit search for rfc1153 separator to the end of the message being burst. * fixed brokenness in VM's invocation of the FSF Emacs interval timers so that they actually work now. * vm-reorder-message-headers: don't cons strings to copy headers. Use positions instead and move text around solely via buffer to buffer copies. This should prevent VM from consing itself and Emacs into oblivion when faced with hundreds of To/Cc headers. * display text/html internally using w3-region if w3-region is bound after (require 'w3). * consider iso-8859-1 charset messages `plain' for the purposes of deciding whether MIME decoding is needed. * made qp decoder not think the end of the region was an equal sign. * under XEmacs don't default vm-mime-button-face to gui-button-face on ttys. gui-button-face is plain on ttys so use bold-italic instead. * remove references to underline in the sexpr default for vm-mime-button-face. * documentation improvements VM 6.04 released (9 January 1997) * mime-error -> vm-mime-error * &optioanl to &optional in def of vm-mime-base64-decode-region * require some diagnostic output before signaling an error when a MIME external decoder exits non-zero. * save-excursion when running quit hook to avoid buffer changes. * don't call facep if it isn't bound. FSF Emacs when compiled without window system support doesn't have face support either. * use reasonable toolbar width and height values if glyph-width and glyph-height return 0, as they do sometimes at startup. * typo fixes from Shapiro. VM 6.03 released (8 January 1997) * made vm-show-current-message use vm-mime-plain-message-p to decide whether to use the presentation buffer, just as vm-preview-current-message does, to avoid calling vm-decode-mime-message when there is no prep'd presentation buffer. * fixed calls to vm-run-command-on-region to use apply so that last arg could be an arg list. * fixed parsing bug in vm-mime-plain-message-p; use \(.*\) instead of \\(.*\\) inside a regexp string. * made vm-decode-mime-message refuse to decode plain messages. * more work on vm-quit and friends to make sure buffers are buried or killed when they should be. * turn off undo record keeping in temp work buffers. * removed undo button from the fallback VM popup menu under FSF Emacs. * vm-mime-send-body-to-file: fixed reversed logic after asking "File exists, overwrite? " * fixed (wrong-type-argument (number-or-markerp nil)) bug in vm-mime-base64-decode-region; botched eob test cause char-after to be called at eob and the result was used in a numeric comparison. * rewrote vm-determine-proper-content-transfer-encoding, fix a small bug with the line length check. * fixed parsing of empty MIME bodies * vm-discard-cached-data: for each affect folder and virtual folder if there's an associated presentation buffer, call vm-preview-current-message to rectify the contents of the presentation buffer with the new reality. * force inclusion of MIME headers into forwarded and digestified messages if the message is not plain. * do CRLF -> LF conversion for text and message types after base64 decoding. * disallow multipart types to be sent to an external viewer. * doc improvements VM 6.02 released (8 January 1997) * New variables: + vm-mime-base64-decoder-switches + vm-mime-base64-encoder-switches * empty the presentation buffer after expunging if the resultant folder is empty. * fixed bug in vm-edit-message; when computing the cursor offset from the start of the message, it was using the value of point from the folder buffer when it should have used the value in the presentation buffer if the latter buffer existed. * bury the presentation buffer in those places where the folder buffer and summary are also buried. * fixed bug in vm-mime-base64-decode-region that would corrupt the last two bytes in a body if there were two padding bytes of the end. * use process-kill-without-query on external viewer processes. * made vm-run-command-on-region use it arg-list parameter * decode base64 or quoted-printable text in message bodies yanked into composition buffers. * remove undo button from vm-menu-vm-menu, which is the popup menu that mostly mirrors the main VM menubar. The button doesn't have much value in a popup menu and I think it is angering ntemacs. * ensured case insensitive matching of MIME Content-Type parameter names. * don't display the Decode MIME toolbar button, don't enable the Decode MIME menu entry, and don't use the presentation buffer if the message is of type text/plain; charset=us-ascii and has no opaque transfer encoding. * don't show autosave and backup file names in the *Files* window. VM 6.01 released (7 January 1997) * fixed bug that caused a message not to be displayed if vm-auto-decode-mime-messages is non-nil. * fixed FSF Emacs specific bug that cause mouse-2 and mouse-3 to not work correctly over URLs. * fixed vm-mime-burst-layout to allow bursting of all subtypes of MIME type "message". * messages of unknown subtypes of MIME type "message" are displayed as text/plain, which is more likely to be correct than treating them as message/rfc822. * added popup menus to the MIME buttons. * typo fixes VM 6.00 released (6 January 1997) * MIME reader support, digest send/burst, resend bounce * New commands: + vm-burst-mime-digest + vm-send-mime-digest + vm-send-mime-digest-other-frame + vm-decode-mime-message * New variables: + vm-display-using-mime + vm-mime-alternative-select-method + vm-mime-digest-discard-header-regexp + vm-mime-digest-headers + vm-auto-displayed-mime-content-types + vm-auto-decode-mime-messages + vm-mime-internal-content-types + vm-mime-external-content-types-alist + vm-mime-button-face + vm-mime-base64-decoder-program + vm-mime-base64-encoder-program + vm-temp-file-directory * Use local-map property on URL overlays so that URLs can now be activated by pressing RET in FSF Emacs. This feature was already present under XEmacs. * Check for buffer-file-name non-nil or buffer-offer-save non-nil before we warn the user about quitting without saving changes. Also use this check before trying to save the folder during a quit. * vm-mode now sets buffer-offer-save to t. * panic buffoon's color changed from yellow to rgb:00/df/ff * made use of the [Emacs] and [Undo] menubar button conditional on not being under Windows 95 or NT. Those versions of Emacs don't handle menubar buttons. * use FSF Emacs' interval timer package if not (featurep 'itimer). VM 5.97 released (22 December 1996) * temporarily set print-length to nil while VM is writing out Lisp objects. * changed vm-menu-support-possible-p to accept 'win32 as a window-system value that means menu support is possible. * fixed parse problem in vm-parse-addresses with () and "". Also change code not to put empty strings recipients in the returned list. * made vm-toolbar a user variable. Experimental. * documentation fixes VM 5.96 released (9 June 1996) * started shipping a pre-built vm.elc file for those who can't build VM. * changed predictate function that determines whether menu support is possible; there can be window system support without menubar support. * changed build procedure to not concatenate .elc files when building the autoloadable version of the program. The concatenation broke Emacs' dynamic loading feature, which some users wanted to use. * fixed typo in default setting of vm-default-folder-type; if system-configuration was unbound, vm-default-folder-type would be set to From instead of From_. * vm-quit-just-bury: reordered burying and undisplaying actions again to try to keep undisplaying from bringing one of the buried buffers back to the top of the buffer list. * vm-follow-summary-cursor: the position at end of buffer now belongs to the last message. * New variables: + vm-virtual-mode-hook * use extent-end-position instead of extent-live-p since XEmacs 19.11 doesn't have extent-live-p. * added ( and ) to characters that cannot be part of an URL path. * changed 'count' local variable in let s-exp to 'undel-count' to avoid conflict with prefix arg parameter also called 'count' * changed vm-help to use (describe-function major-mode) instead of (describe-mode) since in Emacs and XEmacs describe-mode describes minor modes, too. * fixed infinite loop bug in vm-frame-loop. Needed to make sure that the frame we start in could never be a minibuffer-only frame because the loop will never visit a minibuffer-only frame again and thus never terminate. VM 5.95 released (18 August 1995) * vm-find-leading-message-separator: for From_ type folders, removed requirement that there be two newlines before "From " message separators. * don't change summary and numbering redo start points once they are set to t. This got screwed up when I fixed other problems in vm-expunge-folder. * vm: always do window configuration setup if doing full startup. * Shapiro typo fixes * default value of vm-startup-with-summary now t. * default value of vm-follow-summary-cursor now t. * call delete-other-windows before running reporter-submit-bug-report so the user has the full screen to work with. * vm-edit-message-other-frame: lambda-bound vm-frame-per-edit to nil when calling vm-edit-message. * vm-mouse-send-url: fixed calls to vm-unsaved-message that had a missing arg. * vm-keyboard-read-string: make RET do completion and exit the minibuffer (non multi-word reads only). * fixed auto correction in vm-read-string. * set default-directory before running auto-save-mode in vm-mail-internal so the auto-save file name picks up the directory change. VM 5.94 released (4 August 1995) * use window instead of frame in set-mouse-position call (XEmacs 19.12 only). * vm-warp-mouse-to-frame-maybe: nil coordinates mean that the mouse is not really within the frame, so move it. (FSF Emacs only). * use regexp-quote on header contents passed to vm-menu-create-*-virtual-folder functions. * don't set keymap parents for any extent local keymaps because this breaks minor-mode-map-alist, which breaks isearch. * don't actually select frames in vm-frame-loop since this affects the buffer stack. * vm-quit-just-bury: moved vm-bury-buffer calls after the vm-display calls; the latter may have been partially undoing some of the burying. * vm-mail-send-and-exit: moved vm-bury-buffer call after the vm-display call; the latter may have been partially undoing some of the burying. * expect From_-with-Content-Length folders by default on IBM AIX systems. * added toolbar button help messages. * added URL balloon help messages * added electric header balloon help messages * added status messages for when URLs are sent to browsers. * added "https" to the URL match regexp. VM 5.93 released (25 July 1995) * fixed null menu problem if vm-use-menus == 1 (FSF Emacs only); menu map wasn't being built. * tollbar -> toolbar typo in vm-toolbar.el. * vm-find-leading-message-separator: for From_ type added requirement that something that looks like a header or ">From " be on the line after the From_ line. * truncate ultralong buffer names generated by vm-rename-current-buffer-function. * vm-auto-archive-messages: don't really save message if the destination folder is /dev/null. VM 5.92 released (19 July 1995) * vm-set-summary-pointer: check vm-su-start-of for nil value before trying to go to its position. * reuse vm-summary-overlay instead of deleting and recreating it. * fixed dup menu entries in FSF Emacs menubar toggled menubar. VM 5.91 released (19 July 1995) * fixed dup menu problem in FSF Emacs. * vm-expunge-folder: disabled summary updates of expunged messages. * fixed typo in vm-use-menus default value. * check for multi-frame support before trying to create a frame in vm-edit-message. * efficiency tweaks in vm-toolbar-can-recover-p and vm-update-message-summary; avoid work most of the time by testing for the common bailout cases early. VM 5.90 released (16 July 1995) * use vm-set-deleted-flag-of instead of vm-set-deleted-flag in vm-expunge-folder. Should make expunging much faster since many wasted summary updates are eliminated. * use a different symbol name for every menubar binding, as opposed to just a different symbol. (FSF Emacs only.) FSF Emacs seems to match against the names. VM 5.89 released (16 July 1995) * deal with system-configuration not being bound. * don't call buffer-substring with three args in vm-buffer-substring-no-proprerties. buffer-substring only takes two args in FSF Emacs. * fixed XEmacs toggle menu button. * added menu toggle button for FSF Emacs. * changed Undo menu into an Undo button in FSF Emacs. * don't fset most of the vm-toolbar-*-command variables if they are already fbound; lets the user customize them from ~/.vm. * new semantics for vm-use-toolbar. * new semantics for vm-use-menus. * vm-update-message-summary: changed insertion/deletion dance so that window point moves to the beginning of the current summary entry instead of the beginning of the next summary entry when an attribute change occurred and the cursor is in a summary entry but not at beginning of line. * added "Recover" toolbar button that appears in conjunction with "Auto save file is newer..." VM 5.88 released (13 July 1995) * New variables: + vm-frame-per-summary + vm-frame-per-edit + vm-rename-current-buffer-function + vm-thread-using-subject * default window configuration for editing-message now full screen instead of split with summary. * moved calls to vm-set-hooks-for-frame-deletion to avoid having the hooks attached to the wrong buffer. * swapped first and second args to mapconcat in vm-print-message. * check for killed folder buffer in toolbar enabled-p functions to avoid the wildebeest-botfly-toolbar-enabled-p-death-spiral bug in XEmacs 19.12. Actually it looks like that bug was fixed before 19.12 was released. * check for killed folder buffer in menubar enabled-p functions to avoid the wildebeest-botfly-menubar-enabled-p-death-spiral bug in XEmacs 19.12. Unlike the toolbar counterpart, this is bug still exists in 19.12. * vm-read-file-name: allow old value of file-name-history to be used if history is nil. * panic buffoon's color changed from DarkGreen to yellow. * call device-type without any args. device defaults to (selected-device) anyway. * put a save-excursion around the parts of vm-delete-buffer-frame that might change Emacs' idea of the `current buffer'. Lack of this save-excursion caused vm-undisplay-buffer-hook for another buffer to be modified by remove-hook. * vm-read-string: don't pop up mouse interface if the completion list is empty. instead just run the keyboard interface. * don't try to add to menubar if it is nil. (XEmacs only) * recognize rmail, rmail-input and rmail-mode as alternate names for vm. for (defalias 'rmail 'vm). * Shapiro typo fixes. * match Content-Length header case insensitively. * hide the 19.29 Help menu; tag moved from help to help-menu. * don't log uninteresting status messages in *Messages* log. (Emacs 19.29 only.) * use vm-save-restriction instead of save-restriction in vm-run-message-hook. * vm-show-list: fix lossage if list item is wider than the window; avoid division by zero by setting a min value of 1 for columns. * vm-easymenu.el: If callback is a symbol use it in the menu keymap instead of the uninterned menu-function-XXX symbols. This allows Emacs' menu code to set this-command properly when launching a command from the menubar. * default value of vm-convert-folder-types is now t. * instead of putting buffer objects into the virtual folder spec for anonymous virtual folders, use a s-expression that returns a buffer object. * fixed bug where forwarding a zero length message would put the forwared message outside the digest separators. * default values of vm-trust-From_-with-Content-Length and vm-default-folder-type now vary depending on the system type. Solaris and usg-unix-v users are set to use Content-Length folders. * support mail-archive-file-name and mail-self-blind in vm-resend-message. * xbm bitmaps added for XEmacs 19.13 xbm toolbar support. * fixed infinite loop bug in vm-window-loop. Needed to make sure that the window we start in could never be a minibuffer window because the loop will never visit a minibuffer window and thus never terminate. * obfuscated calls to screen-* in vm-warp-mouse-to-frame-maybe to avoid stimulating the Emacs 19.29 byte compiler bug. * prefer References over In-Reply-To when looking for a message parent when threading. * fixed infinite loop bug in vm-mark-thread-subtree; check for messages that we've already seen to avoid child is a parent of the child problem that can occur in subject threading. * strip text properties from all strings to be used in the attributes and summary cache. It should be OK now to use font-lock (i.e. text properties) in a VM folder buffer under FSF Emacs now. VM 5.87 released (16 June 1995) * New variables: + vm-search-other-frames + vm-summary-update-hook * when searching for a window displaying a buffer, always search the selected frame first. * frame-map slot of window configuration set to nil to avoid unreadable objects being printed into the window configuration file. * vm-menu-print-message -> vm-print-message * made the highlight-headers-regexp defvar in vm-vars.el match the one in XEmacs' highlight-headers.el so it doesn't matter if VM is loaded before highlight-headers.el. * warp mouse to center of frame instead of left corner. * only run vm-arrived-message-hook on new messages not messages already in the folder at startup. * fixed bug where a message deletion in one folder caused the "undelete" toolbar button to appear in another folder. * Shapiro typo fixes VM 5.86 released (6 June 1995) * toolbar support (XEmacs 19.12 only) * New commands: + vm-print-message * New variables: + vm-use-toolbar + vm-toolbar-orientation + vm-print-command + vm-print-command-switches * vm-summary-highlight-face's default value is now 'bold (was nil). * vm-highlighted-header-face's default value is now 'bold (was 'highlight). * vm-mail-send-and-exit: always undisplay buffer if it is alive after runnning vm-mail-send. Previously it would undisplay only if the current buffer were the same after running vm-mail-send. * fixed call in vm-bury-buffer to pass the argument to along bury-buffer. * region not narrowed properly for vm-display-xface, so it searched the whole message, which in turn could cause selection of large messages to take a looong time. Fixed. * vm-display-xface: use set-glyph-face instead of set-extent-face. * dropped 'highlight property from the xface extent. * if non-nil let vm-highlighted-header-regexp override highlight-headers-regexp so user can have VM specific highlight if desired. This was done before, but was undone in one of the releases. * rolled (save-window-excursion (switch-to-buffer ...)) into vm-unbury-buffer. * used vm-unbury-buffer in vm-continue-composing-message to avoid having the window configuration code pick a different composition buffer than vm-continue-composing-message did. * added netbsd to the system types that get vm-berkeley-mail-compatibility turned on by default. * clickable *Completions* * mouse triggered commands now use mouse interface to read filenames. * mouse triggered commands now use mouse interface to do completing reads of strings. * fixed typo in completion list show function tab-stop-list -> tab-stops. This was causing the ragged completions display. * vm-sort-messages: signal error is no sort keys provided. * vm: moved visited-folders-menu installation and the running of vm-visit-folder-hook so that they are executed even if "auto save file is newer ..." * fixed places where VM was unconditionally warping the mouse. * added (provide ...) calls for all vm-*.el files. * added version number to vm-mode help. VM 5.85 released (2 June 1995) * dropped reporter.el and timezone.el from distribution * merged tree-menu.el into vm-menu.el; renamed functions to avoid conflicts with the real tree-menu.el. * no more SUPPORT_EL and SUPPORT_ELC in Makefile * New variables: + vm-warp-mouse-to-new-frame + vm-use-lucid-highlighting + vm-display-xfaces * patched vm-current-time-zone to understand timezone offsets that are not an integral number of hours from GMT. * frame deletion hooks now detach themselves from buffer after one execution. * added menubar buttons to toggle between buffer local and global menubars (XEmacs only). * lambda-bound vm-follow-summary-cursor to t in vm-mouse-button-2 so mouse-2 selection in the summary will always work. * make vm-select-frame a no-op in tty-only Emacs * use set-specifier to turn off horizontal scrollbar instead of the variable buffer-scrollbar-height, which is gone now. (XEmacs 19.12 only) * changed vm-url-regexp to not match some common trailing punctuation. * added missing call to vm-move-message-pointer to vm-next-message so that it would start at the message after the current message when vm-circular-folders is non-nil and a move is being retried non-dogmatically. * fixed args to re-search-forward in the URL search code. The search bound wasn't being set. * vm-find-trailing-message-separator: if Content-Length header doens't point to the start of another message or end of folder, search for "^From " starting at the original search point. We used to start at the point Content-Length told us to go, but that can make VM clump many messages together if the incorrect Content-Length value is very large. * fixed logic in vm-display so that if the buffer is visible and is required to be displayed and the applied window configuration undisplays it, notice and display it again. * region not narrowed properly for vm-energize-headers, so it searched the whole message, which in turn could cause selection of large messages to take a looong time. Fixed. * bury-buffer -> vm-bury-buffer in most places. vm-bury-buffer buries the buffer in all frames (XEmacs only). No change in behavior for FSF Emacs. * fixed vm-expunge-folder: numbering and summary redo start points may need to be recomputed on each iteration of the message loop in the case of virtual mirrored expunges. The code previously assumed the first expunged message in a folder would correspond to the correct redo start point. This is only true for unmirrored virtual expunges or real expunges. * dropped duplicate Reply-To from vm-resend-bounced-headers. * Shapiro typo fixes. VM 5.84 released (26 May 1995) * fixed known-virtual-folders menu to use vm-visit-virtual-folder instead of vm-visit-folder. * vm-continue-composing-message now creates a frame for the composition if vm-frame-per-composition is non-nil. * fixed vm-iconify-frame-xxx so that it gives iconify-screen an arg since it churlishly requires one. * vm-delete-buffer-frame: added condition that the target frame must be the selected frame to be unconditionally deleted. Also added call to vm-delete-windows-or-frames-on to clear remaining windows and frames that might be displaying a buffer. * Added Visit tags to the known-virtual-folders and visited-folders menus. VM 5.83 released (25 May 1995) * fixed incorrect mode menus selection that was due to mode-popup-menu being set before major-mode. * fixed menubar Dispose menu * made vm fall back to `folder' if `primary-folder' parameters not specified in vm-frame-parameter-alist. * vm: at startup, reuse summary frame if available when looking for a frame displaying the folder buffer. Supposedly did this in 5.82 but I fluffed the change. * dropped second arg 't' to vm-sort-messages in the menus. Legacy stuff from 5.72.L, bad juju. * renamed support packages to vm- prefixed names to keep from picking up old or non-vm-simpatico versions. * vm-easymenu.el: renamed a couple of easy-menu- functions to further avoid picking up bad versions. * zapped "File" menu when VM is using the whole menubar. Should have been zapped already but file -> files in 19.29 and I'm testing mostly with 19.29. * moved frame creation before call to vm-preview-current-message in vm. Try to help the BBDB crowd. * made the options file optional, as it should be. * added "Mail" item to menubar in mail-mode (XEmacs only). * Folders menu deep-sixed for FSF Emacs. VM 5.82 released (25 May 1995) * New commands: + vm-iconify-frame * New variables: + vm-iconify-frame-hook + mode-popup-menu (FSF Emacs only, XEmacs already has this) * full menubar for FSF Emacs. * popup menu for vm-mode, vm-summary-mode and vm-virtual-mode is now the Dispose menu, rather than the whole VM menu set. * menu consolidations * set keymap parent of vm-mail-mode-map to mail-mode-map. * run URL browsers as background commands so that when you quit Emacs you don't have to quit the browser. * fixed "M A" and "M a" bindings to point to correct commands. * vm-visit-virtual-folder: moved summary display after folder display so the summary is displayed in the correct frame. * vm: at startup, reuse summary frame if available when looking for a frame displaying the folder buffer. * disable "Make Folders Menu" entry if vm-folder-directory is nil. * popup menus for the Subject and From headers. * fixed "new directory" menu to allow mkdir in vm-folder-directory itself. * "emacs -f vm" now ignores vm-frame-per-folder. * added `primary-folder' frame type for vm-frame-parameter-alist. VM 5.81 released (22 May 1995) * backquote use in menu and mouse code removed, due to use of newer backquoting features that were unsupported in older Emacses. * Shapiro typo fixes. VM 5.80 released (22 May 1995) * vm-su-do-author still not quite right, code not falling through to chop-full-name phase if Full-Name header existed but was empty. * fixed reversed sense of Page Up/Down menu items. * added "physical order" to the sort menu. * match-fetch-field -> mail-fetch-field in vm-menu-can-send-mail-p. * use two lines of "---" instead of "===" for compatibility with XEmacs 19.11. * changed how vm-folder-history is updated. Now VM always updates the variable itself, and doesn't let read-file-name alter it. This is so we get a real history of folders visited, and not a history of what the user typed, typos and all. * New variables: + vm-url-browser + vm-url-search-limit + vm-highlight-url-face + vm-netscape-program + vm-mosaic-program + vm-menu-setup-hook * popup menu in Mail Mode now works if you run vm-mail before any other VM command. An initialization omission broke this before. VM 5.79 released (19 May 1995) * New commands: + vm-mark-messages-same-author + vm-unmark-messages-same-author * New variable: + vm-frame-parameter-alist * don't update vm-folder-history for XEmacs, it's done automatically. Continue to update vm-folder-history for FSF Emacs since it needs it. * updated various Emacs-typecheck functions to rely on the contents of emacs-version first and foremost. * vm-mouse-set-fsfemacs-mouse-track-highlight changed to use overlays instead of text properties. VM 5.78 released (18 May 1995) * needed to pass file history as sixth arg to read-file-name instead of fifth arg. * needed to pass variable name as history instead of its value. * FSF Emacs' read-file-name doesn't take six args, needed a wrapper function to pass it only five args if it balks at six. * stopped using add-hook for vm-folder-history * vm-other-frame and vm-visit-folder-other-frame needed wrappers to set vm-frame-per-folder to nil so they wouldn't create too many frames. VM 5.77 released (18 May 1995) * send APOP command with two args instead of one, as the spec demands. * vm-display-buffer makes the buffer to be displayed or undisplayed the current buffer before searching for display hooks. Useful for having buffer local display hooks. * start n at 2 in vm-rename-current-mail-buffer. * indention -> indentation * integrated Heiko Muenkel's vm-folder-menu.el; required addition of tree-menu.el to distribution. * New file: vm-menu.el, which contains the menus and menu code. * New variables: + vm-frame-per-folder + vm-frame-per-composition + vm-use-menus * New commands: + vm-quit-just-iconify * New files: + easymenu.el + tree-menu.el + vm-mouse.el + vm-menu.el * mouse support * vm-pipe-message-to-command now takes 3 C-u's to mean use the visible headers plus the text section. * changed vm-munge-message-separators to munge messages in From_-with-Content-Length folders, too. Necessary now since From_-with-Content-Length parsing falls back to a pseudo type From_ if no Content-Length header is found. This fixes a digest bursting bug that occurred if From_ message separators appeared in a message that was being burst into a From_-with-Content-Length folder. * strip doublequotes from recipient full names as we do for sender full names. * Changed Makefile to use vm-byteopts.el for the support stuff too. * updated vm-grok-From_-* to reject inappropriate types better. * made vm-next-command-uses-marks set this-command. Needed for the menubar invocation of the command. * vm-su-do-author: moved blank full name test before the address gets chopped. Also changes search regexp from "^[ \t]+$" to "^[ \t]*$" to catch "". * added a folder history list which is used by vm-visit-folder*. * composing-message default configuration changed to "full screen composition". Previously it was "summary on top, composition on bottom". VM 5.76 released (7 May 1995) * "\.el$" -> "\\.el$" in make-autoloads. * moved message separator unstuff call before the header conversions in vm-rfc1153-or-rfc934-burst-message. Unstuff must come first or the Content-Length offsets might be invalidated by it. * if full name is just whitespace, use the address instead in summary cache. * vm-burst-digest now can be invoked on marked messages via vm-next-command-uses-marks. * prefix arg to isearch commands now toggles value of vm-search-using-regexps. * don't delete after saving when archiving if vm-delete-after-saving is non-nil and vm-delete-after-archiving is nil. * fixed bug in vm-physically-move-message that was causing vm-headers-of marker corruption. This bug could have caused serious folder corruption in BABYL folders, due to the headers that are copied for this folder type. * turned off dynamic docstrings and lazy loading in vm-byteopts.el. This is a preemptive strike against the new features of the byte compiler that will appear in FSF Emacs 19.29. * docstring typo fixes. VM 5.75 released (30 April 1995) * reinstated code that turns on auto-save-mode in vm-mail-internal. Thought it was redundant; it ain't. * fixed bug in vm-set-xxxx-flag. The same message was being put into all the undo record lists, which loses when the folder containing that message goes away. * fixed bug in vm-save-message. needed to call vm-error-if-folder-empty in the (interactive ...) spec before relying on the value of vm-message-pointer to have a non-nil value. * fixed bug in vm-convert-folder-type-headers; search for trailing message separator was starting in the wrong place--- needed an extra save-excursion around code that computed content-length. * fixed bug in vm-find-trailing-message-separator. Needed to move backward to start of separator after the fallback "^From " search. * output from movemail is no longer considered fatal. If call-process returns a number, then the error is considered fatal only if this number is non-zero. Otherwise upon unexpected output, a warning message is issued and VM carries on. * added status message in vm-pop-move-mail to count out messages as they are retrieved. VM 5.74 released (24 April 1995) * added new test data for mail-extract-address-components to catch its failure to handle "" in some older versions. * expand ~/ instead of ~ in vm-mail-internal, so that default-directory's value ends in a slash. * fixed bug in vm-{next,previous}-message-same-subject that left vm-message-pointer at the wrong position if the search for a message with the same subject failed. * FSF Emacs 19.28.90 breaks make-autoloads by adding a *Messages* buffer with a default-directory different from the directory VM started in. This buffer ends up being selected, which makes find-file-noselect not read in the wanted VM source file. Fixed this. * From_-with-Content-Length folder type now less strict. (Uncle!) If the position indicated by Content-Length doesn't look like a message separator point, VM searches forward for a line beginning with "From ". A side effect of this is that a bug is fixed in the digest bursting code that affected bursting a message in a From_-with-Content-Length folder. * skip >From at the beginning of MMDF messages. I don't know if SCO is at fault or SCO system sysadmins, but I'm tired of these bug reports. * <= should have been >= in tapestry-first-window, oops. * in vm-discard-cached-data, the header markers needed to be discarded before the message was rethreaded, otherwise the threader and summary functions would use the invalid markers. * Shapiro typo fixes VM 5.73 released (7 April 1995) * allow a default non-nil value for vm-folder-read-only to work. * moved the running of vm-arrived-message-hook into vm-assimialte-new-messages. * expand folders, crash box and primary inbox using vm-folder-directory as root if path is relative; this wasn't being done everywhere. * new reporter.el * stop padding the monthday * added reply-to to the default value of vm-resend-bounced-headers * if mail-default-reply-to == t init with (getenv "REPLYTO") for compatibility with FSF Emacs v19.29 change. * changed vm-pop-send-command to not put the user's password in the trace buffer. * set default-directory to either vm-folder-directory or ~ in vm-mail-internal. This cut down on autosave errors due to unwritable directories. * fixed bug in tapestry.el that caused recreation of tapestries with horizontally split windows to be off by one in size. * made tapestry.el use window-pixel-edges in XEmacs, if available. Apparently the window-edges function is going away. * fixed bug in tapestry-first-window. menu-bar-lines frame parameter can be non-zero when Lucid menubar is enabled even though the menubar doesn't steal lines form the topmost window. * fixed bug in vm-build-virtual-message-list, the next folder after a directory in the virtual folder spec was being skipped. * vm-thread-indention -> vm-th-thread-indention typo * fix call to error in vm-help-tale, too many args. * vm-run-user-summary-function was using the virtual message in some contexts; changed to use the real message in all contexts. * changed vm-set-edited-flag-of to a function, rolled common code from several functions that use vm-set-edited-flag-of into it, made the buffer modification flag always get set when the 'edited' flag changes. * New variable: vm-arrived-messages-hook. * removed call to auto-save-default in vm-mail-internal as I don't see why it would ever be needed. * changed vm-get-folder-type to accept start and end args; vm-pop-retrieve-to-crashbox uses these to specify where to scan in the POP trace buffer to determine if there is a folder type. * %+ -> %& in mode line spec. %+ got usurped by RMS into something else. %& now does what %+ was supposed to do. * fixed bug in vm-expunge-folder. It did not work properly with marks because parts of the code assumed that mp always traversed vm-message-list, which was not true if marks were being used. * made the virtual folder spec parser skip auto-save files and backup files when globbing the contents of a directory. VM 5.72 released (29 May 1994) * doc fixes * fixed vm-after-revert-buffer-hook to not attack non-VM buffers. * changed calls to find-file-name-handler to specify the operation; I don't care why. * run hooks in vm-arrived-message-hook for messages returned by the call to vm-assimilate-new-messages. * call vm-find-leading-message-separator before calling vm-skip-past-leading-message-separator in the vm-stuff- functions. This avoids stuffing headers before the leading message separator due to vm-skip-past-leading-message-separator being confused by newlines at the beginning of folder. VM 5.71 released (25 May 1994) * (fboundp 'mail-signature-file) -> (boundp 'mail-signature-file). graaaggg. * vm-mutable-window non-nil non-t special behavior eliminated. * added `exit-minibuffer' to the list of commands VM will do window config setup for. This is so that recover-file and revert-buffer, which read from the minibuffer but do not protect the value of this-command, have window configuration done for them. * fixed VM support for revert-buffer for v19.23 Emacs; revert-buffer now preserves some marker positions across the reversion and this hosed VM's check for reversion since it used the marker clumping as an indicator of the reversion. v19.23 has a new after-revert-hook that VM uses. * Shapiro and Foiani typo fixes. VM 5.70 released (18 May 1994) * added missing quote in (fboundp mail-signature-file) in vm-reply.el. VM 5.69 released (18 May 1994) * vm-munge-message-separators needed (goto-char start). * fixed vm-munge-message-separators to pay attention to first arg, folder-type. * fixing vm-munge-message-separators exposed a bug in vm-convert-folder-type; trailing message separators were getting munged inappropriately because of a bad search bound due to a marker being shifted. * digest bursting code also needed to be fixed, now that vm-munge-message-separators is actually doing the (goto-char start); match-data needed to be saved and restored, needed to start munging after inserting the leading message separator instead of before inserting it. * moved message order gobbling into vm-assimilate-new-messages; needed because thread sorting is done there and message order gobbling needed to be done before thread sorting. * In FSFmacs 19.23, find-file-name-handler takes two args, it used to take only one. The second arg is not optional. Fixed code to deal with the one or two arg versions of this function. * tink message modflag if we encounter a v4 attributes header in vm-read-attributes. The idea is that if the user saves the folder we get rid of those retro headers, so the user gets a fast summary thereafter. * get rid of vm-unhighlight-region, since it adds text properties that we definitely don't want to find their way in the summary cache headers. * made signature insertion work more like mail-mode; use mail-signature-file for lemacs compatibility, insert the mail-signature string itself, instead of using it as a file name (oops). * don't go to point-max if to is null in vm-mail-internal--- keep point just after the header/text separator line. * added the word "encapsulation" to RFC 934 digest start. * fixed babyl label reading bug; needed to skip past comma after attributes. * use regexp-quote on mail-header-separator before using it as a search string; can't count on users not putting plusses and other regexp crap in it. * dropped def of vm-highlight-region. * dropped the spaces after the commas in the label strings. Previous convention seems to be to not display them. * doc string fixes. VM 5.68 released (12 April 1994) * vm-resend-bounced-message now strips Sender. * for From_-with-Content-Length in vm-find-leading-message-separator use (match-end 1) instead of (match-beginning 0). * fixed code in vm-find-trailing-message-separator so that it allows mutiple bogus newlines at the end of a message at the end of a From_-with-Content-Length folder. Turns out this code is really needed, and I found out after I broke it. * vm-byte-count -> vm-su-byte-count in vm-save-message. * removed unneeded (setq vm-need-summary-pointer-update t) forms in vm-motion.el. * don't flush in vm-flush-cached-data if vm-message-list is nil. * header highlighting is now done using overlays instead of text properties in FSF 19. This should cure the "text property leaking in to the summary cache" problem. * summary highlighting is now done using overlays in FSF Emacs and extents Lucid Emacs 19. * header highlight under Lucid Emacs is now done using the out of the box header highlighting functionality. * Shapiro typo fixes. VM 5.67 released (6 April 1994) * used match-end instead of match-beginning in vm-find-leading-message-separator for From_-with-Content-Length folders. (ack!) * revised some docstrings. * added docstrings for many internal functions. * made vm-find-and-set-text-of to set start of text section to (point-max) if \n\n wasn't found. This is more likely to be right than setting it to (point) when the search fails. * put kludge in make-autoloads to deal with v19 autoload fifth arg breakage. * vm-auto-archive-messages now natters about what it's doing, since it's often long running and slow. * don't stuff labels unless there are messages in the folder. * fixed a couple of calls to format that had too few args. VM 5.66 released (26 March 1994) * added call to vm-unhighlight-region to turn off highlighing of headers gathered from the folder buffer. * set current buffer to real message's buffer, not virtual message's buffer, in vm-save-message-sans-headers. * use `signal' with folder-read-only instead of calling `error' in vm-save-message. * fixed type mismatch error message in vm-save-message; must use (vm-message-type-of m) instead vm-folder-type because current buffer is the target folder buffer and not the source buffer during buffer->buffer saves. Went ahead and changed the buffer->file code for consistency. * changed all calls to get-file-buffer to vm-get-file-buffer, which makes all file->buffer mapping try truenames as well as unchased names. * allow leading newlines in From_ and From-_with-Content-Length type folders. * allow multiple trailing newlines in From-_with-Content-Length type folders. * moved call to vm-convert-folder-type-headers up a bit in vm-convert-folder-type, as content-length header generation needs the old folder type's trailing message separator to be present. This makes everything-but-mmdf -> From_-with-Content-length crash box conversion work right. Apparently no one ever tried this. * moved call to vm-convert-folder-type-headers up a bit in vm-change-folder-type, as content-length header generation needs the old folder type's trailing message separator to be present. This makes everything-but-mmdf -> From_-with-Content-length folder conversion work right. Apparently no one ever tried this. * fixed marker shift problem in vm-change-folder-type that caused inserted trailing message separators to be stripped. Conversion from From_-with-Content-Length to other folder types triggered this because there's no trailing message separator for From_-with-Content-Length folders. * don't clump messages together if Content-Length is wrong. this meant moving the content-length goop from vm-find-leading-message-separator to vm-find-trailing-message-separator, which is where it should have been anyway. * insert "-- \n" before the signature. not worth the argument or unending bug reports. * fix code that assumes a non-nil value for buffer-file-name in folder buffers. VM 5.65 released (17 March 1994) * fixed reverse link bug in vm-expunge-folder that was causing renumbering to bug out. * "folder buffer has been deleted" for those who could not figure this out on their own. * dot unquote fix in 5.64 wasn't quite right; try again. * turning off threading now sorts by physical order to avoid the misleading modeline display. * vm-{mark,unmark}-message-same-subject now follows the summary cursor. * fixed logic error in vm-unthread-message; messages without parents were not being unthreaded. * dropped unused ref to unread-command-event. * same subject mark commands now report the number of messages they mark or unmark. * don't mark buffer modified unless sort actually changed the message order. * dropped vm-preview-current-message call in vm-save-folder; we'll see what the effects are. VM 5.64 released (9 March 1994) * dropped call to widen in vm-do-reply, unneeded now that vm-yank-message is called instead of doing the yanking internal to vm-do-reply. * always do the stuff in vm-set-buffer-modified-p regardless of the real modified flag's value. * unquote _all_ leading dots in inbound POP messages. * don't call vm-preview-current-message in an possibly empty folder in vm-assimilate-new-messages. * don't override pre-sort by calling vm-gobble-message-order in vm. VM 5.63 released (7 March 1994) * Shapiro typo fixes * dropped duplicate buffer suppression in vm-build-virtual-message-list; not currently needed and doesn't work anyway. * avoid globally setting tab-stop-list in vm-minibuffer-show-completions. * fixed free var ref "form" in vm-read-password. * dropped some unreferenced vars in tapestry.el * replaced (get-file-buffer buffer-file-name) with (current-buffer) in vm-get-spooled-mail, an obvious optimization. * check inbox against name and truename in vm-get-spooled-mail to avoid being tripped by find-file-visit-truename being non-nil and get-file-buffer's obliviousness thereof. VM 5.62 released (6 March 1994) * vm-burst-digest was honoring vm-delete-after-bursting in the real folder instead of the virtual one; fixed. * vm-add-message-labels didn't work in a virtual folder because vm-label-obarray was uninitialized; fixed. * onw -> one in vm-visit-folder-other-window * vm-get-new-mail, and vm-save-folder now map themselves over the associated real folders when applied to a virtual folder. * since vm-save-folder now has a meaning when applied to virtual folders, vm-save-and-expunge-folder works for virtual folders. * moved (intern (buffer-name) vm-buffers-needing-display-update) into vm-set-buffer-modified-p and out of vm-save-folder. * incremented vm-modification-counter in vm-toggle-virtual-mirror. * incremented vm-modification-counter in vm-build-virtual-message-list. * fixed vm-su-line-count to use the real message offsets, not the virtual message offsets. * fixed expunge in unmirrored virtual folder to remove virtual messages from the virtual message list of the real message. VM 5.61 released (3 March 1994) * moved vm-session-initialization and vm-load-init-file to vm-startup.el so as to avoid autoloading vm-folder.el for M-x vm-mail. * removed call to vm-follow-summary-cursor from vm-mail so as to avoid autoloading vm-motion.el for M-x vm-mail. * added L to regexp string in vm-compile-format. * changed vm-error-if-folder-empty to complain about the folder type being unrecognized if that is the reason the folder is deemed empty. * changed modeline to reflect the "unrecognized folder type" condition. * use epoch::selected-window instead screen-selected-window if it is fbound. VM 5.60 released (1 March 1994) * vm-set-edited-flag -> vm-set-edited-flag-of * forgot to fix interactive spec of vm-yank-message; fixed. * vm-search18.el: signal error if vm-isearch is attempted in a virtual folder. VM 5.59 released (26 February 1994) * was calling pos-visible-in-window-p in wrong window in vm-scroll-forward; fixed, which takes care of preview/scrolling problems introduced in VM 5.58. * fixed interactive spec of vm-yank-message-other-folder * call vm-yank-message with only one arg in vm-yank-message-other-folder * made vm-help-tale be a little less rude. * '?' gives help in vm-read-string * dropped top level requires in favor of autoloads * use vm-selected-frame everywhere, instead of error-free-call * do multi-screens in Lucid Emacs like multi-frames in FSFmacs. VM 5.58 released (26 February 1994) * New variables: + vm-included-text-headers + vm-included-text-discard-header-regexp + vm-summary-highlight-face * New commands: + vm-add-message-labels (la) + vm-delete-message-labels (ld) + vm-virtual-help (V?) * new semantics for vm-yank-message * lookup vm-spool-move-mail and vm-pop-move-mail in file-name-handler-alist. * set stop-point properly if using marks in vm-auto-archive-messages. * in Makefile rm -f vm-search.el to evade a read only copy. * don't assume the subject thread obarray is setup properly or ditto for the message id thread obarray. User may have interrupted the thread build and screwed things up. * V? gives some help for V commands. * put ... after mark help. * Shapiro typo fixes. * switch to virtual buffer before comparing edited message to current message. also compare the underlying real messages instead of the possibly virtual ones. this makes the current message be repreviewed appropriately if it is virtual. * don't generate a summary in vm if recover-file is likely to happen, since recover-file does nothing useful in a summary buffer. * changed VM to use \040 instead of \020 in babyl attribute parsing code. obvious error in babyl spec. * small change to vm-minibuffer-complete-word to handle label reading. since we don't demand a match for label reads, we have to let the user insert a space for multi-word reads. * undo now says what it is doing. * undo now moves the message pointer to the message that it is affecting. * fixed vm-scroll-forward to mark message as read _and_ scroll when point-max isn't visible on screen. should help with vm-preview-lines == t. VM 5.57 released (18 February 1994) * added missing refs to -other-window and -other-frame commands in root commands so that window configurations work. * shuffled targets in Makefile a bit. * integerp -> natnump in vm-start-itimers-if-needed * doc string updates. * added missing -other-frame to the send-digest commands that needed them. fixes the infinite frames, infinite recursion problem. * don't assume a match when descending a nested auto folder alist. * Shapiro typo fixes. * New commands: + vm-set-message-attributes (bound to `a') * made vm-auto-select-folder signal errors. * default value of vm-check-folder-types is now t. * fix modeline at end of vm-auto-archive-messages; vm-save-message whacks it. * use unwind-protect in vm-auto-archive-messages to make sure mode line gets fixed if there's an error. * deal with type 'unknown' in vm-save-message and vm-gobble-crash-box * warn user about unparsable filth at end of folder. * fixed typos of &optional in vm-startup.el * indicate when threading display is enabled in the summary modeline. * clear modification flag undos after saving folder. * always setting vm-system-state to showing is wrong; changed it back to the way it was before 5.56. * display sort keys in summary modeline when they are valid. * used more care when lambda-binding inhibit/enable-local-variables must be careful not to change buffers while inside such a let binding as it might screw users who set local values of those variables. VM 5.56 released (14 February 1994) * vm-save-folder no longer expunges, this also means that 'q' and 'S' keys no longer expunge. * New commands: + vm-save-and-expunge-folder + vm-quit-just-bury + vm-other-frame + vm-visit-folder-other-frame + vm-visit-virtual-folder-other-frame + vm-mail-other-frame + vm-reply-other-frame + vm-reply-include-text-other-frame + vm-followup-other-frame + vm-followup-include-text-other-frame + vm-send-digest-other-frame + vm-send-rfc934-digest-other-frame + vm-send-rfc1153-digest-other-frame + vm-forward-message-other-frame + vm-forward-message-all-headers-other-frame + vm-resend-message-other-frame + vm-resend-bounced-message-other-frame + vm-edit-message-other-frame + vm-summarize-other-window + vm-other-window + vm-visit-folder-other-window + vm-visit-virtual-folder-other-window + vm-mail-other-window * New variables: + vm-quit-hook + vm-digest-identifier-header-format + vm-confirm-mail-send * non-nil non-t vm-delete-empty-folders now means ask first. * select last message in real folder instead of first at startup if no unread messages are present (vm-thoughtfully-select-message). * in vm-get-spooled-mail expand inbox file name rooted in folder directory if path is relative. * don't do physical order sort unless moving messages physically in vm-sort-messages. avoids markers pointing to nowhere at virtual folder startup with the threads display enabled. * don't call display-buffer in vm-display-buffer unless vm-mutable-windows is t. * always set vm-system-state to showing in vm-show-current-message, even if message is not visible. The message-not-visible case is handled in vm-scroll-forward. * moved window config of vm-quit to the beginning of the command instead of the end. * added new window configuration action class: quitting * don't assume new and unread flags are mutually exclusive in vm-show-current-message, they aren't for babyl folders. * fixed tapestry-set-window-map to coerce Emacs into giving space to the right window in the root window case. Works for FSF v19 Emacs. * ignore trailing spaces in subject for threading and other "same subject" purposes. * changed call to vm-update-summary-and-mode-line to vm-preview-current-message in the new same-subject motion commands (oops). * gave vm-virtual-mode a docstring. * don't allow vm-auto-archive-messages to recurse if a message archives to the same folder that it currently lives in. * slightly restructured modeline to deal with new and unread flags both being set in babyl messages. * burst digest fixes for From_-with-Content-Length and babyl folders. * make require-final-newline be buffer local in VM buffers. * don't set vm-block-new-mail in vm-mode-internal; it messes up the value set by the file recovery code. * dropped frame configuration part of VM window configuration code. too restrictive. * use vm-default-folder-type in vm-save-message for empty folders. * don't use sets for marking messages for summary updates; just consing up a list is much faster and the dups don't matter much with the speedy new summary code. * use an obarray for vm-buffers-needing-display-update * dropped sets.el from the distribution. * put cursor in the To header for vm-resend-bounced-message. * don't do Berkeley Mail compatibility stuff unless the current folder type is From_. * use unwind-protect in vm-stuff-attributes to make sure folder modified status is reset properly on non-local exit. * don't change modflag-of for virtual messages in vm-build-virtual-message-list; virtual messages don't use this flag anyway. * added a level of indirection for virtual-messages-of so print will work on a message struct. VM 5.55 released (9 February 1994) * vm-set-babyl-frob-flag -> vm-set-babyl-frob-flag-of * rewrote vm-delete-duplicates again; this one doesn't pitch the full names in hack-addresses mode. * made vm-get-header-contents put grouping ^\(...) around the header name regexp instead of just prepending ^. * vm-yank commands now in the composing-message action class. * made use of the bundled reporter.el and timezone.el optional in Makefile. * New commands: + vm-next-message-same-subject + vm-previous-message-same-subject * fixed bug in vm-assimilate-new-messages; work was being done to a virtual folder even if no new messages were added. * internal thread tree is now built on demand. * some mods to vm-sort-messages to deal with calls by threading code and values of vm-folder-read-only and vm-move-messages-physically. * moved scattered autoload defs into vm-startup.el. * doc string updates. * errors from call to vm-expunge-folder are no longer ignored in vm-save-folder. * default window configuration now uses the split screen mode for everything. * dropped the skip-newlines-at-top-of-folder code. * dropped single quotes from around sed command; unneeded since we're not calling the shell. * made vm-change-folder-type work; fixed babyl related problems along the way. * run copy-sequence on new-messages before sorting in vm-assimilate-new-messages to keep sorting from scrambling the value we need to return. * fixed bugs in vm-convert-folder-type; have to be careful about update order since some code depends on correct separator strings being present. * added special code to the POP mail retriever needed for babyl crash boxes. * block mail new mail retrieval while we're getting new mail; timer processes might be fired up while the POP code is running. * added another missing set-buffer-modified-p in vm-gobble-crash-box. VM 5.54 released (4 February 1994) * made vm-discard-cached-data fill the cache with nils instead of allocating a new array. necessary so that the virtual messages get their caches wiped too. * vm-edit-message now unhightlights the edit buffer. * moved unthread/rethread stuff from vm-edit-message-end to vm-discard-cached-data. * removed thread data prerefs from vm-edit-message and vm-discard-cached-data; I no longer think they are needed. * changed emacs to $(EMACS) in Makefile for make-autoloads run. VM 5.53 released (3 Feburary 1994) * got rid of reuse of count variable in vm-delete-message; used del-count instead. this was hosing motion after vm-delete-message-backward. * fixed bugs in vm-delete-duplicates; was calling vm-delqual with an unfrobbed list of addresses; if 'all' was non-nil was resetting list and setcdr'ing prev inappropriately. * Shapiro typo fixes. * fixed vm-set-xxxx-flag to not add to the undo record list twice; more confusion due to virtual folders. VM 5.52 released (3 February 1994) * BABYL file support. * fixed noautoload target in Makefile to depend on reporter.elc. * actually put the reporter.el file in the distribution (oops) * fixed vm-set-xxxx-flag to notice the real message when a virtual message flag is set. * added loop detection code to vm-thread-list. * added 'redistributed' message attribute, because BABYL files support this. vm-resend-message makes a message 'redistributed'. * %A summary format spec now seven characters wide instead of six. * no longer set vm-message-pointer in composition buffers. It doesn't look like it's used anywhere anymore. * needed make-local-variable calls in some places in vm-reply.el to avoid referencing a global variable. * don't auto-get-new-mail if vm-folder-read-only is non-nil. * don't try to startup folder read only for vm-yank-message-other-folder. * fixed logic error in vm-assimilate-new-messages; if real folder was empty; the first new messages that arrived would not be offered to virtual folders for assimilation. * fixed logic error in vm-build-virtual-message-list that causes new message list not to be installed into an empty virtual folder if vm-build-virtual-message-list was passed a message list. * added some code to vm-save-message and vm-assimilate-new-messages to get the message pointer set properly when live folders inherit their first message from another folder. * rewrote vm-delete-duplicates to use an obarray. * fixed another file name expansion in wrong dir problem in vm-save-message. * fixed bug in vm-pop-move-mail; needed (car (cdr ...)) instead of (car ...) to get password from assoc list. * unhighlight text copied into composition buffers. * use mail-position-on-field in vm-send-digest. * anonymous virtual folders now can acquire new messages when their real folders do. * drop error free calls in vm-window-loop in favor of checking for only one window before doing a delete-window. Lucid Emacs blows away the containing screen if you delete the last ordinary window. * preserve buffer modified status of virtual folder after erase-buffer call in vm-do-needed-mode-line-update. * replaced timezone-floor with Kanazawa Yuzi's fixed version. * don't makunbound unless there are no message left with a subject; previously it was done when there was one message left that was a child of the subject, which was quite wrong. This required keeping track of every message with a particular subject, which wasn't being done before. * reset thread-indention-of cache and thread-list-of in vm-unthread-message * move vm-keep-mail-buffer further down in vm-mail-send so that attribute update code can do its work before the buffer potentially goes away. * fixed logic error in vm-save-message; non-conversion error message check was reversed regarding virtual messages. * made vm-save-message report the number of messages saved, * made vm-delete-message and vm-undelete-message report the number of messages deleted/undeleted if marks are used. * made vm copy the read-only state of a visited folder--- if the file was read-only when vm first visits it, the folder will be read-only, too. * added read-only flag to vm-mode; prefix arg interactively. * New variables: + vm-summary-subject-no-newlines + vm-keep-crash-boxes * New commands: + vm-toggle-virtual-mirror + vm-change-folder-type * virtual-messages-of in real message was not being updated for non-mirrored virtual folders... wrong wrong wrong. fixed. * vm-stuff-virtual-attributes was stuffing the data using the header offsets of the virtual message instead of the real message's offsets... (woo, woo!) fixed. * doc string fixes * preserve summary buffer modified status when doing summary buffer updates since it's supposed to reflect the folder buffer's status. * moved vm-summary-redo-hook run to be in the summary buffer. * made unmirrored virtual message not share a summary with real messages (oops). * moved vm-su-summary preref to fill the cache out of vm-mark-for-summary-update and into vm-stuff-attributes. * changed vm-check-for-killed-summary to be a function, and made it reset su-start-of and su-end-of of all messages if the summary buffer has been killed. * changed thread indent calculator to start counting from the first ancestor that is in the current folder, instead of always counting from the root message. * set require-final-newline to nil for vm-mode buffers. needed for babyl folders. * added more test data to detect brokenesses in mail-extr.el. VM 5.51 released (29 January 1994) * docstring fixes. * fixed logic behind how schedule-reindents is set in vm-build-threads; startup with ought to be somewhat faster. * check for vm-message-pointer == nil in vm-sort-messages to avoid problems when sorting by thread at startup. * added reporter.el to distribution. * changed %* to %+ in modeline in hopeful anticipation of this being added to v19 Emacs. * made sure summary modflag was updated after folder saves; needed to add folder buffer to vm-buffers-needing-display-update. * changed vm-force-mode-line-update to use force-mode-line-update if it is bound. * made vm-make-virtual-copy restore the modified status of the virtual folder buffer after doing the copy. VM 5.50 released (28 January 1994) * found and fixed another bug in the threading code that can cause looping; interned a symbol into the wrong obarray. * made vm-save-message-sans-headers remember that last file written to, and not claim that a file was written to when it wasn't. * made vm-save-message not claim that a folder was written to when it wasn't, and to not visit files, check folder types and so on when the prefix arg given was 0. * fixed doc for vm-summary-uninteresting-senders; pointer -> arrow. * made sets-typetag be defvar'd instead of defconst'd. avoids trouble if sets.el is reloaded. * fixed expunge; it was checking for virtual message after the virtual message list of the message had been emptied. * fixed vm-build-virtual-message-list; when new messages were assimilated, the old message list overlapped the new causing duplicates in vm-virtual-messages-of. * dropped the rest of the undocumented stuff for hilit19. VM 5.49 released (25 January 1994) * changed timezone.el not to call abs directly. * changed vm-mail-send-and-exit to notice if it's no longer in the composition buffer after vm-mail-send and not to bury whatever buffer it happens to be in. * changed make-autoloads to use Lisp, create proper interactive autoloads and to include the doc strings. * cached date of oldest message in a thread; thread display now sorts threads in chronological order of the oldest message known to have been in the thread during this VM session. * fixed threading by subject bug, that I suspect caused endless looping in some folders. * fixed some of the problems with vm-mutable-windows non-t non-nil; most in tapestry.el; one in vm-window.el. * doc fix in vm-summary-format var doc, h -> H. VM 5.48 released (23 January 1994) * @cp -> cp in Makefile. * fixed bug in vm-load-window-configurations where vm-window-configurations is set to t. * Shapiro typos fixes. * added timezone.el to the distribution. VM 5.47 released (23 January 1994) * vm-window-configuration-file now has a default value of "~/.vm.windows". * vm-default-window-configuration is now used if reading a configuration failed. previously it would not be used if the file vm-window-configuration-file pointed to did not exist or was empty. * expunge caused highlighted area to move over to some unwanted areas of text. made highlighting function nuke the face property of the whole message to try to clean this up before the user gets to see it. user will still see it during searches, oh well. real fix is for Emacs to move the properties when the text shifts because of insert/delete, which I think Emacs will do in the next release. * first crack at thread support. New variables: + vm-summary-show-threads + vm-summary-thread-indent-level * vm-subject-ignored-prefix * vm-subject-ignored-suffix New commands: + vm-toggle-threads-display (C-t) + vm-goto-parent-message (^) + vm-mark-thread-subtree (M T) + vm-unmark-thread-subtree (M t) * Variables that went away: + vm-summary-show-message-numbers * summary format specifiers %n and %* are allowed again. * added slot in message struct for the summary to use for its padded copy of the message number. everything else uses the unpadded number. * fixed vm-expunge-folder; a couple of problems with initiating expunges from a virtual folder--- some stuff was being done twice, and the physical expunge was occurring in the virtual buffer instead of the real buffer. * gave vm-mark-for-summary-update an optional arg that says "don't kill the summary entry cache". this is used by thread and marks commands, which don't change anything that the summary entry could cache. * vm-visit-virtual-folder, vm-get-new-mail and vm-burst-digest work harder at keeping the totals blurb on the screen in the face of autoload messages, summary status, etc. * made vm-set-numbering-redo-{start,end}-point update vm-buffers-needing-display-update. * made vm-undisplay-buffer not use save-excursion, which apparently does a switch-to-buffer in v18 Emacs. * made vm-undisplay-buffer not select a dead window, since this can crash v18 Emacs. Rewrote it to use vm-delete-windows-or-frames-on which already has the smarts about not selecting dead windows. * don't emit totals blurb in vm unless it's a full startup. cured problem of calling (message ...) when totals-blurb is nil. * changed call to buffer-disable-undo to use fboundp to check first, and call buffer-flush-undo if it is not fbound. * disable undo in the summary buffer. * updated vm-mode doc with missing variables and keys. * changed make-autoloads to create proper autoload defs for macros and to trim the suffixes from the file names. * folder is now expanded properly in vm-visit-folder before calling vm. * if call of read-file-name with five args fails (v18 doesn't take the INITIAL-INPUT arg) call it with the expansion dir set to what would have been the fifth arg. * Shapiro typo fixes. * don't signal error in vm-expunge-folder if there are no deleted messages. * fixed summary rebuild problem in vm-expunge-folder related to virtual folders. * changed vm-kill-subject to use vm-so-sortable-subject * added new action class "marking-message" and put the mark and unmark commands in it. * some of the motion commands now follow the summary cursor. * dropped a bit of stupidity at the end of vm-next-command-uses-marks; why o why was I prereading the next input event? * fixed message assimilation into virtual folders. * made vm-move-message-forward silently not try to move a message physically if it's in a virtual folder. * updated documentation for vm-get-new-mail. * dropped the refcard from the distribution. * if summary format doesn't match the cache summary format, force a restuff of the cache of all messages when the folder is saved. VM 5.46 released (17 January 1994) * added header highlighting for FSF Emacs 19. + slightly different sematics for vm-highlighted-header-regexp to match the new header name matching rules. + new variable vm-highlighted-header-face to specify what face to use for highlighting. * fixed make-autoloads to create autoloads pointing to .elc files instead of .el files. * updated laggard copyright notice in startup message. * chopped out undocumented hook for hilit19 in vm-preview-current-message. VM 5.45 released (17 January 1994) * Shapiro typo fixes * editing a message that already had an edit buffer caused window config failure; window config code couldn't find the edit buffer, because the current buffer was not the edit buffer. fixed by calling set-buffer for this case in vm-edit-message. * dropped unneeded calls to vm-previous-window in vm-window.el. calling (next-window w 'nomini) is sufficient to avoid the minibuffer and to avoid drifting into another frame while evading the minibuffer. * make vm-next-message do its own window configuration when called by vm-delete-message and others, so auto-motion pops up the correct configuration. * VM now has a default window configuration. * the unwind form in set-tapestry could select a dead frame; we now check with frame-live-p before selecting the saved frame. * removed the kludge from tapestry-set-frame-map, it didn't work reliably anyway. * changed vm-undisplay-buffer not to delete a frame unless there only one window in it. * VM now autoloads all of its modules on demand. some functions moved to different modules for better locality of related functions. some care given to how display update lists were built so as to avoid calling summary update functions on messages that actually are part of a folder that does not have a summary. Turned out mostly to be a waste, the summary gets loaded almost immediately unless serious contortions are made. * New files: make-autoloads - build the autoload defs vm-startup.el - contains all VM entry point functions vm-minibuf.el - contains most of VM's minibuffer read functions. * work harder at vm startup to keep the totals blurb on the screen despite all the autoload tripe blasting the minibuffer. * added a documented cardinality function to sets.el. * made vm-emit-eom-blurb not call vm-su-full-name, which avoids dragging in the summary code unnecessarily. * check for killed folder buffer in vm-mark-replied and vm-mark-forwarded to avoid trying to set-buffer to a killed buffer. * moved a ( in a docstring right to avoid it being in column 0. VM 5.44 released (16 January 1994) * fixed free variable reference (length) in vm-edit.el. * added a few missing commands to the supported window configurations list. * wrapped call to mail-send in save-excursion to protect against a buffer change. * moved call of vm-rename-current-mail-buffer in front of vm-keep-mail-buffer so that if vm-keep-sent-messages is nil we won't rename some random buffer because the current buffer had been killed. * added doc for vm-submit-bug-report to vm-mode doc. * added optional first argument to tapestry which allow specification of which frames to return info about. * made vm-save-window-configuration record configuration info only about the selected frame if vm-mutable-frames is nil. * %* format spec no longer allowed in summary format, for the same reason the %n spec was disallowed. * made the "get new mail" call of vm-assimilate-new-messages in vm not read message attributes, so we don't inherit X-VM stuff from messages sent by others. * was calling select-frame in set-tapestry, changed to call tapestry-select-frame instead. * made tapestry and set-tapestry no change Emacs' idea of what the selected-frame is. * made vm-set-window-configuration more friendly to errors + if the window config requires a summary buffer and none is present and the folder buffer isn't displayed either, then display the folder buffer where the summary would have been displayed if it existed. + if the window config requires an edit, composition, or summary buffer and it is not present, delete windows and frames that would have displayed it. * moved "hide" check in vm-scroll-forward to be prior to the first usage to the window we're checking. * Shapiro typo fixes, as usual, sigh. * more virtual folder selectors * made virtual folder selectors that require dates be more flexible and fill in incomplete date specifications. * removed redundant and incorrect calls to vm-check-count from vm-mark-message and vm-unmark-message. * fixed bug in vm-timezone-make-date-sortable; used car to access chace when should have used cdr. * New commands: + vm-mark-matching-messages + vm-unmark-matching-messages + vm-create-virtual-folder + vm-apply-virtual-folder * default value of vm-virtual-mirror is now t. * added missing mapping of vm-virtual-mode to `message' in vm-set-window-configuration. * fixed sent-before and sent-after selectors to call vm-so-sortable-datestring instead of vm-so-sortable-date. * modeline indicates folder virtuality by surrounding the buffer name with parens, eats less space than "virtual " particularly when the folder are nested. * fixed vm-beginning-of-message and vm-end-of-message so they again work when invoked from the summary buffer. * added vm-beginning-of-message, vm-end-of-message, and vm-expose-hidden-headers to the reading-message action class. * changed vm-expose-hidden-headers to force the displaying of the folder buffer. * changed calls of get-buffer-window to vm-get-buffer-window so that searches for buffers in windows fan out to all frames when it is appropriate. * added let-bind of buffer-read-only to nil around call to erase-buffer in vm-do-needed-mode-line-update. * rewrote vm-mark-for-summary-update again, and hopefully got it right this time. * fixed problem in vm-virtual-quit; vm-message-list needed to have expunged messages stripped before vm-message-pointer was rehomed there. virtual folder can now shrink to 0 messages without errors. * fixed some bad logic in vm-assimilate-new-messages that caused the summary to be rebuilt every time you ran M-x vm. VM 5.43 released (14 January 1994) * changed another reference to window-frame in tapestry.el that I missed, sigh. * added vm-mutable-frames to var list in vm-submit-bug-report * put vm-edit-message-end and vm-edit-message-abort into the reading-message and startup action classes. * changed vm-set-window-configuration to bail if the current buffer isn't a VM related buffer. * changed vm-set-window-configuration to create some descriptive buffers when a configured buffer can't be found, to let users when they've flubbed the window configuration setup. * made vm-convert-folder-header-types a bit more robust * made vm-find-leading-message-separator go to point-max for From_-with-Content-Length folders if no separator is found just as it does for the other folder types. * made vm-edit-message-end properly recompute the Content-Length header for the From_-with-Content-Length type. * made vm-edit-message-end munge message separators that it finds in an edited message before the message is reincorporated into the folder. * made vm-convert-folder-types munge message separators of the new folder type as part of the conversion process. * Greg Shapiro's and Andy Scott's typo fixes * %n spec is gone from the summary format; new summary cache code would cause the messaage number to be cached and this caused many problems. * New variables: + vm-summary-arrow + vm-summary-show-message-numbers * New command: + vm-forward-message-all-headers VM 5.42 released (13 January 1994) * made tapestry-frame-map call tapestry-window-frame instead of window-frame directly, which bombs under v18 Emacs. * made vm-get-mail-itimer-function call vm-assimilate-new-messages with a first arg non-nil, so that attributes found in newly arrived messages will be ignored. * removed some local-set-key calls in vm-do-reply that I forget to take out. * dropped the keymap parent stuff altogether, mimic mail-mode bindings in VM's mail mode, use vm-edit-message-map and simply override text mode map or whatever, copy the vm-mode-map to create the summary mode map. * drop cat-chow from the variable list in vm-submit-bug-report. * added a salutation and subject to vm-submit-bug-report * corrected vm-edit-message-end typo in vm-vars.el * moved vm-isearch-forward back to M-s, took vm-isearch-backward off C-r. * vm-goto-message now does not follow the summary cursor if a prefix argument is given. * added vm-mail-send-and-exit to the reading-message and startup action classes. ought to keep the *scratch* buffer from popping after sending mail when reasonable window configurations are enabled. * New variables: + vm-trust-From_-with-Content-Length * signature now appears after forwarded messages and digests, instead of before them. * added tapestry autoloads. * removed more references to vm-ml-attributes-string * turned off modification flag in crashbox buffer after folder conversion to keep kill-buffer silent. * turn on Emacs 19 compatbility in vm-byteopts.el. VM 5.41 released (10 January 1994) * fixed "~/INBOX" dreg in vm-get-folder-type. * added more test data to detect for broken mail-extract-address-components implementations * added SHELL = /bin/sh to Makefile. * added a current folder buffer slot to message struct so that (marker-buffer (vm-start-of message)) is no longer necessary. * VM no longer changes the message pointer on async auto-get-new-mail unless the folder was previously empty. * VM now queries for a POP password if the password is "*" in vm-spool-files. * made vm-visit-virtual-folder honor vm-startup-with-summary. * older Lucid Emacs versions apparently don't have the improved insert-file-contents; changed test in vm-get-folder-type to deal with it. * took vm-yank-message-other-folder off C-c y. * some fixes for the keymap troubles + use keymap parenting when we can + vm-mail-mode-map + vm-edit-message-map * added support for the System V Content-Length folder type. * much work on the display code + added vm-display clearinghouse function for display work + per command window configuration support added. + weird window configuration related scrolling bugs fixed * New variables: + vm-mutable-frames + vm-display-buffer-hook + vm-undisplay-buffer-hook + vm-reply-ignored-reply-tos + vm-move-messages-physically + vm-tale-is-an-idiot + vm-summary-pointer-update-hook * Variables that went away: + vm-retain-message-order (message order is always retained now.) + vm-mail-window-percentage (have to use window configs for this now.) * frame support added to tapestry.el * file recovery and reversion now deals with virtual folders. * SPC now invokes completion in vm-read-string, which means minibuffer reads of sort keys now have completion on both TAB and SPC. * various minor contortions to quiet the compiler. + added some defvars + moved error condition puts to vm-misc.el + added a compile-time preloaded file vm-byteopts.el * added documentation for more VM entry points to README. * strip quotes from ends of full name in vm-su-do-author. * fixed attribute stuffing code to properly correct the changed value of vm-headers-of in all cases. * made sets.el use prin1-to-string instead of (format "%S" ...) since %S doesn't work under v18 Emacs. * save the correct modeline variables in vm-search18.el; vm-ml-attributes-string is gone. * change vm-su-do-month to avoid using all those symbols * rewrote vm-search19.el to work and work better. * vm-isearch-forward moves from M-s to C-s * vm-isearch-backward command created. * vm-isearch-backward on C-r * made the message separator string generator functions look at the local variable that they set. by looking at the wrong variable they used the wrong folder type. * added needed narrow-to-region to vm-pop-retrieve-to-crashbox so that folder type could be correctly deduced. * jwz improvements + fixed width hh:mm:ss + negative precision in summary spec means truncate from the right + vm-delete-duplicates rewritten to be slow (and not reorder elements) + vm-delete-duplicates also handles addresses specially if asked * fixed bug in vm-default-chop-full-name; it should result a non-nil value in the 'address' part of the list. * fixed typo in vm.texinfo * fixed unnoticeable bug in vm-set-{summary,numbering}-redo-start-point * fixed vm-expunge-folder to not do redundant sets of the summary and numbering start points. * fixed vm-expunge-folder to be lock out interrupts at appropriate places. * fixed vm-expunge-folder to expunge the real message when a mirrored virtual message is expunged. * changed vm-build-virtual-message-list to allow a list to be built from a virtual folder's message list by looking through it to the real messages underneath. This is a prelude to on-the-fly virtual folder creation. * added many new virtual folder selectors, including 'and', 'or' and 'not'. * vm-resend-message now strips the Sender header from the message. * vm-move-message-forward locks out interrupts in the right place to protect message list integrity. * fixed vm-sort-messages bug that caused it to put the message into the wrong physical order. * added two commands: vm-move-message-forward-physically and vm-move-message-backward-physically. * fixed bug in vm-resend-bounced-message; if it found no header separator line it would insert one in the wrong place. * new semantics for vm-startup-with-summary * entire summary entries now cached, which means almost now work to generate a summary at startup now. * VM now does summary, numbering and modeline updates even if it is quitting. virtual folder displays will be out of sync otherwise. * VM now ignores message attributes that arrive attached to new mail. * last vm-gargle-uucp dreg removed. * VM no longer sets inbox file permissions to 600. * added some undocumented hooks for hilit19.el until it starts using the proper hook variables. * added protection for the variable this-command to the (interactive) forms that needed it. * added protection for the variable last-command to the (interactive) forms that needed it. VM 5.40 released (21 December 1993) * made vm-edit-message-end preview if edited message is current; comparison bug caused it not to. * removed extra definition of vm-do-needed-mode-line-update * fixed mail-extract-address-components test code. * fixed problem with summary mode line not being updated if expunge empties the folder. * fixed Makefile install target to copy vm.info to $(INFODIR)/vm . * more doc corrections from Greg Shapiro. * fixed long line Summaries node in Info document. * fixed bug in vm-default-chop-full-name, should use list instead of cons for the return value. VM 5.39 released (21 December 1993) * sanity checked all bindings of case-fold-search. * sanity checked all searches for reasonable ambient values of case-fold-search. * adopted most of Kevin Rodgers latest round of changes to vm-su-do-author, to parse full names and addresses a bit better. * changed 'file' to 'folder' in vm-save-message to fix an invalid variable reference. * New variables: + vm-check-folder-types + vm-convert-folder-types * Variables that have gone away: + vm-gargle-uucp (wrote this for late eighties melee, things are different now) * added call to set-window-point in vm-preview-current-message so that window-point is set properly in time for a vm-howl-if-eom call from a parent function. * fixed set-xxxx-flag and vm-update-message-summary to create correct update lists taking into account virtual folders. The code wasn't quite right. * fixed vm-update-message-summary not to try to use buffer-name to determine if the vm-su-start-of is a live buffer. Just marker-buffer will do, apparently. Killing the summary should safe to do again. * added a vm-submit-bug-report command based on reporter.el. * emit totals blurb in various places before selecting a message to prevent the non-previewers from altering the new message count and confusing themselves. * checked for existence of vm-arrived-message-hook before running the loop. * put vm-howl-if-eom after the vm-update-summary-and-mode-line because the howl contains the message number and the correct message number may not be computed in some cases until after the update. * fixed many bugs with virtual folders. * incremented vm-modification-counter in vm-burst-digest which should make the totals blurb be recomputed; previous it wasn't. * removed a couple of (apparently) unneeded re-search-forward's in the message yanking code. * added X400-Received to a couple of the default header discard lists. * fixed POP retriever to check for servers that DON'T strip message separators. * -hooks vs. -hook; hobgoblins win. * added some defvars to quiet the v19 compiler (a little) * made vm-spool-move-mail kill the miserable buffer if nothing went wrong. * added doc string for vm-summary-mode-hook * added more general date parser * added 'H' (hh:mm) summary specifier * normalized vm-su-year, at least 3 or 4 digits always. * made vm-auto-archive-messages be applicable to marked messages only. * made MNMU == Mu, i.e. vm-unmark-message is applicable to marked messages. * made vm-next-message and friends applicable to marked messages. * incorporated typo and spelling fixes from Gregory Shapiro * fixed vm-get-folder-type to widen before trying to get to the beginning of the buffer. * updated README * change mode line update code to not create strings at every update. * changed update code to not rebuild the mode line regardless of whether it did or did not change. * fixed bug in vm-write-string; point was not supposed to be restored on exit. * fixed bug in vm-save-message; said write-region when I meant insert-buffer-substring. * used new insert-file-contents features in v19 Emacses to replace running sed. * called vm-su-from instead of vm-from-of in vm-rfc1153-or-rfc934-burst-message; vm-from-of can be return nil. * fixed vm-leading-message-separator and vm-trailing-message-separator to use the right type variable. * made nil an allowable value for vm-forwarding-digest-type. * changed vm-stuff-attributes to use insert-before-markers which should keep the attributes headers from leaking into view. (window-start is a marker you see and ...) * changed the RFC 934 digest banners messages, they were scaring the tourists. * changed dashes to spaces in mode line. * 'make' != 'make all' in Makefile anymore * Info file created is now named vm.info. VM 5.38 released (16 December 1993) * made vm function check vm-block-new-mail before calling vm-get-spooled-mail and thereby avoid having an error signaled after M-x recover-file. * putting a call to vm-howl-if-eom into vm-show-current-message was a mistake. moved to vm-scroll-forward, which is a better place for it. * changed vm-delete-message to really honor vm-circular-folders if vm-move-after-deleting is nil. Also fixed a similar problem in vm-undelete-message, plus a typo where delete was used when undelete should have been. * fixed vm-so-sortable-subject, needed case-fold-search set to t. * changed vm-pop-move-mail to clear the trace buffer before trying to open a connection. This is to prevent confusion about old output in the trace buffer. * fixed endless loop bug in vm-mail-yank-default that occur when vm-included-text-prefix is "". * changed folder parser back to just matching "From " for the From_ type. * New variables: + vm-summary-mode-hook + vm-summary-uninteresting-senders-arrow + vm-summary-mode-map * Slightly different semantics for vm-summary-uninteresting-senders. VM 5.37 released (15 December 1993) * fixed "wrong type argument" arrayp nil problem in vm-pipe-message-to-command. (m -> (car mlist)) * fixed "intersting" and "vm-message-type" typos in vm-summary.el * added a clarification about byte-compiler warnings in the README file and corrected a typo in an autoload line; one of the vm's should be vm-mode. * fixed vm-delete-window-configuration to actually read a window configuration. Not sure when this was broken or whether it actually ever worked! * fixed unescaped quotes in docstring for vm-summary-uninteresting-senders * made vm-edit-message be a bit more careful about what it sets the edit buffers local value of vm-message-pointer to be. * made the string returned by vm-safe-popdrop-string look a bit better. * added support for mail-default-headers * added defvars for mail-default-headers and mail-signature for v18 Emacs, to avoid referencing symbols with void values. * fixed bug in vm-resend-message that caused the first to the current message to be copied into the composition buffer. * fixed problem with vm-expunge-folder not updating the display after completing its work iff the current message was not expunged. * made vm-show-current-message not mark a message as read unless the folder buffer had a window opened on it. * added (vm-howl-if-eom) to vm-show-current-message now that it checks for a window. * prevent effects of vm-summary-uninteresting-senders from leaking into non-summary areas. * New variable: + vm-retrieved-spooled-mail-hook * added vm-last-save-folder internal variable to track the last visited folder and offer it as a default for the next vm-visit-folder. VM 5.36 released (14 December 1993) * no more marker sharing between message in real folders. Previously the start and end pointers were shared between consecutive messages. * changed vm-clear-all-marks only update messages that actually have marks, and only update the summaries of updated messages. * let* -> let in some places * dropped one *+ regexp from vm-kill-subject * vm-move-after-deleting non-nil and non-t means move as if vm-circular-folder is nil. * virtual-folders work now * vm-preview-lines == t means preview but display a windowful of text * fixed mark-even-if-inactive type in vm-reply.el; replies under transient mark mode should work now under FSF v19. * doc fixes and changes * fixed bug in vm-scroll-backward, numeric prefix args other than simple strings of C-u's were causing inappropriate forward scrolling. * removed strange no-op in vm-record-and-change-message-pointer * default value of vm-preview-read-messages is now nil. * call-process doesn't return a exit status in all Emacs, only check exit status of movemail run on those Emacses that return it. * digest code redone, refurbished. * RFC1153 digest support * more status messages at startup so user knows Emacs is still alive while visiting a large folder. * protected against letter bombs when vm-visit-when-saving is t. * grouping code is gone * New variables: + vm-forwarded-headers + vm-unforwarded-header-regexp + vm-forwarding-digest-type + vm-digest-burst-type + vm-digest-send-type + vm-rfc934-digest-headers + vm-rfc934-digest-discard-header-regexp + vm-rfc1153-digest-headers + vm-rfc1153-digest-discard-header-regexp + vm-auto-get-new-mail + vm-recognize-pop-maildrops + vm-jump-to-new-messages + vm-jump-to-unread-messages + vm-mail-mode-hook + vm-edit-message-hook + vm-resend-bounced-headers + vm-resend-bounced-discard-header-regexp + vm-resend-headers + vm-resend-discard-header-regexp + vm-init-file + vm-summary-uninteresting-senders + vm-summary-redo-hook + vm-reply-hook + vm-mail-hook + vm-resend-bounced-message-hook + vm-resend-message-hook + vm-send-digest-hook + vm-select-message-hook + vm-select-new-message-hook + vm-select-unread-message-hook + vm-arrived-message-hook + vm-visit-folder-hook * Variables that have gone away: + vm-group-by + vm-rfc934-forwarding + vm-edit-message-mode-map * timer based auto-retrieval of new mail implemented * 'vm' function cleanup and should protect and warn about precious auto save files. * dropped the vm-buffer-modified-p kludge * new semantics for vm-spool-files * M-x recover-file works properly in a VM folder buffer now. * fixed defvar of vm-spool-files so that VM can be dumped with Emacs. * vm-resend-bounced-message now has header trimming variables * vm-resend-message now has header trimming variables and works like other outbound mail commands. * regexps are now allowed in the HEADER-NAME field in vm-auto-folder-alist * when reading the folder name, vm-save-message now uses the default folder name as initial input if it is a directory. * VM now always stuffs attributes in vm-save-message; to do otherwise can cause the deleted' attribute to be saved sometimes. * change vm-save functions to update the summary as they work so that if an error occurs the display will be up-to-date. * ditched overlay-keymap * ditched header highlighting code * fixed vm-yank-message-other-folder to restore window environ before yanking the message. * fixed vm-pipe-message-to-command to save read its command in the right context. * made vm-save-message convert messages to the target folders format if necessary. * POP support via vm-spool-files * made how VM matches headers be consistent. Put a colon at the end of header names if you want exact matches, leave it off if you just want prefixes. VM 5.35 released (25 August 1993) * fixed vm-fsf-emacs-19-p to not confuse FSF Emacs with Lucid * changed code to deal with screen.el's rename to tapestry.el * set enable-local-variables to nil in vm-build-virtual-message-list * began work on code in vm-virtual.el to get virtual folders to work right. not finished yet. * expanded and reorganized message structure for virtual folders * added patch from jwz to use set-keymap parent in vm-edit-message under Lucid Emacs. VM 5.34 released (15 August 1993) * used -l texinfmt explicitly in Makefile to get texinfo-format-buffer loaded under Emacs 19.18+. * ditched use of vm-overlay-keymap in FSF 19 Emacs. * use unread-command-events for FSF v19 in vm-next-command-uses-marks * moved to using buffer-disable-undo rather than buffer-flush-undo; hooked them together for compatibility with v18. * set folder type in more places and allowed empty folders to match all types. * made vm-rename-current-mail-buffer look for Bcc header for possible addition to buffer name, before defaulting to the anonymous horse. * fixed vm-edit-message-end bug; needed to widen so insert-buffer-substring inserts the whole edit-buf into the folder buffer. * added a bunch of patches from Jamie Zawinski--- some for general VM bugs, some to let VM run under Lucid Emacs. - support for Lucid Emacs keymaps in vm-overlay-keymap - fixed some inadvertent free variable references - use % instead of mod to avoid getting clobbered by cl.el macros - check return status of movemail - support enable-local-variables for FSF19 and Lucid - use next-command-event if present for Lucid Emacs - bind zmacs-regions so that (mark) behaves like (mark t) - add support for mail-citation-hook for FSF19. - regexp fix in vm-compile-format that should fix a format bug as well at comply with whatever new POSIX regexp rot has come down the pike. * more regexp fixes so that Emacs won't take an eternity to start VM * vm.texinfo fixes * fixed logic error in dealing with vm-visible-headers and vm-invisible-header-regexp. If header was matched by both variables it would be displayed, which is wrong. VM 5.33 released (11 April 1993) * fixed "wrong type argument arrayp, nil" error when primary inbox is empty. * applied Frank Bresz's fix for vm-visit-folder expanding the minibuffer read filename in the wrong directory. * applied Jamie Z's fix for the old, old scrolling problem when scrolling from the summary buffer. * changed default value of vm-flush-interval to t. * fixed Makefile to say *.el instead of . so compilation will occur even if there are no .elc files. VM 5.32 released (2 March 1992) * changed `|' not to send the message separator strings to the command. * fixed bug in vm-parse-addresses; no longer considers an empty string or a string composed only of whitespace to be an address. * fixed bug in vm-compatible-folder-p; kill-buffer may make Emacs go to an random buffer. * reorganized the sources, moved everything out of vm.el so vm.el can be used as a temp file. VM compiles to one object file now. * Prefix arg to `c' (vm-continue-composing-message) now allows selection of unmodified Mail mode buffers. * Fixed the problem with the startup message appearing every time you invoked VM instead of just the first time. * Fixed problem with first message displayed at startup not having its headers highlighted properly. * axed the Full-Name header. * New variable: vm-mail-header-from * removed addresses from Cc that are already in To in replies. * window configurations - commands vm-apply-window-configuration vm-save-window-configuration vm-delete-window-configuration vm-window-help - variables vm-window-configuration-file * used $(EMACS) instead of emacs in the Makefile. * fixed bug in vm-save-message, needed to restuff deleted messages to suppress the delete flag. * New command: vm-mark-help * moved the license into the texinfo document, and made the license display code use the Info subsystem. * The Info document goes into the file `vm' now; the README and Makefile were changed to reflect this. * vm-visit-folder depended on insert-default-directory being non-nil in order to find folders in the folder directory. vm now temp bind default-directory to folder-directory to make sure that relative paths resolve in that directory. * VM now handles the in-reply-to argument to vm-mail-internal (oops). * Reply-To instead of Reply-to in outbound mail, a concession to broken mailers. * Fixed vm-grok functions to give up only in the case of MMDF folders. A nil value of vm-folder-type could confuse it otherwise. This is an interim fix. VM 5.31 released (31 March 1991) * kill-buffer in vm-parse-address may cause a change to a random buffer; added save-excursion. * moved vm-parse-addresses to vm.el, since it's used in the summary and in replies. * fixed problem with retaining correct message order across multiple saves and expunges. * no longer generate an empty In-Reply-To if mailer didn't provide message-ID. VM 5.30 released (26 March 1991) * vm-resend-message now inserts a Resent-To header. * changed default value of vm-visible-headers to show Resent-From and Resent-Date. * fixed bug in vm-thoughtfully-select-message, return value was sometimes incorrect. * fixed bug in vm-save-message, summary and message renumbering were being deferred too long in the destination folder when saving between visited folders. fix similar deferral bug in vm-burst-digest. * rfc822-addresses is no longer needed to support vm-reply-ignored-addresses. This should keep addresses from being stripped of comments inappropriately. * VM now reorders before grabbing the bookmark, as it should. * vm-mail-internal now subsumes the function of mail-setup so as to avoid some of the choices made in mail-setup. * removed the conditionals from around calls to vm-mail-internal since it cannot fail; vm-mail-internal no longer returns the token value of t. * centralized the code that removes duplicates from lists of addresses, message-ids, etc, and fixed a bug in it. * used duplicate removal code on address lists * in replies, if To is empty and Cc isn't then To = Cc, Cc = nil * used vm-parse-addresses in vm-su-do-recipients, which should do better than the simple address parser used there before. * vm-mail-internal now automatically adds a Full-Name header. * vm-flush-interval == t now means flush after every change * vm-save-message now check whether the per message modflag is set before stuffing the message attributes. * (setq file-precious-flag t) is no longer done by vm-mode-internal. * vm-reply puts together an appropriate Newsgroups header. VM 5.29 released (18 March 1991) * fixed References being inserted after mail-header-separator * made a couple of VM find-file-hooks not assume that because they've been installed vm-message-list has been initialized. * removed last of \\[...] usage; might as well be consistent since these things waste more time than they save. VM 5.28 released (16 March 1991) * fixed buffer renaming error; check for name collisions * vm-goto-message now tries to follow the summary cursor first; if it does, then it doesn't try to move again. * fixed another bookmark problem; problem really inside vm-expunge-folder, some variables needed to be set even if quitting. * removed the expand-file-name loop from vm-save-message, since it would loop endlessly if vm-folder-directory was a relative path name. * fixed code in vm-save-message that assumed some VM specific local variables would have sane values in a non VM mode buffer. * VM maintains the References header in replies. VM 5.27 released (14 March 1991) * fixed bug in vm-stuff-message-order; needed (cdr vm-message-list) instead of (cdr vm-message-pointer). * centralized code that VM executes once per Emacs session. * eliminated the need for immediately loading other libraries during the load of the main VM Lisp file, which should fix a bug in the Makefile. * cleaned up the vm function a bit, the code that tries to make make sure that the totals blurb in left at the bottom of the screen after startup is less grungy now. * fuzzier grouping, spaces at end of the subject and after re: are ignored. * killing a killed buffer breaks older versions Andy Norman's homebrewed kill-buffer function in gnuserv.el. VM no longer stimulates the bug. * fixed a couple of summary pointer update bugs in the VM isearch code. * better bindings for the mark commands. * vm-forward-message just calls vm-send-digest when user tries to use it with marks, instead of just chiding the user. * VM feeps even less on motion errors to avoid disturbing sensitive souls and sleeping spouses. * various documentation corrections * fixed bug bookmark bug; bookmark was being stuffed too soon, i.e. before messages were renumbered properly * when mail is sent the outbound mail buffer is renamed to "sent ..." to indicate that the mail has been sent. * New command: vm-resend-message * New command: vm-continue-composing-message * `|' uses marks now VM 5.26 released (6 March 1991) * vm-move-message-forward now sets the proper variables to get the message order saved. * fixed bug in vm-stuff-message-order; message numbers needed to be redone sometimes before saving. * fixed bug in vm-revert-to-physical-order, it was not recording the message order change properly either. * prefix arguments to vm and vm-visit-folder now cause VM to visit the folder read-only. * altered conditional in vm that decides whether to get new mail; * indiscriminately scrubbing slashes from reply buffer auto save file names proved to be a humorous mistake. I've decided that post-modification of the auto save file name is a bad thing, so VM doesn't do any of the scrubbing anymore. I leave it up to make-auto-save-file-name to do the right thing, since it's its job anyway. * documentation fixes in vm-reply.el * 'g' now switches to the primary inbox if you weren't there already and there is new mail. VM 5.25 released (3 March 1991) * got rid of vm-local-message-list and vm-local-message-pointer VM 5.24 released (2 March 1991) * New variable: vm-retain-message-order * New command: vm-move-message-forward * New command: vm-move-message-backward * VM finally gets doubly links message lists. vm-previous-message should be much faster on large folders now. * removed some unnecessary code at the end of the routine that reverts the message-list back to physical-ordering. * added missing function vm-delete-directories to vm-virtual.el * added `/' to the list of characters that get scrubbed out of the auto-save-file-name's of reply buffers. * added > description to the doc string of vm-mode. * move-after-deleting and move-after-undeleting now signal error only if non-interactive and not executing a keyboard macro. * New variable: vm-edit-message-mode-map * C-c C-c now works like C-c ESC when editing a message. * substitute-command-keys now used in vm-edit-message since it should be relatively cheap. * doc string correction in vm-delete-message. VM 5.23 released * fixed display bug with virtual folders; virtual folder would switch real buffers when changing messages but the display wouldn't display the buffer containing the new current message. * changed the vm-group-by algorithm; now uses buckets, should be much faster. * append a newline if necessary after inserting an edit buffer into the folder, to keep the message separator from becoming a part of the message. * Made the "No new mail" message go away after a while. * fixed bug where VM assumed buffer-file-name would always be non-nil. * fixed bug in vm-gobble-deleted-messages that caused VM via vm-expunge-folder to bomb on empty folders. * fixed another bug in vm-gobble-deleted-messages that caused it to mark a folder modified if an expunge was attempted on an empty folder. * further centralized summary updates and renumbering activities * couldn't remember why require-final-newline was set to nil in vm-mode and vm-virtual-mode buffers so I got rid of it. * "No new messages" -> "No messages gathered" in vm-get-new-mail. * made `g' go ahead and get new mail even if the current folder isn't the primary inbox. VM 5.22 released (beta-testable in Feb 22, 1991) * fixed obscure bug in vm-write-file-hook that might have bitten someone some day; vm-message-list vs. vm-local-message-list. * updated startup message and README to say where to send bug reports. * added support for timer based checkpointing. * New variable: vm-flush-interval * VM now gets along with revert-buffer and recover-file. * VM undo will now delete the auto-save-file when appropriate. * Folder saves with C-x C-s and C-x C-w don't get the -??- uncertainty indicators anymore. C-x s still does though, alas. * vm-set-buffer-modified-p changed to make the setting of the buffer's modification flag be tried first, so that file locking and file supersession threat aborts are handled cleanly. * added code (that really works) to clear the question from the minibuffer after vm-quit gets its answer. * tiny cleanup in mail buffer name used by vm-send-digest VM 5.21 released * the auto-save file name scrubber was broken. I also discovered that Emacs` aset function is broken. * vm-keep-sent-messages didn't quite work right; used rassq instead of memq... VM 5.20 released * fixed doc string for vm-scroll-forward and vm-scroll-backward * removed whitespace from auto-save-file-names in VM Mail Mode buffers. trimmed shell metacharacters as well. * fixed doc error for vm-resend-bounced-message (bound to M-r not C-r) * the default value of vm-confirm-quit is now 0. * corrected documentation on vm-confirm-quit. * variable initialization now in vm-vars.el * VM scroll commands, page narrowing functions and other functions that schlep about in the current message moved to vm-page.el. * New variable: vm-keep-sent-messages * VM now reports the "right" number of new and unread messages at startup, even if previewing is disabled. * added code to clear the question from the minibuffer after vm-quit gets its answer. VM 5.19 released * fixed bug in vm-gobble-deleted-messages that causes the summary to be botched if the first message was expunged and the second message wasn't. * call to vm-set-buffer-modified-p made clearer. * fixed bug in vm-expunge-folder and vm-update-summary-and-mode-line that caused a botched summary if all the messages in a folder were expunged. * moved the vm-version variable initialization into another separate file. * vm-save-folder is now more verbose when it does it's work. * vm-beginning-of-message and vm-end-of-message now push point onto the mark ring just like their beginning-of-buffer/end-of-buffer counterparts. * removed incorrect vm-system-state change in vm-beginning-of-message * vm-save-folder now handles prefix args like save-buffer does. * vm-mail now works if called before the rest of VM is loaded. VM 5.18 released * VM now ignores garbage (e.g. blank lines) at the beginning of a folder. * C-x C-s and C-x C-w will now save the folder if invoked from the summary buffer. VM 5.17 released * fixed bug in vm-build-=virtual-message-list that kept other virtual folder selectors from working.] * fixed bug in vm-get-new-mail when gathering messages from another folder instead of the spool. * added autoload for vm-visit-virtual-folder to vm.el * fixed bug in parsing of MAILPATH environmental variable. * fixed bug in vm-expose-hidden-headers; if message is unread body is not inadvertently displayed. VM 5.16 released * message structs are no longer directly self-referential. A symbol must now be dereferenced. This was done to allow the debugger to be used on VM. * vm-get-spooled-mail no longer assumes that there's always mail in an existing spool file. VM 5.15 released to the beta-testers * slight cleanup in vm-assimilate-new-messages * added some calls to vm-select-folder-buffer to some commands that needed it. Basically this means commands that call another command to do most of their work but do not call this second command interactively, which result in vm-set-folder-variables not always being called when it's needed. VM 5.14 released * New variable: `vm-delete-after-archiving' * New variable: `vm-delete-after-bursting' * VM now avoids the use of the default *mail* buffer. Outgoing mail buffers are given more descriptive names, and more than one can exist concurrently. VM 5.13 released * vm-kill-subject bug fixed; report of number of killed message was broken. * changed vm-message-list to vm-local-message-list in vm-do-summary VM 5.12 released * last couple of changes to the grouping code didn't make it into the previous patch. VM 5.11 released * added a check for a killed summary buffer to vm-group-message. * references to vm-local- variables still weren't right; there are now no references at all to their global counterparts. VM 5.10 released * grouping code wasn't setting vm-local- vars... this didn't generate an error when I tested it with a virtual folder, but better safe than... * summary code now tries not to do a total rebuild after getting new mail or expunging. This should give a considerable time savings on large folders. * another type of bounced message delimiter added to the searches in vm-resend-bounced-message. VM 5.09 released * New variable: `vm-folder-read-only' * removed all the "clever" code at the end of vm-quit that tried to do nice thing if we landed on a VM buffer. * vm-kill-subject now reports the number of messages that have been deleted. * fixed bug in implementation of vm-reply-subject-prefix; test condition was reversed, and the string-match for the prefix was not anchored at the beginning of the header contents as it should have been. * fixed problem where expunging immediately after C-x C-s would not show folder as being modified, even if some messages were expunged. * virtual folders - New variables: + vm-virtual-folder-alist + vm-virtual-mirror - New commands: + vm-visit-virtual-folder * vm-proportion-windows now handles vertical windows appropriately. * vm-expose-hidden-headers now automatically jumps to top of message. * VM no longer stuffs headers into expunged messages before saving the folder (oops). * fixed bug in handling of negative prefix arguments (broken everywhere). * fixed bug in the message save functions, last-command was being clobbered on interactive calls, which made the commands inapplicable to marked messages. * fixed bug in vm-delete-message-backward; vm-follow-summary-cursor was not being called. * vm-resend-bounced-message moved from C-r to M-r. * support for Grapevine added to vm-resend-bounced-message. VM 5.08 released * commands that send mail now inherit the default-directory of the folder buffer. * 86ed last paragraph of vm-burst-digest docstring left by an overzealous documentation Muse. * better error handling when getting months and month numbers. bogus Date: header shouldn't make VM explode now. * the code that supported vm-reply-ignored-addresses had a typo: "to" where "cc" should have been--- fixed. * fixed problem with *mail* buffer not being displayed after C-r (vm-resend-bounced-message). I believe this is in fact a bug in save-excursion. * New variable: vm-auto-folder-case-fold-search * Updated regexp that groks RFC 822 dates to reflect new policy as of RFC 1123, i.e. four digit year numbers. * vm-mail need not be invoked from within VM now. VM 5.07 released * purged the overlay-arrow filth, enough is enough. * changed incorrect reference to m to (car mp) in vm-write-file-hook. * removed incorrect call to backup-buffer in vm-gobble-crash-box * fixed full name parsing botch that left trailing quote on doublequoted names. * more virtual folders code added VM 5.06 released * vm-save-restriction modified to hide its uninterned vars in a (let ...) because the byte-compiler interns them. :-( * fixed problem with vm-resend-bounced-message; mail-header-separator was not being inserted into the message. * fixed another problem with vm-resend-bounced-message; code needed to be inside the save-restriction call instead of outside it. * some early virtual folder stubs added. VM 5.05 released * Changed vm-thoughtfully-select-message to rely on vm-system-state to determine whether to jump to a new message or not. Made mods to other VM function to insure the vm-system-state always has the right value. * New variable: vm-digest-preamble-format * New variable: vm-digest-center-preamble * cleanups in the header stuffing routines * added a modify flag to each message struct; should save time when saving by restuffing only those messages that need it. VM 5.04 released * fixed problem with the summary arrow drifting out of view in the summary window. * fixed problem with visible/invisible variables startup consistency checking. * disabled file locking in places where it is inappropriate; this should make startup a bit faster. * made vm-show-current-message do something sensible if a page-delimiter is at the beginning of the text portion of the message, and vm-honor-page-delimiters is non-nil. * made vm-honor-page-delimiters override the value of vm-preview-lines if honoring vm-preview-lines would require displaying past a page boundary. * fixed problem where VM wasn't detecting end of message when honoring page delimiters. * fixed problem with editing and already edited message not setting the buffer modification flag; also fixed similar problem with unsetting the edited flag. * added a page break indicator via overlay-arrow. The overlay-arrow vars are buffer local, so there shouldn't be any squabbles over their use. VM 5.03 released * fixed problem with point and the summary arrow not coinciding at startup. * MAILPATH again; bash doesn't use `%' as sh does, it uses `?'. * Changed Makefile. `make' alone no longer rebuilds the texinfo stuff; `make all' does that now. * Fixed Makefile; vm.info wasn't being saved after formatting (oops). VM 5.02 released * Changed defconst to defvar in the definition of vm-summary-format; this is a leftover from debugging. * Makefile wasn't loading ./vm.elc before forcing compilation of all modules. Depending on the circumstances an old vm.elc could be loaded with predictably bad results. * Added -q to Emacs invocations in Makefile to avoid grot in .emacs files. * New command: vm-delete-message-backward (C-d), a concession to RMAILoids. Maybe now they'll get off my BACK about this. :-) * doc corrections and additions * modified vm-su-do-author to handle double quoted full names better. VM 5.01 released * fixed MAILPATH parsing; forgot about "%message" stuff that could be tacked onto the end of the filenames. * added check to the mail gathering routines to make sure the folder types of the source and destination folders are compatible. * fixed bug involving vm-totals in vm-assimilate-new-messages. * doc corrections VM 5.00 released for alpha testing (sometime in 1990) * `t' now toggles exposing/hiding normally invisible headers. * VM now writes much more cached info into its data header resulting in much faster startup. * New variable `vm-invisible-header-regexp'. * Cached a regular expression that shows how to find the beginning of the reordered headers (assuming the user permits such cached data to be used, then VM won't reorder message headers every time a folder is visited. * Status and X-VM-... headers are now updated in place instead of always putting them at the top of the message. * vm-delete-header unused, went away. * Doesn't feep on "No next unread message." * `written' and `forwarded' attributes added. * macroized (if vm-mail-buffer (set-buffer vm-mail-buffer)) into (vm-select-folder-buffer) * modularized the header highlighting and folder buffer display functions. * fixed < and > to behave properly when invoked from the summary buffer. * vm-last-save-folder now gets the fully expanded version of the folder name. * vm-visit-folder now defaults to vm-last-save-folder if it is non-nil, and the user hits RET at the interactive prompt. * old vm-mode now vm-mode-internal; new vm-mode now interactively callable. * vm-get-new-mail now takes a prefix argument to mean gather mail from a user specified folder instead of from the usual spool files. * vm-auto-archive-messages now ask user confirmation before saving each message if given a prefix arg. * Fixed botched interpretation of Berkeley Status headers. * VM now loads ~/.vm the first time it is executed in an Emacs session. * New variable `vm-move-after-undeleting'. * Added a trailing slash to the if-all-else-fails setting of vm-spool-directory. * Fixed problem where the totals blurb would not be redisplayed after the copyright info if vm-startup-with-summary is t. * `vm' now only does (switch-to-buffer mail-buffer) if it was not invoked via vm-mode. * vm-howl-if-eom-visible has forsaken pos-visible-in-window-p in favor of just doing a scroll-up and howling if an error occurs. This obviates the need for vm-show-current-message to do a sit-for before calling vm-howl-... * Implemented the standard VM included text code as a call to vm-yank-message and a default yank function. This default yank function is not called if the user already has a mail-yank-hook in place. * If the FOLDER-NAME part of auto-folder-alist evaluates to a list, then it is considered to be another auto-folder-alist and is scanned like vm-auto-folder-alist. * New variable `vm-auto-next-message'. * New variable `vm-auto-center-summary'. * VM can now survive the death of its summary buffer. * VM no longer uses overlay-arrow; the summary arrow is now written into the summary buffer directly. * %t and %T now supported to show recipient addresses and full names in the summary. * vm-gargle-uucp extended to cover %t addresses. * New variable `vm-honor-page-delimiters'. * New variable `vm-reply-subject-prefix'. * vm-quit now squawks if invoked from a non-VM buffer. It used to just kill whatever buffer it was invoked from. * vm-folder-type now automated; is no longer a user variable. * message marks * the end of message notification has been removed. * group by recipient * New variable: vm-reply-ignored-addresses * `U' now marks messages unread. * skip variables value = t now means skip inappropriate messages dogmatically, no exceptions. Non-nil and non-t value now gives old behavior. * attributes are now stuffed before saving a message to a folder. * bookmarks * vm-yank-message-other-folder * support for MAIL and MAILPATH environmental variables * after getting new mail jump to the first unread message only if the last command executed was not a message scan command, e.g. vm-scroll-forward, vm-isearch-forward. * summary mode-line-format format now mirrors that of the folder buffer * vm-buffer-modified-p returns, folder buffer is now read-only. * 'L' now loads ~/.vm * vm-mode is quieter and less obtrusive now, vm now works with crypt.el and with vm-mode present in auto-mode-alist. * you can now save a message in a folder to that same folder, in effect duplicating it. * `M' format spec now gives numeric month. * message editing * `j' discards cache data * C-r (vm-resend-bounced-message). * New variable: vm-confirm-quit * New behavior for vm-visit-when-saving if it is non-nil and non-t. * `A' no longer archives messages marked for deletion. * prefix arg to vm-burst-digest now makes it copes with non-standard digests, at least to a certain extent. * New format spec %A gives longer attribute summary; less column overloading. ? vm-read-mh-folder gnu.emacs.vm.info started Feb 1, 1991 http://groups.google.com/group/gnu.emacs.vm.info/browse_frm/month/1991-02 VM 4.11 released May 30, 1989 (posted on comp.emacs) * VM has learned how to deal with MMDF folders VM 4.10 released May 23, 1989 (posted on comp.emacs) The first public release of VM http://groups.google.com/group/comp.emacs/browse_frm/month/1989-05 ------- Kyle Jones's note (written on Apr 27, 1997) The earliest record I have of anything VM related is April 1989. Sometime in the spring of 1989, I wrote the first version of VM and gave it to a few friends. The first net release was 4.10, sometime in June of that same year. All releases up to that point were to a small group of people, mostly college friends who I knew used Emacs. VM was originally written to run under GNU Emacs 18.52. I didn't seem to get seriously interested in supporting v19 GNU Emacs until the summer of 1993. 5.00 was a private alpha release, sometime in 1990 I think. I know that Jamie [Zawinski] was shipping VM with XEmacs as early as v19.9. But beyond that I have no idea. vm-8.2.0b/TODO0000755000175000017500000001323711676442161013270 0ustar srivastasrivastaThis file lists the bugs, feature requests and wishes for future versions of VM. If you are missing anything please let me know! ****************************************************************************** EVERGREENS There are some things which probably will never be fixed ... * Update the info file. News should also be there not in the NEWS file? * Cleanup and reorganize the code. * Better doc strings: VM has nearly none in the core, just my own extensions have been documented properly using "M-x checkdoc RET". * Enable sane extensions and configurations: The default should satisfy most people, but still allow one to disable what they dislike. * Integrate more extensions from others into the core. ****************************************************************************** BUGS The bugs which should be fixed before the next release: * Syncing with Mozilla-Status may corrupt folder The bugs that remain unsolved: * Sometimes the cursor is not restored correctly in GNU Emacs when visiting a folder multiple times during an Emacs session. * VM is dead slow in marking/deleting/... when a folder has thousands of messages. ****************************************************************************** ROADMAP The features planed for one of the next releases. The order hints on the priority, but it is no gurantee. * Folding of threads in the summary * Display draft status in the modeline. (partially done) * Break up the customize stuff into more and smaller sub categories. * GNU Emacs: does not highlight attachment buttons in compositions * Merge changes from the Debian package. * Some of the user defined summary functions should become internal ones. E.g.: has-attachments, text/html, size, draft, ... * Better HTML support for both displaying and replying, but probably not for composition as there is no urge to surrender here! There should be a test for w3m-emacs, w3, lynx, w3m and the best method should be selected by default if not configured by the user. HTML only messages should be converted to mixed/alternative parts by vm-assimilate-html-message. vm-mime-show-alternatives should probably be smart enough to display all but the chosen part as button. "D" should switch between mixed/alternative parts and the undecoded resp. button representation. * Click in mailto: link does not work when being used from w3 buffers. * Virtual selectors matching on specific mime parts, e.g. (vm-vs-text regexp): matching only text parts and those which can be converted to text. (vm-vs-attachment regexp): matching the disposition of parts * Improved (i)search support: Only text parts and certain headers should be searched and it should also work for virtual folders. We might utilize virtual folder selectors here. [1] * Better IMAP support, i.e. just fetch headers, sync, offline, search. It is really bad now and thus I do use Thunderbird at work! * Maildir support: It is a nice format and possibly can fix the problem of huge mail folders, as VM must not read the whole buffer into memory, just the index. Also it would allow for using external indexing tools like http://www.rpcurnow.force9.co.uk/mairix/ and make folders really virtual. * Virtual folders everywhere, i.e. only one physical folder. VM should not read the folder into a buffer, but only query relevant messages from an maildb-backend. * S/MIME PKI support. ****************************************************************************** REST The unsorted and remaining ones. * Marking + Delete is dead slow on folders with many (>2000) messages. * Shortcut to expunge a single message. From EU * Fix bugs when marking threads by "M T". Sometimes it misses some messages, IMHO ones of broken MUAs not setting the References: header, but hey we cannot fix them so let's work around them. * for text/alternative messages, when the plain text part is displayed internally, [add variable that will allow to] show icon for the html (or rich text) part, which will allow to delete it easily using $d. I now have to edit these by hand... * The binding of mouse-3 overrides the usual usage of mouse-3 which is very useful. An option to allow binding this menu to another key (C-mouse-3?) would be great. * when attachments appear with no empty line separating them from the text, the attachment icon appears on the same line as the text before it. this results in poor appearance (I think), Would be much nicer to show the attachment icon on a separate line, rather than continued on the last text line as now. * Typing h when in the presentation window makes vm display only a single windows with headers rather than adding a headers window to the presentation mode window. (when in vm, change to presentation buffer, type C-x1 and then h" * When reading mail I have the frame divided into three windows: headers, presentation and BBDB. When replying from the header window, the reply window just replaces the headers window, leaving the presentation window and the BBDB window unchanged. The resulting reply window is too small... would be good to have it replace all three windows (headers, presentation, BBDB) until the reply is sent. ****************************************************************************** REFERENCES [1] Newsgroups: gnu.emacs.vm.info Subject: Re: Improved search for mixed (mime) ascii/html folders? [2] Message-ID: <1159541555.884682.318660@c28g2000cwb.googlegroups.com> Newsgroups: gnu.emacs.vm.info Subject: VM feature requests Date: 29 Sep 2006 07:52:35 -0700 ;;; Local Variables: *** ;;; mode:text *** ;;; End: *** vm-8.2.0b/install-sh0000755000175000017500000001273611676442161014604 0ustar srivastasrivasta#!/bin/sh # # install - install a program, script, or datafile # This comes from X11R5 (mit/util/scripts/install.sh). # # Copyright 1991 by the Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. It can only install one file at a time, a restriction # shared with many OS's install programs. # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" mkdirprog="${MKDIRPROG-mkdir}" transformbasename="" transform_arg="" instcmd="$mvprog" chmodcmd="$chmodprog 0755" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" dir_arg="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -d) dir_arg=true shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; -t=*) transformarg=`echo $1 | sed 's/-t=//'` shift continue;; -b=*) transformbasename=`echo $1 | sed 's/-b=//'` shift continue;; *) if [ x"$src" = x ] then src=$1 else # this colon is to work around a 386BSD /bin/sh bug : dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 else true fi if [ x"$dir_arg" != x ]; then dst=$src src="" if [ -d $dst ]; then instcmd=: chmodcmd="" else instcmd=mkdir fi else # Waiting for this to be detected by the "$instcmd $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if [ -f $src -o -d $src ] then true else echo "install: $src does not exist" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 else true fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` else true fi fi ## this sed command emulates the dirname command dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` # Make sure that the destination directory exists. # this part is taken from Noah Friedman's mkinstalldirs script # Skip lots of stat calls in the usual case. if [ ! -d "$dstdir" ]; then defaultIFS=' ' IFS="${IFS-${defaultIFS}}" oIFS="${IFS}" # Some sh's can't handle IFS=/ for some reason. IFS='%' set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` IFS="${oIFS}" pathcomp='' while [ $# -ne 0 ] ; do pathcomp="${pathcomp}${1}" shift if [ ! -d "${pathcomp}" ] ; then $mkdirprog "${pathcomp}" else true fi pathcomp="${pathcomp}/" done fi if [ x"$dir_arg" != x ] then $doit $instcmd $dst && if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi else # If we're going to rename the final executable, determine the name now. if [ x"$transformarg" = x ] then dstfile=`basename $dst` else dstfile=`basename $dst $transformbasename | sed $transformarg`$transformbasename fi # don't allow the sed command to completely eliminate the filename if [ x"$dstfile" = x ] then dstfile=`basename $dst` else true fi # Make a temp file name in the proper directory. dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp && trap "rm -f ${dsttmp}" 0 && # and set any options; do chmod last to preserve setuid bits # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $instcmd $src $dsttmp" command. if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && # Now rename the file to the real destination. $doit $rmcmd -f $dstdir/$dstfile && $doit $mvcmd $dsttmp $dstdir/$dstfile fi && exit 0 vm-8.2.0b/README0000755000175000017500000001250711676442160013456 0ustar srivastasrivastaVM was written by Kyle Jones! Hail Kyle! The last release from Kyle was 7.19. VM's home page up to version 7.19 on the World Wide Web is at http://www.wonderworks.com/vm and the FAQ is still hosted there. The later versions of VM have been maintained by the user community. The current 'VM development team' (vm@lists.launchpad.net) consists of of Robert Widhof-Fenk, Ulrich Müller and Uday Reddy, but contributions from various other users and developers have also been incorporated in them. See the info manual for a full list of contributors. ******************************************************************************* VERSION INFO The VM versions 8.2.0 and up are designed to work with: - XEmacs version 21.4 or higher, with MULE support - Gnu Emacs versions 22 or higher (While Gnu Emacs 21 is permitted, it is not recommended.) The users of vcard's need a vcard.el package with vcard-api-version 2.0. (A suitable version of vcard.el is included in this distribution.) ******************************************************************************** INSTALLATION Read INSTALL and follow the instructions to compile and setup VM. If you are new to VM, see example.vm for example configuration settings (in a '~/.vm' file). Read more in the VM manual on 'info'. ******************************************************************************* BUGS Please report bugs in VM using the VM function M-x vm-submit-bug-report This function formats an email report including the entire state of VM which can be used to diagnose and fix the bug. Please include information about how to reproduce the problem. Please report any problems or bugs otherwise they cannot be fixed! If you are not sure that the problem is a bug or that it could be of general importance to other users, you are welcome to discuss it on the USENET groups gnu.emacs.vm.bugs or gnu.emacs.vm.info! However, it is not always possible to diagnose problems without full information about your VM settings. So, filing a bug report is necessary. ******************************************************************************* Homepage The new homepage of VM is at http://www.nongnu.org/viewmail/ hosted by Savannah. The latest downloads of VM can also be found here. The source code of VM is at http://launchpad.net/vm hosted by Launchpad. Eventually, we may migrate to a single site for both the facilities. ******************************************************************************* Wiki The Wiki at http://www.emacswiki.org/emacs/CategoryViewMail is best suited to conserve code snippets, cooking guides or feature requests. ******************************************************************************* Code Repository We maintain the source code using Bazaar (http://bazaar-vcs.org/). If you want to get the latest development version of VM, or want to contribute changes you may want to branch from the follwing launchpad URI: lp:vm which is short for the full URL: http://bazaar.launchpad.net/~vm/vm/trunk # create your own branch from the trunk # the 'lp' URL's do they same job as the 'http' URL's above. bzr get lp:vm # for the main trunk (or) bzr get lp:vm/8.2.x # for the latest version in the 8.2.x series # get updates bzr pull # start hacking emacs vm-pgg.el # commit your changes bzr commit # Generate a bundle of your changes for merging bzr bundle-revisions --output=xy-changes.diff # Attach the bundle to a mail (rather than doing cut&paste) and send # it to vm @ lists.launchpad.net with a descriptive subject. # Alternatively, upload it to your space on Launchpad bzr push lp:~username/vm/branchname # Then send a message to vm @ lists.launchpad.net requesting merge ******************************************************************************* Get involved The project home is at http://launchpad.net/vm Registering on launchpad is painless process and makes it convenient to participate in the development of VM (or other Launchpad projects). The "Bugs" tracker is where we keep track of the bugs that need fixing as well as TODO items. The "Blueprints" section records our future development plans. ******************************************************************************* COMMENTS In addition to Kyle Jones's original VM, this version includes various contributions from Robert Widhopf-Fenk and others. Extensions for VM written by Robert: - vm-pine.el for draft handling and other Pine inspired functions. - vm-ps-print.el for nice ps-printing functions - vm-rfaddons.el adds various add-ons to VM - vm-grepmail a grepmail interface for VM - vm-avirtual.el brings additional virtual folder selectors and functions for spam tagging - vm-biff.el is a xbiff within VM, notifying you of new mail - vm-serial.el templates for mails, personalized serial mails - vm-summary-faces.el face base on virtual selectors Additional extensions for VM from other people: - vm-pcrisis.el by Rob Hodges for people with personal crisis which need to rewrite headers automatically. - vcard.el by Noah Friedman for vm-vcard.el displaying vcards within VM. Enhancements: - Support for reading HTML messages using Emacs packages and external applications, as well as replying to HTML messages. - IMAP server support by Uday Reddy Local Variables: mode: text coding: utf-8 End: vm-8.2.0b/README.headers-only0000755000175000017500000000400411676442161016041 0ustar srivastasrivastaThe headers-only operation has an outstanding bug which occurs very infrequently and is difficult to track down. - It only affects the headers-only downloading of IMAP messages. All other features of VM are unaffected. - It has only been observed on Gnu Emacs 23. (There is a possibility that it has something to do with the Emacs 23 word-wrapping functionality, but that is only a guess at this point. If you turn on word-wrapping or visual-line-mode by default, you should remove the default because it will get used in VM folder buffers otherwise.) - Whenever the problem was observed, it caused the body of a message to be inserted in the *midst* of its headers instead of inserting it after the headers. An example follows. - The failure recovery is to delete or rename the imap-cache folder on disk and force VM to generate a new cache folder. (Renaming it is a better idea. You can then send me a sample of the error and I might be able to garner some information from it.) - Permanent damage can occur if you save a message from the IMAP folder to a local folder and delete the IMAP copy. If the message had corruption before you saved it, the corrupted copy would have been saved. So, keep an eye out for the problem whenever you save a message. ----- The problem should be normally visible. Here is an example: From: "Lucas, Simon M" <...> To: ... Subject: Re: Unemployment rate among CS graduates Date: Sun, 4 Jul 2010 16:09:35 +0100 X-SoCS-Spam-DQogT25lIG1vcmUgdGhpbmcgdG8gY29uc2lkZXIgd2l0aCB0aGVzZSBzdGF0cyBpcw0KIHRoZWly IHJlbGlhYmlsaXR5Lg0KDQogSWYgeW91IHNlbGVjdCBjb21wdXRlciBzY2llbmNlIGFuZCBzb3J0... The correct message should have been: From: "Lucas, Simon M" <...> To: ... Subject: Re: Unemployment rate among CS graduates Date: Sun, 4 Jul 2010 16:09:35 +0100 X-SoCS-Spam-Score: 0.0 DQogT25lIG1vcmUgdGhpbmcgdG8gY29uc2lkZXIgd2l0aCB0aGVzZSBzdGF0cyBpcw0KIHRoZWly IHJlbGlhYmlsaXR5Lg0KDQogSWYgeW91IHNlbGVjdCBjb21wdXRlciBzY2llbmNlIGFuZCBzb3J0 The body of the message got inserted 13 places above the correct position. vm-8.2.0b/INSTALL0000755000175000017500000001510511676442160013624 0ustar srivastasrivastaPRE-COMPILED BINARIES ===================== If you have downloaded binaries for Gnu Emacs version 22 or 23, you can unpack it to a directory, say ~/vm, and go to step (3) below. However, this build assumes that you are not using any supporting libraries such as BBDB, W3 or W3M. If you are using such libraries, please rebuild VM as indicated below. If you are using XEmacs, you need to do your own build. USING CONFIGURE =============== 0) autoconf: If you get VM from the revision control, the `configure' script is not included. You have to run `autoconf' to create it. If you got VM from a public release, you should skip this step. 1) configure: First you need to decide the various options. --with-emacs the emacs you will use to compile (can be a Unix path) --prefix the prefix for the installation (default /usr/local) --with-other-dirs the directories to use for loading any extra emacs-lisp libraries during compilation The default installation locations are as follows: a) GNU Emacs: lisp files goto ${prefix}/share/emacs/site-lisp, data files go to ${prefix}/share/vm, and doc files go to ${prefix}/share/doc/vm-X.Y.Z, and info files go to ${prefix}/share/info, (overridable with --with-lispdir=..., --with-etcdir=..., --with-docdir=... and --infodir=...). b) XEmacs: lisp files go to ${prefix}/lib/xemacs/site-packages/lisp/vm, data files go to ${prefix}/lib/xemacs/site-packages/etc/vm, doc files go to ${prefix}/lib/vm-X.Y.Z, info files to ${prefix}/lib/xemacs/site-packages/info, (overridable with --with-lispdir=..., --with-etcdir=..., --with-docdir=... and --infodir=...). Run M-x describe-installation in XEmacs for hints on where to install the files for XEmacs. NOTE: VM 8.1.1 and older versions used an option --with-pixmapdir, which is now replaced by --with-etcdir. ATTENTION: Files byte-compiled with GNU Emacs are NOT COMPATIBLE with XEmacs and you may experience strange problems during startup if you do so. Even between different versions of the same Emacs, there can be problems! EXAMPLES: a) GNU Emacs+BBDB users run: ./configure --with-other-dirs=/absolute/path/to/bbdb/lisp b) XEmacs+BBDB users run: ./configure --with-emacs=xemacs --with-other-dirs=/path/to/bbdb/lisp c) GNU Emacs+BBDB+Emacs-w3m users run: ./configure --with-other-dirs="/absolute/path/to/bbdb/lisp;/absolute/path/to/emacs-w3m" d) XEmacs with no additional packages ./configure --with-emacs=xemacs 2) make: Compile everything by running: make You may ignore the byte compiler warnings. However any messages from `make' indicate problems or deficiencies in the installation, such as missing libraries. 3) Installing the files a) To use VM from the built directory You can use VM directly from the directory where you built it, without any further installation. To activate VM, follow these steps: Add the "lisp" and "info" directories in the VM built directory to the Emacs search paths, e.g. if you have built vm in ~/vm, add the following to your ~/.emacs or ~/.xemacs/init.el files. (add-to-list 'load-path (expand-file-name "~/vm/lisp")) (add-to-list 'Info-default-directory-list (expand-file-name "~/vm/info")) IMPORTANT: If there are any old VM-related autoloads in your emacs init file, you should remove them. The current version of VM takes care of its own autoloading. GNU Emacs: Load the autoloads by hand by adding (require 'vm-autoloads) to their ~/.emacs. XEmacs: Since XEmacs has a built-in distribution of VM, you have two options. (i) You can delete the built-in package in the XEmacs xemacs-packages directory. Then the new copy of VM in ~/vm/lisp will get loaded. (ii) You can include the following line in your ~/.xemacs/init.el file: (load-library "~/vm/lisp/auto-autoloads") Info files: Add the following lines to the `dir' file in your user-maintained info directory. If you don't have one, you can create a new `dir' file in ~/vm/info. * VM: (vm.info). VM Mail Reader * VM-PCrisis: (vm-pcrisis.info). Personality Crisis package for VM Note that vm-pcrisis is a separate add-on package (not officially a part of VM). b) To use VM from system directories: Run make install This will install VM files in the locations chosen in the `configure' step. You are now ready to use VM. C-h i should start up the Emacs Info system. If you have installed the Info documents properly, you can use the online documentation to teach yourself how to use VM. COMPANION PACKAGES ================== VM uses companion packages for address book maintenance and HTML display. VM will work fine even if the companion packages are unavailable, but the best functionality is obtained with them. * BBDB or "Big Brother Insidious DataBase" is an address book application that runs within Emacs. It is able to watch the email addresses in the headers of your email addresses and record them in the database. Assuming that you have compiled VM with BBDB included in the `lispdir' list, include the following lines in your .emacs to turn on BBDB support: (require 'bbdb) (bbdb-initialize 'vm) * For rendering HTML messages, VM can make use of the following Emacs libraries: - Emacs/W3 - a web browser written by William Perry in Emacs Lisp. It is said to be slow and its current maintenance (in 2010) is weak. - Emacs/W3M - an Emacs interface to the text-mode web browser W3M. For guidance on installing either of these libraries, please check their EmacsWiki pages and their own installation instructions. VM can also make use of the following external text-mode web browsers (as basically converters from html to plain text). - Lynx - A fast text-based web browser that runs under Unix. Developed at the University of Kansas. - W3M - Possibly the best text-based web browser. Written by Akinori Ito and his team, it runs fast and renders pages as true to form as possible in plain text. VM can check the libraries available on your path and pick the best one for HTML rendering, but you can also specify the choice explicitly by including in your .emacs file, e.g., (setq vm-mime-text/html-handler 'emacs-w3m) Other than 'emacs-w3m, you can also use 'w3, 'w3m and 'lynx.