vm-8.1.2/0002755000175000017500000000000011725175471012432 5ustar srivastasrivastavm-8.1.2/lisp/0002755000175000017500000000000011725175471013401 5ustar srivastasrivastavm-8.1.2/lisp/vm-rfaddons.el0000644000175000017500000024125011725175471016145 0ustar srivastasrivasta;;; vm-rfaddons.el --- a collections of various useful VM helper functions ;; ;; 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: (defgroup vm nil "VM" :group 'mail) (defgroup vm-rfaddons nil "Customize vm-rfaddons.el" :group 'vm) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when-compile (require 'vm-version) (require 'vm-message) (require 'vm-macro) (require 'vm-vars) (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) (if vm-xemacs-p (require 'overlay)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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-mime-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 (define-key vm-mail-mode-map "\C-c\C-a" 'vm-mime-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-buffer)) (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-buffer t) (defadvice vm-preview-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)) (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 (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-mime-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-preview-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: VM is now infected.") (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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar vm-reply-include-presentation nil) ;;;###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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-do-reply to-all t count)))) ;;;###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)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###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 (regexp-quote mail-header-separator) (point-max)) (delete-region (match-beginning 0) (match-end 0)) (let ((header-end (point-marker))) (mail-do-fcc header-end) (goto-char header-end) (insert mail-header-separator)))) (defcustom vm-do-fcc-before-mime-encode nil "*Non-nil means to FCC before encoding." :type 'boolean :group 'vm-rfaddons) (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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar vm-switch-to-folder-history nil) ;;;###autoload (defun vm-switch-to-folder (folder-name) "Switch to another opened VM folder and rearrange windows as with a scroll." (interactive (list (let ((fl (vm-folder-list)) (f vm-switch-to-folder-history) d) (if (member major-mode '(vm-mode vm-presentation-mode vm-summary-mode)) (save-excursion (vm-select-folder-buffer) (setq fl (delete (buffer-name) fl)))) (while f (setq d (car f) f (cdr f)) (if (member d fl) (setq f nil))) (completing-read (format "Foldername%s: " (if d (format " (%s)" d) "")) (mapcar (lambda (f) (list f)) (vm-folder-list)) nil t nil 'vm-switch-to-folder-history d)))) (switch-to-buffer folder-name) (vm-select-folder-buffer) (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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-marked-or-prefixed-messages count))) (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 (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) (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-frames (if (eq mode 'edit) vm-mutable-frames 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)) ) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun vm-mime-find-type-of-message/external-body (layout) (save-excursion (vm-select-folder-buffer) (save-restriction (set-buffer (marker-buffer (vm-mm-layout-body-start layout))) (widen) (goto-char (vm-mm-layout-body-start layout)) (if (not (re-search-forward "Content-Type: \"?\\([^ ;\" \n\t]+\\)\"?;?" (vm-mm-layout-body-end layout) t)) (error "No `Content-Type' header found in: %s" (buffer-substring (vm-mm-layout-body-start layout) (vm-mm-layout-body-end layout))) (match-string 1))))) ;; 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) ;;;###autoload (defun vm-mime-display-button-message/external-body (layout) "Return a button usable for viewing message/external-body MIME parts. When you apply `vm-mime-send-body-to-file' with `vm-mime-delete-after-saving' set to t one will get theses message/external-body parts which point to the external file. In order to view these we search for the right viewer hopefully listed in `vm-mime-external-content-types-alist' and invoke it as it would have happened before saving. Otherwise we display the contents as text/plain. Probably we should be more clever here in order to fake a layout if internal displaying is possible ... But nevertheless this allows for keeping folders smaller without loosing basic functionality when using `vm-mime-auto-save-all-attachments'." (let ((buffer-read-only nil) (real-mime-type (vm-mime-find-type-of-message/external-body layout))) (vm-mime-insert-button (vm-replace-in-string (format " external: %s %s" (if (vm-mime-get-parameter layout "name") (file-name-nondirectory (vm-mime-get-parameter layout "name")) "") (let ((tmplayout (copy-tree layout t)) format) (aset tmplayout 0 (list real-mime-type)) (setq format (vm-mime-find-format-for-layout tmplayout)) (setq format (vm-replace-in-string format "^%-[0-9]+.[0-9]+" "%-15.15" t)) (vm-mime-sprintf format tmplayout))) "save to a file\\]" "display as text]") (function (lambda (xlayout) (setq layout (if vm-xemacs-p (vm-extent-property xlayout 'vm-mime-layout) (overlay-get xlayout 'vm-mime-layout))) (let* ((type (vm-mime-find-type-of-message/external-body layout)) (viewer (vm-mime-find-external-viewer type)) (filename (vm-mime-get-parameter layout "name"))) (if (car viewer) (progn (message "Viewing %s with %s" filename (car viewer)) (start-process (format "Viewing %s" filename) nil (car viewer) filename)) (let ((buffer-read-only nil) (converter (assoc type vm-mime-type-converter-alist))) (if vm-xemacs-p (delete-region (extent-start-position xlayout) (extent-end-position xlayout)) (delete-region (overlay-start xlayout) (overlay-end xlayout))) (if converter (shell-command (concat (caddr converter) " < '" filename "'") 1) (message "Could not find viewer for type %s!" type) (insert-file-contents filename)))) ))) layout nil))) ;;;###autoload ;(defun vm-mime-display-internal-message/external-body (layout) ; "Display the text of the message/external-body MIME part." ; (vm-mime-display-internal-text/plain layout)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar vm-mime-attach-files-in-directory-regexps-history nil "Regexp history for matching files.") (defcustom vm-mime-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"))) (defcustom vm-mime-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))) ;; (define-obsolete-variable-alias 'vm-mime-save-all-attachments-types ;; 'vm-mime-savable-types ;; "8.3.0" ;; "*List of MIME types which should be saved.") (defvaralias 'vm-mime-savable-types 'vm-mime-save-all-attachments-types) (make-obsolete-variable 'vm-mime-save-all-attachments-types 'vm-mime-savable-types "8.1.1") ;; (define-obsolete-variable-alias ;; 'vm-mime-save-all-attachments-types-exceptions ;; 'vm-mime-savable-type-exceptions ;; "8.3.0" ;; "*List of MIME types which should not be saved.") (defvaralias 'vm-mime-savable-type-exceptions 'vm-mime-save-all-attachments-types-exceptions) (make-obsolete-variable 'vm-mime-save-all-attachments-types-exceptions 'vm-mime-savable-type-exceptions "8.1.1") ;; (define-obsolete-variable-alias 'vm-mime-delete-all-attachments-types ;; 'vm-mime-deletable-types ;; "8.3.0" ;; "*List of MIME types which should be deleted.") (defvaralias 'vm-mime-deletable-types 'vm-mime-delete-all-attachments-types) (make-obsolete-variable 'vm-mime-delete-all-attachments-types 'vm-mime-deletable-types "8.1.1") ;; (define-obsolete-variable-alias ;; 'vm-mime-delete-all-attachments-types-exceptions ;; 'vm-mime-deletable-type-exceptions ;; "8.3.0" ;; "*List of MIME types which should not be deleted.") (defvaralias 'vm-mime-deletable-type-exceptions 'vm-mime-delete-all-attachments-types-exceptions) (make-obsolete-variable 'vm-mime-delete-all-attachments-types-exceptions 'vm-mime-deletable-type-exceptions "8.1.1") (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-mime-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-mime-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-mime-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-mime-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-mime-attach-file file type charset)) (setq files (cdr files)))))) (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-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)) "--" (vm-decode-mime-encoded-words-in-string (or (vm-su-full-name msg) "unknown")) "--" (vm-decode-mime-encoded-words-in-string (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) (vm-check-for-killed-summary) (vm-mime-save-all-attachments count 'vm-mime-auto-save-all-attachments-path) (when (interactive-p) (vm-discard-cached-data) (vm-preview-current-message))))) ;;;###autoload (defun vm-mime-auto-save-all-attachments-delete-external (msg) "Deletes the external attachments created by `vm-mime-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) (vm-check-for-killed-summary) (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 '((t (:background "gray"))) "Used for marking shrunken headers." :group 'vm-faces) (defvar 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) (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. (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))))) (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) (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-list))) (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) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Subject: RE: How to configure for more obvious 'auto decode' attachement. ;; Newsgroups: gnu.emacs.vm.info ;; Date: Mon, 20 Sep 1999 21:48:37 GMT ;; Organization: Deja.com - Share what you know. Learn what you don't. ;; From: rmirani (defcustom vm-mime-display-internal-multipart/mixed-separater "\n----------------------------------------------------------------------\n" "*The separator which is inserted between the parts of a multipart message." :group 'vm-rfaddons :type '(choice (string :tag "Separator") (const :tag "No Separator" nil))) ;;;###autoload (defun vm-mime-display-internal-multipart/mixed (layout) "A replacement for VMs default function adding separators. LAYOUT specifies the layout." (let ((part-list (vm-mm-layout-parts layout))) (while part-list (let ((cur (car part-list))) (vm-decode-mime-layout cur) (setq part-list (cdr part-list)) (cond ((and part-list (not (vm-mime-should-display-button cur nil)) (vm-mime-should-display-button (car part-list) nil)) ;; do nothing ) ((and part-list (not (vm-mime-should-display-button cur nil)) (not (vm-mime-should-display-button (car part-list) nil)) vm-mime-display-internal-multipart/mixed-separater) (insert vm-mime-display-internal-multipart/mixed-separater))))) t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###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))))) (setq vm-highlight-url-face 'message-url)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 () "Switched to the presentation or preview buffer and starts isearch." (interactive) (vm-select-folder-buffer) (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) ;;;###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 (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 (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)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide 'vm-rfaddons) ;;; vm-rfaddons.el ends here vm-8.1.2/lisp/vm-serial.el0000644000175000017500000010247311725175471015627 0ustar srivastasrivasta;;; vm-serial.el --- automatic creation of personalized message bodies ;; and sending of personalized serial mails ;; ;; 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: (defgroup vm nil "VM" :group 'mail) (defgroup vm-serial nil "Sending personalized serial mails and getting message templates." :group 'vm) (eval-when-compile (require 'cl)) (require 'vm-reply) (eval-and-compile (require 'vm-pine) (require 'mail-utils) (require 'mail-extr) (require 'advice)) (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 var 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 (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 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) (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) (vm-make-local-hook 'mail-send-hook) (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))) ;;----------------------------------------------------------------------------- (provide 'vm-serial) ;;; vm-serial.el ends here vm-8.1.2/lisp/vm-mouse.el0000644000175000017500000005776411725175471015514 0ustar srivastasrivasta;;; vm-mouse.el --- Mouse related functions and commands ;; ;; 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: (defun vm-mouse-set-mouse-track-highlight (start end &optional overlay) (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 (make-extent start end))) (set-extent-property o 'start-open t) (set-extent-property o 'priority 10) (set-extent-property o 'highlight t) o ))) (cond (vm-fsfemacs-p (move-overlay overlay start end)) (vm-xemacs-p (set-extent-endpoints overlay start end))))) ;;;###autoload (defun vm-mouse-button-2 (event) (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) (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 (extent-at (point) nil 'highlight))) (if e (buffer-substring (extent-start-position e) (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 ((extent-at (point) (current-buffer) 'vm-url) (vm-mouse-send-url-at-event event)) ((setq e (extent-at (point) nil 'vm-mime-function)) (funcall (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 (extent-at pos (current-buffer) 'vm-url)) url) (if (null e) nil (setq url (buffer-substring (extent-start-position e) (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) (message "Sending URL to %s..." browser) (apply 'vm-run-background-command browser (append switches (list url))) (message "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))) (message "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))) (message "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))) (message "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))) (message "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))) (message "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))) (message "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")))) (message "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)))) (message "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) (message "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))) (message "Sending URL to Konqueror... done")) (defun vm-mouse-send-url-to-firefox (url &optional new-window) (message "Sending URL to Mozilla Firebird...") (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))) (message "Sending URL to Mozilla Firefox... done")) (defun vm-mouse-send-url-to-konqueror-new-browser (url) (vm-mouse-send-url-to-konqueror url t)) (defun vm-mouse-send-url-to-clipboard (url) (message "Sending URL to X Clipboard...") (cond ((fboundp 'own-selection) (own-selection url 'CLIPBOARD)) ((fboundp 'x-own-clipboard) (x-own-clipboard url)) ((fboundp 'x-own-selection-internal) (x-own-selection-internal 'CLIPBOARD url))) (message "Sending URL to X Clipboard... done")) ;;;###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) (message "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) (message "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) (message "%s exited non-zero (code %s)" command status) t) (t (save-excursion (message "%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-frames 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-frames 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))) (provide 'vm-mouse) ;;; vm-mouse.el ends here vm-8.1.2/lisp/vm-menu.el0000644000175000017500000015023511725175471015313 0ustar srivastasrivasta;;; vm-menu.el --- Menu related functions and commands ;; ;; 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. (eval-when-compile (defvar current-menubar nil)) ;;; Code: (defvar vm-menu-folders-menu '("Manipulate Folders" ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]) "VM folder menu list.") (defvar 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. "-------" )) (defvar 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] ["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-unread-message 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] "---" ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list] ["Decode MIME" vm-decode-mime-message (vm-menu-can-decode-mime-p)] ))) (defvar 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] )) (defvar vm-menu-virtual-menu '("Virtual" ["Visit Virtual Folder" vm-visit-virtual-folder t] ["Visit Virtual Folder Same Author" vm-visit-virtual-folder-same-author t] ["Visit Virtual Folder Same Subject" vm-visit-virtual-folder-same-subject t] ["Create Virtual Folder" vm-create-virtual-folder t] ["Apply Virtual Folder" vm-apply-virtual-folder t] "---" "---" ;; special string that marks the tail of this menu for ;; vm-menu-install-known-virtual-folders-menu. "-------" )) (defvar 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] ["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] )) (defvar 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] )) (defvar 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] )) (defvar vm-menu-sort-menu '("Sort" ["By Multiple Fields..." vm-sort-messages vm-message-list] "---" ["By Date" (vm-sort-messages "date") vm-message-list] ["By Subject" (vm-sort-messages "subject") vm-message-list] ["By Author" (vm-sort-messages "author") vm-message-list] ["By Recipients" (vm-sort-messages "recipients") vm-message-list] ["By Lines" (vm-sort-messages "line-count") vm-message-list] ["By Bytes" (vm-sort-messages "byte-count") vm-message-list] "---" ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list] ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list] ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list] ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list] ["By Lines (backward)" (vm-sort-messages "reversed-line-count") vm-message-list] ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list] "---" ["Toggle Threading" vm-toggle-threads-display t] "---" ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list] )) (defvar vm-menu-help-menu '("Help" ["Switch to Emacs Toolbar" vm-menu-toggle-menubar] "---" ["What Now?" vm-help t] ["Describe Mode" describe-mode 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] )) (defvar vm-menu-undo-menu ["Undo" vm-undo (vm-menu-can-undo-p)] ) (defvar vm-menu-emacs-button ["XEmacs" vm-menu-toggle-menubar t] ) (defvar vm-menu-vm-button ["VM" vm-menu-toggle-menubar t] ) (defvar 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-mime-attach-file vm-send-using-mime] ["Attach MIME Message..." vm-mime-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-mime-preview-composition vm-send-using-mime] ))) (defvar 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-run-display-function-at-point 'vm-mime-display-body-as-text) t] ["Display using External Viewer" (vm-mime-run-display-function-at-point 'vm-mime-display-body-using-external-viewer) t] ;; FSF Emacs does not allow a non-string menu element name. ,@(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 e))))) "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 e))))])) "---" ["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-run-display-function-at-point (function (lambda (e) (vm-extent-property e 'vm-mime-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-run-display-function-at-point 'vm-mime-send-body-to-printer) t] ["Pipe to Shell Command (display output)" (vm-mime-run-display-function-at-point 'vm-mime-pipe-body-to-queried-command) t] ["Pipe to Shell Command (discard output)" (vm-mime-run-display-function-at-point 'vm-mime-pipe-body-to-queried-command-discard-output) t] ["Attach to Message Composition Buffer" vm-mime-attach-object-from-message t] ["Delete" vm-delete-mime-object t]))) (defvar 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 ["Emacs W3" (vm-mouse-send-url-at-position (point) (quote ,w3)) (fboundp (quote ,w3))] ["Mosaic" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-mosaic) t] ["mMosaic" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-mmosaic) t] ["Netscape" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-netscape) t] ["Konqueror" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-konqueror) t] ["X Clipboard" (vm-mouse-send-url-at-position (point) 'vm-mouse-send-url-to-clipboard) t]))) (defvar 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]))) (defvar 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] ))) (defvar 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] ))) (defvar 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] ))) (defvar 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) (defvar 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) (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-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) (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) (setq this-command 'vm-create-virtual-folder) (vm-create-virtual-folder 'author (regexp-quote (vm-su-from (car vm-message-pointer))))) (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 ;; (list "Undo" vm-menu-undo-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)))) cons (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 'virtual 'sort 'label 'mark 'send 'motion 'folder)))) (while menu-list (if (null (car menu-list)) nil;; no flushright support in FSF Emacs (aset vec 2 (intern (concat "vm-menubar-" (symbol-name (car menu-list))))) (setq cons (assq (car menu-list) menu-alist)) (if cons (define-key map vec (eval (car (cdr 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-undo-menu))) 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 contexts, ;; 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)))) (defun vm-menu-toggle-menubar (&optional buffer) (interactive) (if buffer (set-buffer buffer) (vm-select-folder-buffer)) (cond ((vm-menu-xemacs-menus-p) (if (null (car (find-menu-item current-menubar '("XEmacs")))) (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 "VM" '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)) (define-key vm-mode-map [menu-bar vm] (cons "[VM]" 'vm-menu-toggle-menubar))) (vm-menu-set-menubar-dirty-flag)))) (defun vm-menu-install-menubar () (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 () (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 () ;; 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 () (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 (stringp vm-recognize-pop-maildrops) (string-match vm-recognize-pop-maildrops (car folders)) (setq foo (vm-pop-find-name-for-spec (car folders)))) (list 'vm-menu-run-command ''vm-visit-pop-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)))))))) ;;; Muenkel Folders menu code (defvar vm-menu-hm-no-hidden-dirs t "*Hidden directories are suppressed in the folder menus, if non nil.") (defvar 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)) (message "Folder deleted.") (vm-menu-hm-make-folder-menu) (vm-menu-hm-install-menu) ) (message "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) (message "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] )))) (message "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 (defvar 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))) (defvar 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 ) ) (provide 'vm-menu) ;;; vm-menu.el ends here vm-8.1.2/lisp/vm-summary.el0000644000175000017500000020050411725175471016037 0ustar srivastasrivasta;;; vm-summary.el --- Summary gathering and formatting routines for VM ;; ;; Copyright (C) 1989-1995, 2000 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: (defvar scrollbar-height) ; defined for XEmacs (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) ;; horizontal scrollbar off by default ;; user can turn it on in summary hook if desired. (and vm-xemacs-p (featurep 'scrollbar) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-summary-mode-map) (and (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)) (if (and vm-mutable-frames (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) (vm-check-for-killed-summary) (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) (let ((m-list (or start-point vm-message-list)) mp m tr trs tre (n 0) ;; Just for laughs, make the update interval vary. (modulus (+ (% (vm-abs (random)) 11) 10)) (do-mouse-track (and vm-mouse-track-summary (vm-mouse-support-possible-p))) summary) (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))) (unwind-protect (progn (if start-point (if (vm-su-start-of (car mp)) (progn (goto-char (vm-su-start-of (car mp))) (delete-region (point) (point-max))) (goto-char (point-max))) (erase-buffer) (setq vm-summary-pointer nil)) ;; 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. (while mp (setq m (car mp)) (setq summary (vm-su-summary 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))) (put-text-property s e 'vm-message m) (when (and vm-summary-toggle-thread-folding vm-summary-show-threads) (if (= 0 (vm-thread-indentation-of m)) (setq tr m trs s tre e) (save-excursion (when (and tr trs (progn (goto-char (1+ (vm-su-start-of tr))) (not (looking-at "-")))) ;; do not hide new messages (put-text-property s e 'invisible (not (vm-new-flag m))) (put-text-property s e 'thread-root tr) (put-text-property trs tre 'thread-end m) (insert "+") (goto-char (vm-su-start-of tr)) (delete-char 1) ))))) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (message "Generating summary... %d" n))) ;; now convert the ints to markers. (if (>= n modulus) (message "Generating summary markers... ")) (setq mp m-list) (while mp (setq m (car mp)) (and do-mouse-track (vm-set-su-summary-mouse-track-overlay-of m (vm-mouse-set-mouse-track-highlight (vm-su-start-of m) (vm-su-end-of m) (vm-su-summary-mouse-track-overlay-of m)))) (vm-set-su-start-of m (vm-marker (vm-su-start-of m))) (vm-set-su-end-of m (vm-marker (vm-su-end-of m))) (setq mp (cdr mp)))) (set-buffer-modified-p modified)) (run-hooks 'vm-summary-redo-hook))) (if (>= n modulus) (message "Generating summary... done")))) (defun vm-summary-toggle-thread-folding (&optional visible) "Toggle the thread folding at point." (interactive) (save-excursion (vm-follow-folders-summary-cursor) (vm-select-folder-buffer) (set-buffer vm-summary-buffer) (when (and vm-summary-toggle-thread-folding vm-summary-show-threads (get-text-property (point) 'thread-end)) (let* ((m (get-text-property (point) 'vm-message)) (e (get-text-property (point) 'thread-end)) (i (not (get-text-property (vm-su-start-of e) 'invisible)))) (if (eq visible -1) (setq i t) (if (eq visible 1) (setq i nil))) (put-text-property (vm-su-end-of m) (vm-su-end-of e) 'invisible i) (let ((buffer-read-only nil)) (goto-char (1+ (vm-su-start-of m))) (insert (if i "+" "-")) (goto-char (vm-su-start-of m)) (delete-char 1)))))) (defun vm-do-needed-summary-rebuild () (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) (and vm-message-pointer (vm-set-summary-pointer (car vm-message-pointer))) (setq vm-need-summary-pointer-update nil)) (and vm-need-summary-pointer-update vm-summary-buffer vm-message-pointer (progn (vm-set-summary-pointer (car vm-message-pointer)) (setq vm-need-summary-pointer-update nil))))) (defun vm-update-message-summary (m) (if (and (vm-su-start-of m) (marker-buffer (vm-su-start-of m))) (let ((modified (buffer-modified-p)) (do-mouse-track (and vm-mouse-track-summary (vm-mouse-support-possible-p))) summary) (save-excursion (setq summary (vm-su-summary m)) (set-buffer (marker-buffer (vm-su-start-of m))) (let ((buffer-read-only nil) (selected nil) (modified (buffer-modified-p))) (unwind-protect (save-excursion (goto-char (vm-su-start-of m)) (setq selected (looking-at "[+-]>")) ;; 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)) (delete-region (point) (1- (vm-su-end-of m))) (if (not selected) (if (not (get-text-property (point) 'thread-end)) (insert vm-summary-no-=>) (if (get-text-property (1+ (vm-su-end-of vm-summary-pointer)) 'invisible) (insert "+ ") (insert "- "))) (if (not (get-text-property (point) 'thread-end)) (insert vm-summary-=>) (if (get-text-property (1+ (vm-su-end-of vm-summary-pointer)) 'invisible) (insert "+>") (insert "->")))) (vm-tokenized-summary-insert m (vm-su-summary m)) (delete-char 1) (run-hooks 'vm-summary-update-hook) (and 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 (and selected vm-summary-highlight-face) (vm-summary-highlight-region (vm-su-start-of m) (point) vm-summary-highlight-face))) (set-buffer-modified-p modified))))))) (defun vm-set-summary-pointer (m) (if vm-summary-buffer (let ((w (vm-get-visible-buffer-window vm-summary-buffer)) (do-mouse-track (and vm-mouse-track-summary (vm-mouse-support-possible-p))) (old-window nil)) (vm-save-buffer-excursion (unwind-protect (progn (set-buffer vm-summary-buffer) (if w (progn (setq old-window (selected-window)) (select-window w))) (let ((buffer-read-only nil)) (if (and vm-summary-pointer (vm-su-start-of vm-summary-pointer)) (progn (goto-char (vm-su-start-of vm-summary-pointer)) (if (not (get-text-property (point) 'thread-end)) (insert vm-summary-no-=>) (if (get-text-property (1+ (vm-su-end-of vm-summary-pointer)) 'invisible) (insert "+ ") (insert "- "))) (delete-char (length vm-summary-=>)) (and 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))))) (setq vm-summary-pointer m) (goto-char (vm-su-start-of m)) (let ((modified (buffer-modified-p))) (unwind-protect (progn (if (not (get-text-property (point) 'thread-end)) (insert vm-summary-=>) (if (get-text-property (1+ (vm-su-end-of vm-summary-pointer)) 'invisible) (insert "+>") (insert "->"))) (delete-char (length vm-summary-=>)) (and 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)))) (set-buffer-modified-p modified))) (forward-char (- (length vm-summary-=>))) (if vm-summary-highlight-face (vm-summary-highlight-region (vm-su-start-of m) (vm-su-end-of m) vm-summary-highlight-face)) (and w vm-auto-center-summary (vm-auto-center-summary)) (run-hooks 'vm-summary-pointer-update-hook))) (and 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 (extent-end-position ooo)) (set-extent-endpoints ooo start end) (setq ooo (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. (set-extent-property ooo 'start-open t) (set-extent-property ooo 'detachable nil) (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) ;; 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)))) (if (null match) (progn (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) (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) (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) (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 (vm-th-thread-indentation message)))))) (setq tokens (cdr tokens)))))) (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]+\\)\\)?\\([()pPaAcSdfFhHiIlLmMnstTwyz*%]\\|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 ?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 ?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) (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))))))) (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) (let ((contents nil) regexp) (setq regexp (concat "^\\(" header-name-regexp "\\)") 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) (if (vm-get-header-contents msg vm-postponed-header) vm-summary-postponed-indicator "")) (defun vm-su-attachment-indicator (msg) (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) (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) (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") (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-long (m) (concat (cond ((vm-deleted-flag m) "D") ((vm-new-flag m) "N") ((vm-unread-flag m) "U") (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) (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) "Return the size of a message in bytes, kilobytes or megabytes. Argument msg is a message pointer." (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." (let ((spam-status (vm-get-header-contents m "X-Spam-Status:"))) (if (string-match "\\(hits\\|score\\)=\\([+-]?[0-9.]+\\)" spam-status) (string-to-number (match-string 2 spam-status)) 0))) (defun vm-su-spam-score (m) "Return the numeric spam level for M (possibly using cache)." (or (vm-spam-score-of m) (vm-set-spam-score-of m (vm-su-spam-score-aux m)))) (defun vm-su-weekday (m) (or (vm-weekday-of m) (progn (vm-su-do-date m) (vm-weekday-of m)))) (defun vm-su-monthday (m) (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-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-su-do-date (m) (let ((case-fold-search t) vector date) (setq date (or (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) (let ((message (vm-real-message-of message))) (save-excursion (set-buffer (vm-buffer-of message)) (save-restriction (widen) (save-excursion (narrow-to-region (vm-headers-of message) (vm-text-end-of message)) (funcall function message)))))) (defun vm-su-full-name (m) (or (vm-full-name-of m) (progn (vm-su-do-author m) (vm-full-name-of m)))) (defun vm-su-interesting-full-name (m) (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) (or (vm-from-of m) (progn (vm-su-do-author m) (vm-from-of m)))) (defun vm-su-interesting-from (m) (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) (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 full-name) (vm-set-from-of m 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 (message err) (sit-for 5) "corrupted-header"))) (setq list (vm-parse-addresses all)) (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) (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m)))) (defun vm-su-to-names (m) (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m)))) ;;;###autoload (defun vm-su-message-id (m) (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) (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) (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) (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) "Rebuilts the summary. Call this function if you made changes to `vm-summary-format'." (interactive "P") (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (if kill-local-summary (kill-local-variable 'vm-summary-format)) (message "Fixing your summary... %s" vm-summary-format) (let ((mp vm-message-list)) (while mp (vm-set-summary-of (car mp) nil) (vm-mark-for-summary-update (car mp)) (vm-set-stuff-flag-of (car mp) t) (setq mp (cdr mp))) (message "Stuffing attributes...") (vm-stuff-folder-attributes nil) (message "Stuffing attributes... done") (set-buffer-modified-p t) (vm-update-summary-and-mode-line)) (message "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-th-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 (vm-labels-of m) ",")) (vm-label-string-of m))) (defun vm-substring (string from &optional to) (let ((work-buffer nil)) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-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)) (and work-buffer (kill-buffer work-buffer))))) (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 ((and (stringp vm-recognize-pop-maildrops) (string-match vm-recognize-pop-maildrops folder)) (vm-safe-popdrop-string folder)) ((and (stringp vm-recognize-imap-maildrops) (string-match vm-recognize-imap-maildrops 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 (message "open-database signaled: %S" data) (sleep-for 2) 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-folder-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 (and vm-mouse-track-summary (vm-mouse-support-possible-p))) 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) (and 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)))) (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) (and vm-xemacs-p (featurep 'scrollbar) (set-specifier scrollbar-height (cons (current-buffer) 0))) (use-local-map vm-folders-summary-mode-map) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) (if (and vm-mutable-frames 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 (and vm-mouse-track-summary (vm-mouse-support-possible-p)))) (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))) (and 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)))) (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 ))) (provide 'vm-summary) ;;; vm-summary.el ends here vm-8.1.2/lisp/vm-user.el0000644000175000017500000000424611725175471015325 0ustar srivastasrivasta;;; vm-user.el --- Interface functions to VM internal data ;; ;; 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: (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 )) (provide 'vm-user) ;;; vm-user.el ends here vm-8.1.2/lisp/vm-mime.el0000644000175000017500000101377411725175471015305 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: (eval-when-compile (require 'cl)) (defvar enable-multibyte-characters) (defvar default-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")) ;; 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)) ;; This function has been updated from Rob F's version based on Brent ;; Goodrick's suggestions, his rev. 609, 2009-01-24 (defun vm-find-coding-system (system) (cond ((functionp 'find-coding-system) (find-coding-system system)) ((boundp 'coding-system-list) (if (member system coding-system-list) system nil)) (t system))) (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 (coding-system-p (vm-find-coding-system list-item)) (delq list-item res))) res))) (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 (coding-system-p (vm-find-coding-system '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. (mapcar (lambda (x) (and (coding-system-p (vm-find-coding-system 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. (mapcar (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 (coding-system-p (vm-find-coding-system '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)))) (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-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-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-display-error (e c) (aset e 14 c)) (defun vm-set-mm-layout-is-converted (e c) (asef e 15 c)) (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) (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)))) (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) (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 (device-type) '(x gtk mswindows))) vm-fsfemacs-p (vm-mime-tty-can-display-mime-charset charset) nil) (let ((buffer-read-only nil) (cell (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))) (opoint (point))) (if cell (progn ;; decode 8-bit indeterminate char to correct ;; char in correct charset. (vm-decode-coding-region start end (car cell)) (put-text-property start end 'vm-string t) (put-text-property start end 'vm-charset charset) (put-text-property start end 'vm-coding (car cell)))) ;; 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) (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) 200) (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) 200) (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) (message "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) (message "Encoding base64... done")) (- end start)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-qp-decode-region (start end) (and (> (- end start) 200) (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) 200) (message "Decoding quoted-printable... done"))) (defun vm-mime-qp-encode-region (start end &optional Q-encoding quote-from) (and (> (- end start) 200) (message "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) (message "Encoding quoted-printable... done")) (- end start)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-uuencode-decode-region (start end &optional crlf) (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))) (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-B-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 () (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) (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 )) (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 default-type default-encoding passing-message-only) "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-mime-parse-content-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-mime-parse-content-header type ?\; t) type (vm-mime-parse-content-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-mime-parse-content-header encoding)) "7bit") id (vm-get-header-contents m "Content-ID:") id (car (vm-mime-parse-content-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-mime-parse-content-header disposition ?\; t)) disposition (and disposition (vm-mime-parse-content-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-mime-parse-content-header type ?\; t) default-type) type (or (vm-mime-parse-content-header type ?\;) default-type) encoding (or (vm-mime-get-header-contents "Content-Transfer-Encoding:") default-encoding) encoding (or (car (vm-mime-parse-content-header encoding)) default-encoding) id (vm-mime-get-header-contents "Content-ID:") id (car (vm-mime-parse-content-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-mime-parse-content-header disposition ?\; t)) disposition (and disposition (vm-mime-parse-content-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 c-t c-t-e 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 c-t c-t-e 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 c-t c-t-e p-m-only) "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 c-t (setq c-t '("text/plain" "charset=us-ascii"))) (or c-t-e (setq c-t-e "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 c-t c-t-e p-m-only) (vm-mime-error (message "%s" (car (cdr error-data))) ;;; don't sleep, no one cares about MIME syntax errors ;;; (sleep-for 2) (let ((header (if (and m (not p-m-only)) (vm-headers-of m) (vm-marker (point-min)))) (text (if (and m (not p-m-only)) (vm-text-of m) (save-excursion (re-search-forward "^\n\\|\n\\'" nil 0) (vm-marker (point))))) (text-end (if (and m (not p-m-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) ))))) (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, rebuilt 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 name) (let ((string (vm-mime-get-xxx-parameter name (cdr (vm-mm-layout-type layout))))) (if string (vm-decode-mime-encoded-words-in-string string)))) (defun vm-mime-get-disposition-parameter (layout name) (let ((string (vm-mime-get-xxx-parameter name (cdr (vm-mm-layout-disposition layout))))) (if string (vm-decode-mime-encoded-words-in-string string)))) (defun vm-mime-set-xxx-parameter (name value 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) (setcar param-list (concat name "=" value))))) (defun vm-mime-set-parameter (layout name value) (vm-mime-set-xxx-parameter name value (cdr (vm-mm-layout-type layout)))) (defun vm-mime-set-qparameter (layout name value) (setq value (concat "\"" value "\"")) (vm-mime-set-xxx-parameter name value (cdr (vm-mm-layout-qtype layout)))) (defun vm-mime-insert-mime-body (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) (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-make-presentation-copy (m) "Create a copy of the message M in the Presentation Buffer. If working in headers-only mode, the copy is made from the external source of the message." (let ((mail-buffer (current-buffer)) b mm (real-m (vm-real-message-of m)) (modified (buffer-modified-p))) (cond ((or (null vm-presentation-buffer-handle) (null (buffer-name vm-presentation-buffer-handle))) (setq b (vm-generate-new-multibyte-buffer (concat (buffer-name) " Presentation"))) (save-excursion (set-buffer b) (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 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-frames 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) (and (vm-menu-support-possible-p) (vm-menu-install-menus)) (run-hooks 'vm-presentation-mode-hook)) (setq vm-presentation-buffer-handle b))) (setq b vm-presentation-buffer-handle vm-presentation-buffer vm-presentation-buffer-handle 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) b) (remove-specifier (face-background 'default) b))) (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 b) ;; do not keep undo information in presentation buffers (setq buffer-undo-list t) (widen) (let ((buffer-read-only nil) (inhibit-read-only t) (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))) (set-buffer-modified-p modified))) (setq mm (copy-sequence m)) (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)) (vm-fetch-message (list (vm-message-access-method-of mm)) mm)) ((re-search-forward "^X-VM-Storage: " (vm-text-of mm) t) (vm-fetch-message (read (current-buffer)) mm))) ;; 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)) (let ((buffer-read-only nil) (inhibit-read-only t) (buffer-undo-list t) (text-begin (marker-position (vm-text-of mm)))) (goto-char text-begin) (delete-region (point) (point-max)) (apply (intern (format "vm-fetch-%s-message" (car storage))) mm (cdr storage)) ;; delete the new headers (delete-region text-begin (or (re-search-forward "\n\n" (point-max) t) (point-max))) ;; fix markers now (set-marker (vm-text-of mm) text-begin) (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)) (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")))) (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 (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) (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) (message "Converting %s to %s..." (car (vm-mm-layout-type layout)) (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)) ;; 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 'binary) (coding-system-for-read 'binary) ) (setq ex (call-process-region (point-min) (point-max) shell-file-name t t nil shell-command-switch (nth 2 ooo))))) (if (not (eq ex 0)) (progn (switch-to-buffer work-buffer) (message "Conversion from %s to %s failed (exit code %s)" (car (vm-mm-layout-type layout)) (nth 1 ooo) ex) (sit-for 5) (throw 'done nil))) (goto-char (point-min)) ;; if the to-type is text, then we will assume that the conversion ;; process output 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 (let* ((charset (vm-mime-find-charset-for-binary-buffer))) (insert "Content-Type: " (nth 1 ooo) (if (vm-mime-types-match "text" (nth 1 ooo)) (concat "; charset=" charset) "") "\n") (insert "Content-Transfer-Encoding: binary\n\n") (set-buffer-modified-p nil) (message "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 (vector (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))))) (append (list (nth 1 ooo)) (cdr (vm-mm-layout-type layout))) "binary" (vm-mm-layout-id layout) (vm-mm-layout-description layout) (vm-mm-layout-disposition layout) (vm-mm-layout-qdisposition layout) (vm-marker (point-min)) (vm-marker (1- (point))) (vm-marker (point)) (vm-marker (point-max)) nil (vm-mime-make-cache-symbol) (vm-mime-make-message-symbol (vm-mm-layout-message layout)) nil 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)))) (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)) (message "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)) (insert-before-markers "Content-Type: " (car (vm-mm-layout-type layout))) (insert-before-markers ";\n\t" (mapconcat 'identity (car (vm-mm-layout-type layout)) ";\n\t") "\n") (insert-before-markers "Content-Transfer-Encoding: binary\n\n") (set-buffer-modified-p nil) (message "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) (setq ooo (vm-mime-can-convert-charset charset)) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer " *mime object*")) (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) (call-process-region (point-min) (point-max) shell-file-name t t nil shell-command-switch (nth 2 ooo)) (if vm-fsfemacs-mule-p (set-buffer-multibyte t)) ; is this safe? (setq start (point-min) end (point-max)) (save-excursion (set-buffer b) (goto-char b-start) (insert-buffer-substring work-buffer start end) (delete-region (point) (+ (point) oldsize))) (nth 1 ooo)) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-should-display-button (layout dont-honor-content-disposition) (if (and vm-honor-mime-content-disposition (not dont-honor-content-disposition) (vm-mm-layout-disposition layout)) (let ((case-fold-search t)) (string-match "^attachment$" (car (vm-mm-layout-disposition layout)))) (let ((i-list vm-auto-displayed-mime-content-types) (type (car (vm-mm-layout-type layout))) (matched nil)) (if (if (eq i-list t) nil (while (and i-list (not matched)) (if (vm-mime-types-match (car i-list) type) (setq matched t) (setq i-list (cdr i-list)))) (not matched)) t (setq i-list vm-auto-displayed-mime-content-type-exceptions matched nil) (while (and i-list (not matched)) (if (vm-mime-types-match (car i-list) type) (setq matched t) (setq i-list (cdr i-list)))) matched )))) (defun vm-mime-should-display-internal (layout) (let ((i-list vm-mime-internal-content-types) (type (car (vm-mm-layout-type layout))) (matched nil)) (if (if (eq i-list t) t (while (and i-list (not matched)) (if (vm-mime-types-match (car i-list) type) (setq matched t) (setq i-list (cdr i-list)))) matched ) (progn (setq i-list vm-mime-internal-content-type-exceptions matched nil) (while (and i-list (not matched)) (if (vm-mime-types-match (car i-list) type) (setq matched t) (setq i-list (cdr i-list)))) (not matched)) 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))))) ;;;###autoload (defun vm-decode-mime-message () "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. 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-auto-displayed-mime-content-types vm-auto-displayed-mime-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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (if (and (not vm-display-using-mime) (null 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)) (if vm-mime-decoded (if (eq vm-mime-decoded 'decoded) (let ((vm-preview-lines nil) (vm-auto-decode-mime-messages t) (vm-honor-mime-content-disposition nil) (vm-auto-displayed-mime-content-types '("multipart")) (vm-auto-displayed-mime-content-type-exceptions nil)) (setq vm-mime-decoded nil) (intern (buffer-name) vm-buffers-needing-display-update) (save-excursion (vm-preview-current-message)) (setq vm-mime-decoded 'buttons)) (let ((vm-preview-lines nil) (vm-auto-decode-mime-messages nil)) (intern (buffer-name) vm-buffers-needing-display-update) (vm-preview-current-message))) (let ((layout (vm-mm-layout (car vm-message-pointer))) (m (car vm-message-pointer))) (message "Decoding MIME message...") (if (stringp layout) (error "Invalid MIME message: %s" layout)) (if (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)) (if (and (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 (and (not (eq (vm-mm-encoded-header m) 'none)) (vm-decode-mime-message-headers m)) (if (vectorp layout) (progn (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) (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-decode-mime-layout (layout &optional dont-honor-c-d) "Decode the MIME message in the current buffer using LAYOUT. DONT-HONOR-C-D non-Nil, then don't honor the Content-Disposition declarations in the attachments and make a decision independently." (let ((modified (buffer-modified-p)) new-layout file type type2 type-no-subtype (extent nil)) (unwind-protect (progn (if (not (vectorp layout)) (progn (setq extent layout layout (vm-extent-property extent 'vm-mime-layout)) (goto-char (vm-extent-start-position extent)))) (setq type (downcase (car (vm-mm-layout-type layout))) type-no-subtype (car (vm-parse type "\\([^/]+\\)"))) (cond ((and vm-infer-mime-types (or (and vm-mime-attachment-infer-type-for-text-attachments (vm-mime-types-match "text/plain" type)) (vm-mime-types-match "application/octet-stream" type)) (setq file (vm-mime-get-disposition-filename layout)) (setq type2 (vm-mime-default-type-from-filename file)) (not (vm-mime-types-match type type2))) (vm-set-mm-layout-type layout (list type2)) (vm-set-mm-layout-qtype layout (list (concat "\"" type2 "\""))) (setq type (downcase (car (vm-mm-layout-type layout))) type-no-subtype (car (vm-parse type "\\([^/]+\\)"))))) (cond ((and (vm-mime-should-display-button layout dont-honor-c-d) (or (condition-case nil (funcall (intern (concat "vm-mime-display-button-" type)) layout) (void-function nil)) (condition-case nil (funcall (intern (concat "vm-mime-display-button-" type-no-subtype)) layout) (void-function nil))))) ((and (vm-mime-should-display-internal layout) (or (condition-case nil (funcall (intern (concat "vm-mime-display-internal-" type)) layout) (void-function nil)) (condition-case nil (funcall (intern (concat "vm-mime-display-internal-" type-no-subtype)) layout) (void-function nil))))) ((vm-mime-types-match "multipart" type) (or (condition-case nil (funcall (intern (concat "vm-mime-display-internal-" type)) layout) (void-function nil)) (vm-mime-display-internal-multipart/mixed layout))) ((and (vm-mime-can-display-external type) (vm-mime-display-external-generic layout)) (and 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))) ;; a button should always go away if we're doing ;; a conversion. (if extent (vm-set-extent-property extent 'vm-mime-disposable t)) (vm-decode-mime-layout new-layout)) (t (and extent (vm-mime-rewrite-failed-button extent (or (vm-mm-layout-display-error layout) "no external viewer defined for type"))) (if (vm-mime-types-match type "message/external-body") (if (null extent) (vm-mime-display-button-xxxx layout t) (setq extent nil)) (vm-mime-display-internal-application/octet-stream (or extent layout))))) (and extent (vm-mime-delete-button-maybe extent))) (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 no 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 (message "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) (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 by %s, be patient..." vm-mime-text/html-handler) (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) ;; 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) (message "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 (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 (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)) nil) (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) (and need-conversion (setq charset (vm-mime-charset-convert-region charset start end))) (vm-mime-charset-decode-region charset start end) (or no-highlighting (vm-energize-urls-in-message-region start end)) (if (and 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"))) (message "Decoding text/enriched, 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) ;; 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)) (message "%s" (vm-mm-layout-display-error layout)) (sleep-for 2) nil )) (vm-energize-urls-in-message-region start end) (goto-char end) (message "Decoding text/enriched... done") t )) (defun vm-mime-display-external-generic (layout) (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))) ;; 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)))) (message "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) (message "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) (if (vectorp layout) (let ((buffer-read-only nil) (vm-mf-default-action "save to a file")) (vm-mime-insert-button (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) (function (lambda (layout) (save-excursion (vm-mime-display-internal-application/octet-stream layout)))) layout nil)) (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)) (if 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) (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 (vm-decode-mime-layout (car part-list)) (setq part-list (cdr part-list))) t )) (defun vm-mime-display-internal-multipart/alternative (layout) (if (or vm-mime-show-alternatives (eq vm-mime-alternative-select-method 'all)) (let ((vm-mime-show-alternatives 'mixed)) (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-select-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-select-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-select-method) (eq (car vm-mime-alternative-select-method) 'favorite-internal)) (let ((done nil) (best nil) (saved-part-list (nreverse (copy-sequence (vm-mm-layout-parts layout)))) (favs (cdr vm-mime-alternative-select-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-select-method) (eq (car vm-mime-alternative-select-method) 'favorite)) (let ((done nil) (best nil) (saved-part-list (nreverse (copy-sequence (vm-mm-layout-parts layout)))) (favs (cdr vm-mime-alternative-select-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))))))) (and 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))))) (vm-decode-mime-layout start-part))) (defun vm-mime-display-button-multipart/parallel (layout) (vm-mime-insert-button (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) ) (function (lambda (layout) (save-excursion (let ((vm-auto-displayed-mime-content-types t) (vm-auto-displayed-mime-content-type-exceptions nil)) (vm-decode-mime-layout layout t))))) layout 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 (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) (function (lambda (layout) (save-excursion (vm-mime-display-internal-multipart/digest layout)))) layout nil)) (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 (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) (function (lambda (layout) (save-excursion (vm-mime-display-internal-message/rfc822 layout)))) layout nil))) (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 vm-visible-headers 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 (generate-new-buffer (format "message from %s/%s" (buffer-name vm-mail-buffer) (vm-number-of (car vm-message-pointer))))) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for new buffer (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-display-internal-message/external-body (layout) (let ((child-layout (car (vm-mm-layout-parts layout))) (access-method (downcase (vm-mime-get-parameter layout "access-type"))) ob (work-buffer nil)) ;; Normal objects have the header and body in the same ;; buffer. A retrieved external-body has the body in a ;; different buffer from the header, so we use this as an ;; indicator of whether the retrieval work has been dnoe ;; yet. (unwind-protect (cond ((and (eq 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))) (condition-case data (save-excursion (setq work-buffer (vm-make-multibyte-work-buffer (format "*%s mime object*" (car (vm-mm-layout-type child-layout))))) (set-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 (format "mail to MIME mail server %s" server) server subject) (mail-text) (vm-mime-insert-mime-body child-layout) (let ((vm-confirm-mail-send nil)) (vm-mail-send)) (message "Retrieval message sent. Retry viewing this object after the response arrives.") (sleep-for 2))) (t (vm-mime-error "unsupported access method: %s" access-method))) (cond (child-layout (setq work-buffer nil) (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 (vm-set-mm-layout-display-error layout (cdr data)) (setq child-layout nil))))) (and work-buffer (kill-buffer work-buffer))) (and child-layout (vm-decode-mime-layout child-layout)))) (defun vm-mime-fetch-url-with-programs (url buffer) (and (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) (cond ((vm-mime-types-match "message/external-body" (car (vm-mm-layout-type layout))) (if (not (string= (downcase (vm-mime-get-parameter layout "access-type")) "local-file")) nil (let ((work-buffer nil)) (unwind-protect (let ((child-layout (car (vm-mm-layout-parts layout))) oldsize (i (1- (length layout)))) (save-excursion (setq work-buffer (vm-make-multibyte-work-buffer (format "*%s mime object*" (car (vm-mm-layout-type child-layout))))) (set-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)))) (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)) (while (>= i 0) (aset layout i (aref child-layout i)) (setq i (1- i))))) (and 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 (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) (function (lambda (layout) (save-excursion (vm-mime-display-internal-message/partial layout)))) layout nil)) (message "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)) (if (< p-total 1) (vm-mime-error "message/partial specified part total < 1, %d" p-total)) (if total (if (not (= total p-total)) (vm-mime-error "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")) (if (null p-number) (vm-mime-error "message/partial message missing number parameter")) (setq p-number (string-to-number p-number)) (if (< p-number 1) (vm-mime-error "message/partial part number < 1, %d" p-number)) (if (and total (> p-number total)) (vm-mime-error "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) p-list (cdr p-list)))) (goto-char (vm-mm-layout-body-end o)))))) (if (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 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 (generate-new-buffer "assembled message")) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for new buffer (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 nil "\\(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 '("Subject" "MIME-Version" "Content-" "Message-ID" "Encrypted") 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) (message "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) (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-21-xxxx layout image-type name)) (vm-fsfemacs-p (vm-mime-display-internal-image-fsfemacs-19-xxxx layout image-type name)))) (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 (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 (message "Failed making image strips: %s" error-data) ;; fallback to the non-strips way (setq do-strips nil))))) (cond ((not do-strips) (message "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)))))) (message "") ;; 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-21-xxxx (layout image-type name) (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) (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 (message "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 ) nil )) (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 (message "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))) (and 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 (message "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 (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") (if incremental (progn (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)))) (if (not async) nil (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)) (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)) (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) (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)) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-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:-")))))) (if success (progn (write-region (point-min) (point-max) tempfile nil 0) (if (consp blob) (setcar (nthcdr 5 blob) 0)) (put (vm-mm-layout-cache layout) 'vm-image-modified t)))) (and work-buffer (kill-buffer work-buffer))) (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-mark-image-tempfile-as-message-garbage-once layout tempfile) (vm-mime-display-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" "*Max width and height of image thumbnail." :group 'vm :type '(choice string (const :tag "Disable thumbnails." nil))) (defun vm-mime-display-button-image (layout) "Displays an button for the image and when possible a thumbnail." (if (not (and vm-imagemagick-convert-program vm-mime-thumbnail-max-geometry (vm-images-possible-here-p))) ;; just display the normal button (vm-mime-display-button-xxxx layout t) ;; otherwise create a thumb and display it (let (tempfile start end x glyph) ;; fake an extent to display the image as thumb (setq start (point)) (insert " ") (setq x (vm-make-extent start (point))) (vm-set-extent-property x 'vm-mime-layout layout) (vm-set-extent-property x 'vm-mime-disposable nil) (vm-set-extent-property x 'start-open t) ;; write out the image data (save-excursion (set-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)) ;; force display (let ((vm-mime-internal-content-types '("image")) (vm-mime-internal-content-type-exceptions nil) (vm-mime-use-image-strips nil)) (vm-mime-frob-image-xxxx x "-thumbnail" vm-mime-thumbnail-max-geometry)) ;; extract image data (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 correct 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))) ;; force redisplay in original size (put (vm-mm-layout-cache layout) 'vm-mime-display-internal-image-xxxx nil) 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 (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) (save-excursion (let ((vm-auto-displayed-mime-content-types t) (vm-auto-displayed-mime-content-type-exceptions nil)) (vm-decode-mime-layout layout t)))) (defun vm-mime-display-button-xxxx (layout disposable) (vm-mime-insert-button (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) (function vm-mime-display-generic) layout disposable)) (defun vm-find-layout-extent-at-point () (cond (vm-fsfemacs-p (let (o-list o retval (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (cond ((overlay-get (car o-list) 'vm-mime-layout) (setq found t) (setq retval (car o-list)))) (setq o-list (cdr o-list))) retval )) (vm-xemacs-p (extent-at (point) nil 'vm-mime-layout)))) ;;;###autoload (defun vm-mime-run-display-function-at-point (&optional function dispose) "Display the MIME object at point according to its type." (interactive) ;; 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 ((e (vm-find-layout-extent-at-point)) retval ) (cond ((null e) nil) (vm-fsfemacs-p (funcall (or function (overlay-get e 'vm-mime-function)) e)) (vm-xemacs-p (funcall (or function (extent-property e 'vm-mime-function)) e)))))) ;;;###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))) (if 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)))) 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))) (if 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 folder) (error nil)))))) ;;;###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-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-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." (unless mlist (or count (setq count 1)) (vm-check-for-killed-folder) (vm-select-folder-buffer) (vm-error-if-folder-empty)) (let ((mlist (or mlist (vm-select-marked-or-prefixed-messages count)))) (save-excursion (while mlist (let (parts layout filename type disposition o) (setq o (vm-mm-layout (car mlist))) (when (stringp o) (setq o 'none) (backtrace) (message "There is a bug, please report it with *backtrace*")) (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) (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 (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) 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 (not quiet) (message "Action on part type=%s filename=%s disposition=%s!" type filename disposition)) (funcall action (car mlist) layout type filename)) ((not quiet) (message "No action on part type=%s filename=%s disposition=%s!" type filename disposition))) (setq parts (cdr parts))))) (setq mlist (cdr mlist)))))) ;;;###autoload (defun vm-mime-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-deletable-types' but not `vm-mime-deletable-type-exceptions' are also included." (interactive "p") (vm-check-for-killed-summary) (if (interactive-p) (vm-follow-summary-cursor)) (vm-mime-action-on-all-attachments count (lambda (msg layout type file) (message "Deleting `%s%s" type (if file (format " (%s)" file) "")) (vm-mime-discard-layout-contents layout)) vm-mime-deletable-types vm-mime-deletable-type-exceptions) (when (interactive-p) (vm-discard-cached-data) (vm-preview-current-message))) ;;;###autoload (defun vm-mime-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-savable-types' but not `vm-mime-savable-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 (interactive-p) (vm-follow-summary-cursor)) (let ((n 0)) (vm-mime-action-on-all-attachments count ;; the action to be performed BEGIN (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))) (when file (message "Saving `%s%s" type (if file (format " (%s)" file) "")) (make-directory (file-name-directory file) t) (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 n (+ 1 n))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END ;; attachment filters vm-mime-savable-types vm-mime-savable-type-exceptions) (when (interactive-p) (vm-discard-cached-data) (vm-preview-current-message)) (if (> n 0) (message "%d attachment%s saved" n (if (= n 1) "" "s")) (message "No attachments to be saved!")))) ;; for the karking compiler (defvar vm-menu-mime-dispose-menu) (defun vm-mime-set-image-stamp-for-type (e type) (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)))) (defvar 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) (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) (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 (caption action layout disposable) (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 (eq (symbol-function 'vm-make-extent) 'make-overlay) ;; 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 (make-overlay start (point) nil t nil)) (setq e (make-extent start (point))) (set-extent-property e 'start-open t) (set-extent-property e 'end-open t)) (vm-mime-set-image-stamp-for-type e (car (vm-mm-layout-type layout))) ;; for emacs (vm-set-extent-property e 'mouse-face 'highlight) (vm-set-extent-property e 'local-map keymap) ;; for xemacs (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 'vm-mime-layout layout) (vm-set-extent-property e 'vm-mime-function action) ;; for vm-continue-postponed-message (if vm-xemacs-p (vm-set-extent-property e 'duplicable t) (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)))) ;; 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-send-body-to-file (layout &optional default-filename file overwrite) (if (not (vectorp layout)) (setq layout (vm-extent-property layout 'vm-mime-layout))) (if (not default-filename) (setq default-filename (vm-mime-get-disposition-filename layout))) (and default-filename (setq default-filename (file-name-nondirectory default-filename))) (let ((work-buffer nil) ;; evade the XEmacs dialog box, yeccch. (use-dialog-box nil) (dir vm-mime-attachment-save-directory) (done nil)) (if file nil (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) (if (null default-filename) (error "%s is a directory" file)) (setq file (expand-file-name default-filename file) done t)))) (save-excursion (unwind-protect (let ((coding-system-for-read (vm-binary-coding-system))) (setq work-buffer (vm-make-work-buffer)) (set-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 ) (and work-buffer (kill-buffer work-buffer)))))) (defun vm-mime-send-body-to-folder (layout &optional default-filename) (if (not (vectorp layout)) (setq layout (vm-extent-property layout 'vm-mime-layout))) (let ((work-buffer nil) (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) (save-excursion (unwind-protect (let ((coding-system-for-read (vm-binary-coding-system)) (coding-system-for-write (vm-binary-coding-system))) (setq work-buffer (vm-make-work-buffer)) (set-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 ) (and work-buffer (kill-buffer work-buffer))))))) (defun vm-mime-pipe-body-to-command (command layout &optional discard-output) (if (not (vectorp layout)) (setq layout (vm-extent-property layout 'vm-mime-layout))) (let ((output-buffer (if discard-output 0 (get-buffer-create "*Shell Command Output*"))) (work-buffer nil)) (save-excursion (if (bufferp output-buffer) (progn (set-buffer output-buffer) (erase-buffer))) (unwind-protect (progn (setq work-buffer (vm-make-work-buffer)) ;; call-process-region calls write-region. ;; don't let it do CR -> LF translation. (setq selective-display nil) (set-buffer work-buffer) (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-windows 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))) (and work-buffer (kill-buffer work-buffer))) (if (bufferp output-buffer) (progn (set-buffer output-buffer) (if (not (zerop (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 (layout &optional discard-output) (let ((command (read-string "Pipe object to command: "))) (vm-mime-pipe-body-to-command command layout discard-output))) (defun vm-mime-pipe-body-to-queried-command-discard-output (layout) (vm-mime-pipe-body-to-queried-command layout t)) (defun vm-mime-send-body-to-printer (layout) (vm-mime-pipe-body-to-command (mapconcat (function identity) (nconc (list vm-print-command) vm-print-command-switches) " ") layout)) (defun vm-mime-display-body-as-text (button) (let ((vm-auto-displayed-mime-content-types '("text/plain")) (vm-auto-displayed-mime-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-auto-displayed-mime-content-types t) (vm-auto-displayed-mime-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)) (goto-char (vm-extent-start-position button)) (if (not (vm-mime-find-external-viewer (car (vm-mm-layout-type layout)))) (error "No viewer defined for type %s" (car (vm-mm-layout-type layout))) (vm-mime-display-external-generic layout)))) (defun vm-mime-convert-body-then-display (button) (let ((layout (vm-mime-convert-undisplayable-layout (vm-extent-property button 'vm-mime-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-get-button-layout (e) (vm-mime-run-display-function-at-point (function (lambda (e) (vm-extent-property e '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 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). (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? (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 (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 (car (cdr (vm-string-assoc name vm-mime-mule-charset-to-coding-alist)))) ;; 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-string-assoc name vm-mime-mule-charset-to-coding-alist) 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 by VM?" (cond ((and vm-xemacs-mule-p (memq (device-type) '(x gtk mswindows))) (or (vm-string-assoc name vm-mime-mule-charset-to-coding-alist) (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-mime-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-mime-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) (if (null vm-send-using-mime) (error "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)) (if (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: ")) (if (string-match "^[ \t]*$" description) (setq description nil)) (list file type charset description nil))) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (if (file-directory-p file) (error "%s is a directory, cannot attach" file)) (if (not (file-exists-p file)) (error "No such file: %s" file)) (if (not (file-readable-p file)) (error "You don't have permission to read %s" file)) (and charset (setq charset (list (concat "charset=" charset)))) (and description (setq description (vm-mime-scrub-description description))) (vm-mime-attach-object file type charset description nil)) ;;;###autoload (defun vm-mime-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-mime-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) (if (null vm-send-using-mime) (error "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))) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (if (file-directory-p file) (error "%s is a directory, cannot attach" file)) (if (not (file-exists-p file)) (error "No such file: %s" file)) (if (not (file-readable-p file)) (error "You don't have permission to read %s" file)) (vm-mime-attach-object file type nil nil t)) ;;;###autoload (defun vm-mime-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-mime-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) (if (null vm-send-using-mime) (error "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)) (if (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: ")) (if (string-match "^[ \t]*$" description) (setq description nil)) (list buffer-name type charset description))) (if (null (setq buffer (get-buffer buffer))) (error "Buffer %s does not exist." buffer)) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (and charset (setq charset (list (concat "charset=" charset)))) (and description (setq description (vm-mime-scrub-description description))) (vm-mime-attach-object buffer type charset description nil)) ;;;###autoload (defun vm-mime-attach-message (message &optional description) "Attach a message from a folder to a VM composition buffer to be sent along with the message. 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. 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) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (if 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))) (save-excursion (set-buffer (let ((coding-system-for-read (vm-binary-coding-system))) (find-file-noselect file))) (setq folder (current-buffer)) (vm-mode) (setq mlist (vm-select-marked-or-prefixed-messages 0))))) (t (setq folder vm-mail-buffer) (save-excursion (set-buffer folder) (setq mlist (vm-select-marked-or-prefixed-messages 0))))) (if (null mlist) (save-excursion (set-buffer folder) (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))) (if (null (setq mp (nthcdr (1- result) vm-message-list))) (error "No such message.")))) (setq description (read-string "Description: ")) (if (string-match "^[ \t]*$" description) (setq description nil)) (list (or mlist (car mp)) description))) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (if (not (consp message)) (let* ((buf (generate-new-buffer "*attached message*")) (m (vm-real-message-of message)) (folder (vm-buffer-of m))) (save-excursion (set-buffer buf) (if vm-fsfemacs-mule-p (set-buffer-multibyte nil)) ; for new 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 nil vm-internal-unforwarded-header-regexp)) (and description (setq description (vm-mime-scrub-description description))) (vm-mime-attach-object buf "message/rfc822" nil description nil) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list (list message)) (add-hook 'kill-buffer-hook (list 'lambda () (list 'if (list 'eq (current-buffer) '(current-buffer)) (list 'kill-buffer buf))))) (let ((buf (generate-new-buffer "*attached messages*")) boundary) (save-excursion (set-buffer buf) (setq boundary (vm-mime-encapsulate-messages message vm-mime-digest-headers vm-mime-digest-discard-header-regexp t)) (goto-char (point-min)) (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\n")) (and description (setq description (vm-mime-scrub-description description))) (vm-mime-attach-object buf "multipart/digest" (list (concat "boundary=\"" boundary "\"")) nil t) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list (copy-sequence message)) (add-hook 'kill-buffer-hook (list 'lambda () (list 'if (list 'eq (current-buffer) '(current-buffer)) (list 'kill-buffer buf))))))) ;;;###autoload (defun vm-mime-attach-object-from-message (composition) "Attach a object from the current message 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. 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 object to buffer: " (vm-find-composition-buffer) t)))) (if (null vm-send-using-mime) (error "MIME attachments disabled, set vm-send-using-mime non-nil to enable.")) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let (e layout (work-buffer nil) buf start w) (setq e (vm-find-layout-extent-at-point) layout (and e (vm-extent-property e 'vm-mime-layout))) (unwind-protect (if (null layout) (error "No MIME object found at point.") (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-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 nil "Content-Transfer-Encoding:") (insert "Content-Transfer-Encoding: binary\n") (set-buffer composition) (vm-mime-attach-object work-buffer (car (vm-mm-layout-type layout)) (cdr (vm-mm-layout-type layout)) (vm-mm-layout-description layout) t) ;; move windwo 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) (add-hook 'kill-buffer-hook (list 'lambda () (list 'if (list 'eq (current-buffer) '(current-buffer)) (list 'kill-buffer buf)))))) (and work-buffer (kill-buffer work-buffer))))) (defun vm-mime-attach-object (object type params description mimed &optional no-suggested-filename) (if (not (eq major-mode 'mail-mode)) (error "Command must be used in a VM Mail mode buffer.")) (if (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 disposition (fb (list vm-mime-forward-local-external-bodies))) (if (< (point) (save-excursion (mail-text) (point))) (mail-text)) (setq start (point)) (if (listp object) (setq tag-string (format "[ATTACHMENT %s, %s]" (nth 4 object) type)) (setq tag-string (format "[ATTACHMENT %s, %s]" object (or type "MIME file")))) (insert tag-string "\n") (setq end (1- (point))) (if (and (stringp object) (not mimed)) (progn (if (or (vm-mime-types-match "application" type) (vm-mime-types-match "model" type)) (setq disposition (list "attachment")) (setq disposition (list "inline"))) (if (not no-suggested-filename) (setq type (concat type "; name=\"" (file-name-nondirectory object) "\"") disposition (nconc disposition (list (concat "filename=\"" (file-name-nondirectory object) "\"")))))) (setq disposition (list "unspecified"))) (if (listp object) (setq disposition (nth 3 object))) (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-mime-button-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 (make-extent start end)) (vm-mime-set-image-stamp-for-type e (or type "text/plain")) (set-extent-property e 'start-open t) (set-extent-property e 'face vm-mime-button-face) (set-extent-property e 'duplicable t) (let ((keymap (make-sparse-keymap))) (if vm-popup-menu-on-mouse-3 (define-key keymap 'button3 'vm-menu-popup-attachment-menu)) (define-key keymap [return] 'vm-mime-change-content-disposition) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help)) (set-extent-property e 'vm-mime-forward-local-refs fb) (set-extent-property e 'vm-mime-type type) (set-extent-property e 'vm-mime-object object) (set-extent-property e 'vm-mime-parameters params) (set-extent-property e 'vm-mime-description description) (set-extent-property e 'vm-mime-disposition disposition) (set-extent-property e 'vm-mime-encoding nil) (set-extent-property e 'vm-mime-encoded mimed))))) (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 (extent-at (point) nil 'vm-mime-type)) (fb (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 (extent-at (point) nil 'vm-mime-type)) (fb (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 (extent-at (point) nil 'vm-mime-type))) (delete-region (extent-start-position e) (extent-end-position e)))))) (defun vm-mime-delete-attachment-button-keep-infos () (cond (vm-fsfemacs-p ;; TODO ) (vm-xemacs-p (let ((e (extent-at (point) nil 'vm-mime-type))) (save-excursion (goto-char (1+ (extent-start-position e))) (insert " --- DELETED ") (goto-char (extent-end-position e)) (insert " ---") (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 (extent-at (point) nil 'vm-mime-disposition)) (disp (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 (extent-at (point) nil 'vm-mime-disposition)) (disp (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 (extent-at (point) nil 'vm-mime-encoding))) (if e (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)) (vm-xemacs-p (let ((e (extent-at (point) nil 'vm-mime-disposition))) (set-extent-property e 'vm-mime-encoding sym))))) (defun vm-disallow-overlay-endpoint-insertion (overlay after start end &optional old-size) (cond ((null after) nil) ((= 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-fake-attachment-overlays (start end) (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 'vm-mime-object)) (setq pos (next-single-property-change pos 'vm-mime-object)) (or pos (setq pos (point-max) done t)) (if object (progn (setq o (make-overlay start pos)) (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)) (while props (overlay-put o (car props) (car (cdr props))) (setq props (cdr (cdr 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) (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) (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 (if (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))))) (if (not (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 nil "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 MIME object referred to by the MIME button 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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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.")) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (let (layout label) (cond (vm-fsfemacs-p (let (o-list o (found nil)) (setq o-list (overlays-at (point))) (while (and o-list (not found)) (setq o (car o-list)) (cond ((setq layout (overlay-get o 'vm-mime-layout)) (setq found t) (if (and (vm-mm-layout-message layout) (eq layout (vm-mime-layout-of (vm-mm-layout-message layout)))) (error "Can't delete only MIME object; use vm-delete-message instead.")) (if vm-mime-confirm-delete (or (y-or-n-p (vm-mime-sprintf "Delete %t? " layout)) (error "Aborted"))) (vm-mime-discard-layout-contents layout saved-file))) (setq o-list (cdr o-list))) (if (not found) (error "No MIME button found at point.")) (let ((inhibit-read-only t) (buffer-read-only nil)) (save-excursion (vm-save-restriction (goto-char (overlay-start o)) (setq label (vm-mime-sprintf vm-mime-deleted-object-label layout)) (insert label) (delete-region (point) (overlay-end o))))))) (vm-xemacs-p (let ((e (extent-at (point) nil 'vm-mime-layout))) (if (null e) (error "No MIME button found at point.") (setq layout (extent-property e 'vm-mime-layout)) (if (and (vm-mm-layout-message layout) (eq layout (vm-mime-layout-of (vm-mm-layout-message layout)))) (error "Can't delete only MIME object; use vm-delete-message instead.")) (if vm-mime-confirm-delete (or (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 (extent-start-position e)) (setq opos (point)) (setq label (vm-mime-sprintf vm-mime-deleted-object-label layout)) (insert label) (delete-region (point) (extent-end-position e)) (set-extent-endpoints e opos (point))))) (vm-mime-discard-layout-contents layout saved-file))))) (when (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: " (car (vm-mm-layout-qtype layout))) (if (cdr (vm-mm-layout-qtype layout)) (let ((p (cdr (vm-mm-layout-qtype layout)))) (insert "; " (mapconcat 'identity p "; ")))) (insert "\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)) ;; should use accessor and mutator functions ;; to copy the layout struct members, but i'm ;; tired. (let ((i (1- (length layout)))) (while (>= i 0) (aset layout i (aref new-layout i)) (setq i (1- i)))))) (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-string-assoc charset vm-mime-mule-charset-to-coding-alist) coding (and coding (cadr coding))) ;; 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) (vm-with-string-as-temp-buffer string '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 mail-header-separator) (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 () "MIME encode the current mail composition buffer. Attachment tags added to the buffer with `vm-mime-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 vm-mail-header-order 'none)) (buffer-enable-undo) (let ((unwind-needed t) (mybuffer (current-buffer))) (unwind-protect (progn (cond (vm-xemacs-p (vm-mime-xemacs-encode-composition)) (vm-fsfemacs-p (vm-mime-fsfemacs-encode-composition)) (t (error "don't know how to MIME encode composition for %s" (emacs-version)))) (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) ;; Non-XEmacs specific changes to this function should be made to ;; vm-mime-fsfemacs-encode-composition as well. (defun vm-mime-xemacs-encode-composition () "Encode the current message using MIME. The Multipurpose Internet Message Extensions extend the original format of Internet mail to allow non-US-ASCII textual messages, non-textual messages, multipart message bodies, and non-US-ASCII information in message headers. This function chooses the MIME character set(s) to use, and transforms the message content from the XEmacs-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.)" (save-restriction (widen) (if (not (eq major-mode 'mail-mode)) (error "Command must be used in a VM Mail mode buffer.")) (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) (error "Message is already MIME encoded.")) (let ((8bit nil) (just-one nil) (boundary-positions nil) (enriched (and (boundp 'enriched-mode) enriched-mode)) forward-local-refs already-mimed layout e e-list boundary type encoding charset params description disposition object opoint-min postponed-attachment) ;;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 (extent-list nil (point) (point-max)) e-list (vm-delete (function (lambda (e) (extent-property e 'vm-mime-object))) e-list t) e-list (sort e-list (function (lambda (e1 e2) (< (extent-end-position e1) (extent-end-position e2)))))) ;; 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) (extent-start-position (car e-list))) (save-excursion (goto-char (extent-end-position (car e-list))) (looking-at "[ \t\n]*\\'")))) (if (null e-list) (progn (narrow-to-region (point) (point-max)) ;; support enriched-mode for text/enriched composition (if enriched (let ((enriched-initial-annotation "")) (enriched-encode (point-min) (point-max)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (if vm-xemacs-mule-p (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.) (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (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)) (widen) (vm-remove-mail-mode-header-separator) (goto-char (point-min)) (vm-reorder-message-headers nil nil "\\(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)) (while e-list (setq e (car e-list)) (if (or just-one (save-excursion (eq (extent-start-position e) (re-search-forward "[ \t\n]*" (extent-start-position e) t)))) (delete-region (point) (extent-start-position e)) (narrow-to-region (point) (extent-start-position e)) (if enriched (let ((enriched-initial-annotation "")) (enriched-encode (point-min) (point-max)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (if vm-xemacs-mule-p (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.) (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (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))) (setq boundary-positions (cons (point-marker) boundary-positions)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (if description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (widen)) (goto-char (extent-start-position e)) (narrow-to-region (point) (point)) (setq object (extent-property e 'vm-mime-object)) ;; insert the object (cond ((bufferp object) (insert-buffer-substring object)) ((listp object) (save-restriction (save-excursion (set-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) )) ((stringp object) (let ((coding-system-for-read (if (vm-mime-text-type-p (extent-property e 'vm-mime-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 object)))) ;; gather information about the object from the extent. (if (setq already-mimed (extent-property e 'vm-mime-encoded)) (setq layout (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") "7bit") type (or (extent-property e 'vm-mime-type) (car (vm-mm-layout-type layout))) params (or (extent-property e 'vm-mime-parameters) (cdr (vm-mm-layout-qtype layout))) forward-local-refs (car (extent-property e 'vm-mime-forward-local-refs)) description (extent-property e 'vm-mime-description) disposition (if (not (equal (car (extent-property e 'vm-mime-disposition)) "unspecified")) (extent-property e 'vm-mime-disposition) (vm-mm-layout-qdisposition layout))) (setq type (extent-property e 'vm-mime-type) params (extent-property e 'vm-mime-parameters) forward-local-refs (car (extent-property e 'vm-mime-forward-local-refs)) description (extent-property e 'vm-mime-description) disposition (if (not (equal (car (extent-property e 'vm-mime-disposition)) "unspecified")) (extent-property e 'vm-mime-disposition) nil))) (cond ((vm-mime-types-match "text" type) (setq encoding (or (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)) (if (not already-mimed) (progn (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 (list "text/plain" "charset=us-ascii") "7bit")) (setq already-mimed t))) (and layout (not forward-local-refs) (vm-mime-internalize-local-external-bodies 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) (and layout (not forward-local-refs) (vm-mime-internalize-local-external-bodies layout)) (if already-mimed (setq encoding (vm-mime-transfer-encode-layout layout)) (vm-mime-base64-encode-region (point-min) (point-max)) (setq encoding "base64")))) (if (or just-one postponed-attachment) nil (goto-char (point-min)) (setq boundary-positions (cons (point-marker) boundary-positions)) (if (not already-mimed) nil ;; trim headers (vm-reorder-message-headers nil '("Content-ID:") nil) ;; remove header/text separator (goto-char (1- (vm-mm-layout-body-start layout))) (if (looking-at "\n") (delete-char 1))) (insert "Content-Type: " type) (if params (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity params "; ") "\n") (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) (insert "\n")) (and description (insert "Content-Description: " description "\n")) (if disposition (progn (insert "Content-Disposition: " (car disposition)) (if (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 (extent-start-position e)) (vm-assert (looking-at "\\[ATTACHMENT"))) (delete-region (extent-start-position e) (extent-end-position e)) (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)) (if enriched (let ((enriched-initial-annotation "")) (enriched-encode (point) (point-max)))) (setq charset (vm-determine-proper-charset (point) (point-max))) (if vm-xemacs-mule-p (encode-coding-region (point) (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.) (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (setq encoding (vm-determine-proper-content-transfer-encoding (point) (point-max)) encoding (vm-mime-transfer-encode-region encoding (point) (point-max) t) description (vm-mime-text-description (point) (point-max))) (setq 8bit (or 8bit (equal encoding "8bit"))) (setq boundary-positions (cons (point-marker) boundary-positions)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (if description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (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))) (if (and just-one already-mimed) (progn (goto-char (vm-mm-layout-header-start layout)) ;; trim headers (vm-reorder-message-headers nil '("Content-ID:") 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)) (if (not 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 nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") (vm-add-mail-mode-header-separator) (insert "MIME-Version: 1.0\n") (if (not just-one) (insert (if vm-mime-avoid-folding-content-type "Content-Type: multipart/mixed; boundary=\"" "Content-Type: multipart/mixed;\n\tboundary=\"") boundary "\"\n") (insert "Content-Type: " type) (if params (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity params "; ") "\n") (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) (insert "\n"))) (if (and just-one description) (insert "Content-Description: " description "\n")) (if (and just-one disposition) (progn (insert "Content-Disposition: " (car disposition)) (if (cdr disposition) (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity (cdr disposition) "; ") "\n") (insert ";\n\t" (mapconcat 'identity (cdr disposition) ";\n\t") "\n")) (insert "\n")))) (if just-one (insert "Content-Transfer-Encoding: " encoding "\n") (if 8bit (insert "Content-Transfer-Encoding: 8bit\n") (insert "Content-Transfer-Encoding: 7bit\n"))))))) ;; Non-FSF-Emacs specific changes to this function should be ;; made to vm-mime-xemacs-encode-composition as well. (defun vm-mime-fsfemacs-encode-composition () (save-restriction (widen) (if (not (eq major-mode 'mail-mode)) (error "Command must be used in a VM Mail mode buffer.")) (or (null (vm-mail-mode-get-header-contents "MIME-Version:")) (error "Message is already MIME encoded.")) (let ((8bit nil) (just-one nil) (boundary-positions nil) (enriched (and (boundp 'enriched-mode) enriched-mode)) forward-local-refs already-mimed layout o o-list boundary type encoding charset params description disposition object opoint-min delete-object postponed-attachment) (goto-char (mail-text-start)) (setq o-list (vm-mime-fake-attachment-overlays (point) (point-max)) o-list (vm-delete (function (lambda (o) (overlay-get o 'vm-mime-object))) o-list t) o-list (sort o-list (function (lambda (e1 e2) (< (overlay-end e1) (overlay-end e2)))))) ;; 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 o-list) 1) (looking-at "[ \t\n]*") (= (match-end 0) (overlay-start (car o-list))) (save-excursion (goto-char (overlay-end (car o-list))) (looking-at "[ \t\n]*\\'")))) (if (null o-list) (progn (narrow-to-region (point) (point-max)) ;; support enriched-mode for text/enriched composition (if enriched (let ((enriched-initial-annotation "")) (enriched-encode (point-min) (point-max)))) (setq charset (vm-determine-proper-charset (point-min) (point-max))) (if vm-fsfemacs-mule-p (let ((coding-system (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (if (null 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)) (widen) (vm-remove-mail-mode-header-separator) (goto-char (point-min)) (vm-reorder-message-headers nil nil "\\(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)) (while o-list (setq o (car o-list)) (if (or just-one (save-excursion (eq (overlay-start o) (re-search-forward "[ \t\n]*" (overlay-start o) t)))) (delete-region (point) (overlay-start o)) (narrow-to-region (point) (overlay-start o)) ;; support enriched-mode for text/enriched composition (if 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))) (if vm-fsfemacs-mule-p (let ((coding-system (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (if (null 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))) (setq boundary-positions (cons (point-marker) boundary-positions)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (if description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (widen)) (goto-char (overlay-start o)) (narrow-to-region (point) (point)) (setq object (overlay-get o 'vm-mime-object)) (setq delete-object nil) (cond ((bufferp object) ;; 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 (setq delete-object t) (save-excursion (set-buffer object) (let ((buffer-file-coding-system (vm-binary-coding-system))) (write-region (point-min) (point-max) tempfile nil 0)) (setq object tempfile))))) ;; insert attachment from postponed message (cond ((listp object) (save-restriction (save-excursion (set-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 the object (cond ((stringp object) ;; 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 work to prevent it. (insert-before-markers " ") (forward-char -1) (let ((coding-system-for-read (if (vm-mime-text-type-p (overlay-get o 'vm-mime-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 object) (error (if delete-object (vm-error-free-call 'delete-file object)) ;; 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)))))) (if delete-object (vm-error-free-call 'delete-file object)) (goto-char (point-max)) (delete-char -1))) ;; gather information about the object from the extent. (if (setq already-mimed (overlay-get o 'vm-mime-encoded)) (setq layout (vm-mime-parse-entity nil (list "text/plain" "charset=us-ascii") "7bit") type (or (overlay-get o 'vm-mime-type) (car (vm-mm-layout-type layout))) params (or (overlay-get o 'vm-mime-parameters) (cdr (vm-mm-layout-qtype layout))) forward-local-refs (car (overlay-get o 'vm-mime-forward-local-refs)) description (overlay-get o 'vm-mime-description) disposition (if (not (equal (car (overlay-get o 'vm-mime-disposition)) "unspecified")) (overlay-get o 'vm-mime-disposition) (vm-mm-layout-qdisposition layout))) (setq type (overlay-get o 'vm-mime-type) params (overlay-get o 'vm-mime-parameters) forward-local-refs (car (overlay-get o 'vm-mime-forward-local-refs)) description (overlay-get o 'vm-mime-description) disposition (if (not (equal (car (overlay-get o 'vm-mime-disposition)) "unspecified")) (overlay-get o 'vm-mime-disposition) nil))) (cond ((vm-mime-types-match "text" type) (setq encoding (or (overlay-get o '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)) (if (not already-mimed) (progn (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 (list "text/plain" "charset=us-ascii") "7bit")) (setq already-mimed t))) (and layout (not forward-local-refs) (vm-mime-internalize-local-external-bodies 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) (and layout (not forward-local-refs) (vm-mime-internalize-local-external-bodies layout)) (if already-mimed (setq encoding (vm-mime-transfer-encode-layout layout)) (vm-mime-base64-encode-region (point-min) (point-max)) (setq encoding "base64")))) (if (or just-one postponed-attachment) nil (goto-char (point-min)) (setq boundary-positions (cons (point-marker) boundary-positions)) (if (not already-mimed) nil ;; trim headers (vm-reorder-message-headers nil '("Content-ID:") nil) ;; remove header/text separator (goto-char (1- (vm-mm-layout-body-start layout))) (if (looking-at "\n") (delete-char 1))) (insert "Content-Type: " type) (if params (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity params "; ") "\n") (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) (insert "\n")) (and description (insert "Content-Description: " description "\n")) (if disposition (progn (insert "Content-Disposition: " (car disposition)) (if (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 (overlay-start o)) (vm-assert (looking-at "\\[ATTACHMENT"))) (delete-region (overlay-start o) (overlay-end o)) (delete-overlay o) (if (looking-at "\n") (delete-char 1)) (setq o-list (cdr o-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)) ;; support enriched-mode for text/enriched composition (if enriched (let ((enriched-initial-annotation "")) (enriched-encode (point) (point-max)))) (setq charset (vm-determine-proper-charset (point) (point-max))) (if vm-fsfemacs-mule-p (let ((coding-system (car (cdr (vm-string-assoc charset vm-mime-mule-charset-to-coding-alist))))) (if (null coding-system) (error "Can't find a coding system for charset %s" charset) (encode-coding-region (point) (point-max) coding-system)))) (setq encoding (vm-determine-proper-content-transfer-encoding (point) (point-max)) encoding (vm-mime-transfer-encode-region encoding (point) (point-max) t) description (vm-mime-text-description (point) (point-max))) (setq 8bit (or 8bit (equal encoding "8bit"))) (setq boundary-positions (cons (point-marker) boundary-positions)) (if enriched (insert "Content-Type: text/enriched; charset=" charset "\n") (insert "Content-Type: text/plain; charset=" charset "\n")) (if description (insert "Content-Description: " description "\n")) (insert "Content-Transfer-Encoding: " encoding "\n\n") (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))) (if (and just-one already-mimed) (progn (goto-char (vm-mm-layout-header-start layout)) ;; trim headers (vm-reorder-message-headers nil '("Content-ID:") 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)) (if (not 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 nil "\\(Content-Type:\\|MIME-Version:\\|Content-Transfer-Encoding\\)") (vm-add-mail-mode-header-separator) (insert "MIME-Version: 1.0\n") (if (not just-one) (insert (if vm-mime-avoid-folding-content-type "Content-Type: multipart/mixed; boundary=\"" "Content-Type: multipart/mixed;\n\tboundary=\"") boundary "\"\n") (insert "Content-Type: " type) (if params (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity params "; ") "\n") (insert ";\n\t" (mapconcat 'identity params ";\n\t") "\n")) (insert "\n"))) (if (and just-one description) (insert "Content-Description: " description "\n")) (if (and just-one disposition) (progn (insert "Content-Disposition: " (car disposition)) (if (cdr disposition) (if vm-mime-avoid-folding-content-type (insert "; " (mapconcat 'identity (cdr disposition) "; ") "\n") (insert ";\n\t" (mapconcat 'identity (cdr disposition) ";\n\t") "\n")) (insert "\n")))) (if just-one (insert "Content-Transfer-Encoding: " encoding "\n") (if 8bit (insert "Content-Transfer-Encoding: 8bit\n") (insert "Content-Transfer-Encoding: 7bit\n"))))))) (defun vm-mime-fragment-composition (size) (save-restriction (widen) (message "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 (list "text/plain" "charset=us-ascii") "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 nil "\\(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=%s" n)) (insert (format ";\n\ttotal=%s" 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)) (message "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) (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 '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)) (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-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) (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)))) nil )) (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")) (defun vm-mf-default-action (layout) (if (eq vm-mime-show-alternatives 'mixed) (concat (vm-mf-default-action-orig layout) " alternative") (vm-mf-default-action-orig layout))) (defun vm-mf-default-action-orig (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)))) (format "convert to %s and display" (nth 1 cons))) (t "save to a file"))) ;; 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-mime-list-part-structure (&optional verbose) "List mime part structure of the current message." (interactive "P") (vm-check-for-killed-summary) (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (let ((m (car vm-message-pointer))) (switch-to-buffer "*VM mime part layout*") (erase-buffer) (setq truncate-lines t) (insert (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 (insert (format "%s%S\n" (make-string (length path) ? ) layout)) (insert (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) ""))))))))) ;;;###autoload (defun vm-mime-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-mime-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 (interactive-p) (vm-check-for-killed-summary) (vm-follow-summary-cursor) (vm-select-folder-buffer)) (let ((mlist (or mlist (vm-select-marked-or-prefixed-messages count)))) (save-excursion (while mlist (let ((count (vm-mime-nuke-alternative-text/html-internal (car mlist)))) (when (interactive-p) (if (= count 0) (message "No text/html parts found.") (message "%d text/html part%s deleted." count (if (> count 1) "s" "")))) (setq mlist (cdr mlist)))))) (when (interactive-p) (vm-discard-cached-data count))) (provide 'vm-mime) ;;; vm-mime.el ends here vm-8.1.2/lisp/vm-imap.el0000644000175000017500000041360211725175471015275 0ustar srivastasrivasta;;; vm-imap.el --- Simple IMAP4 (RFC 2060) client for 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 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: (eval-when-compile (require 'sendmail) (require 'vm-vars) (require 'vm-misc) (require 'vm-macro)) (defvar selectable-only) ; used with dynamic binding ;; To-Do (USR) ;; - Need to ensure that new imap sessions get created as and when needed. ;; ------------------------------------------------------------------------ ;; Utilities ;; ------------------------------------------------------------------------ ;; 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 (defun vm-imap-session-type:set (type) (setq vm-imap-session-type type)) (defun 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) (save-excursion (set-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)))) (if (fboundp 'define-error) (progn (define-error 'vm-imap-protocol-error "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")) (defun vm-imap-capability (cap &optional process) (if process (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) ;;------------------- (vm-buffer-type:exit) ;;------------------- (memq cap vm-imap-capabilities)) (memq cap vm-imap-capabilities))) (defun vm-imap-auth-method (auth) (memq auth vm-imap-auth-methods)) ;; 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 (defsubst vm-folder-imap-process () (aref vm-folder-access-data 1)) ;; the uid validity value of the imap folder (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 ;; (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 (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 (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 (defsubst vm-folder-imap-flags-obarray () (aref vm-folder-access-data 10)) ; obarray(uid, (size . flags list)) ; cons-pair shared with imap-uid-list (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)) (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))) ))) (defsubst vm-imap-delete-message (process n) (vm-imap-delete-messages process n n)) ;; ----------------------------------------------------------------------- ;; 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-clear-invalid-retrieval-entries: ... ;; ------------------------------------------------------------------------ (defsubst vm-imap-fetch-message (process n use-body-peek &optional headers-only) (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) (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)))) ;; 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 (and (fboundp 'find-file-name-handler) (condition-case () (find-file-name-handler source 'vm-imap-move-mail) (wrong-number-of-arguments (find-file-name-handler source))))) (imapdrop (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) (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 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)) (t (if vm-imap-expunge-after-retrieving t (message (concat "Leaving messages on IMAP server; " "See info under \"IMAP Spool Files\"")) (sit-for 4) nil)))) (unwind-protect (catch 'end-of-session (if handler (throw 'end-of-session (funcall handler 'vm-imap-move-mail source destination))) (setq process (vm-imap-make-session source)) (or process (throw 'end-of-session nil)) (setq process-buffer (process-buffer process)) (save-excursion (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)) (setq mailbox-count (nth 0 select) uid-validity (nth 1 select) read-write (nth 2 select) can-delete (nth 3 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-stat-x-box statblob imapdrop) (vm-set-imap-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-imap-stat-x-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) (if (member msgid imap-retrieved-messages) (progn (if vm-imap-ok-to-ask (message "Skipping message %d (of %d) from %s (retrieved already)..." n mailbox-count imapdrop)) (throw 'skip t)))) (setq message-size (vm-imap-get-message-size process n)) (vm-set-imap-stat-x-need statblob message-size) (if (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)))) (progn (if (and read-write can-delete (eq response 'delete)) (progn (message "Deleting message %d..." n) (vm-imap-delete-message process n) (setq did-delete t)) (if vm-imap-ok-to-ask (message "Skipping message %d..." n) (message "Skipping message %d in %s, too large (%d > %d)..." n imapdrop message-size vm-imap-max-message-size))) (throw 'skip t))) (message "Retrieving message %d (of %d) from %s..." n mailbox-count imapdrop) (vm-imap-fetch-message process n use-body-peek nil) (vm-imap-retrieve-to-target process destination statblob use-body-peek) (vm-imap-read-ok-response process) (message "Retrieving message %d (of %d) from %s...done" n mailbox-count imapdrop) (vm-increment retrieved) (and b-per-session (setq retrieved-bytes (+ retrieved-bytes message-size))) (setq imap-retrieved-messages (cons (copy-sequence msgid) imap-retrieved-messages)) (if auto-expunge ;; The user doesn't want the messages ;; kept in the mailbox. ;; Delete the message now. (if (and read-write can-delete) (progn (vm-imap-delete-message process n) (setq did-delete t))))) (vm-increment n)) (if did-delete (progn ;; 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) ;;---------------------------------- )) ;;------------------- (vm-buffer-type:exit) ;;------------------- (not (equal retrieved 0)) ; return result )) ;; unwind-protections (setq vm-imap-retrieved-messages imap-retrieved-messages) (if (and (eq vm-flush-interval t) (not (equal retrieved 0))) (vm-stuff-imap-retrieved)) (when statblob (vm-imap-stop-status-timer statblob)) (when process (vm-imap-end-session process)) ))) (defun vm-imap-check-mail (source) ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (let ((process nil) (handler (and (fboundp 'find-file-name-handler) (condition-case () (find-file-name-handler source 'vm-imap-check-mail) (wrong-number-of-arguments (find-file-name-handler source))))) (retrieved vm-imap-retrieved-messages) (imapdrop (vm-imapdrop-sans-password source)) (count 0) msg-count uid-validity x response select mailbox source-list result) (unwind-protect (prog1 (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (catch 'end-of-session (if handler (throw 'end-of-session (funcall handler 'vm-imap-check-mail source))) (setq process (vm-imap-make-session source)) (or 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) msg-count (car select) uid-validity (nth 1 select)) (if (zerop msg-count) (progn (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 (when process (vm-imap-end-session process) ;; (vm-imap-dump-uid-and-flags-data) ;;------------------- (vm-buffer-type:exit) ;;------------------- )))) (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) (vm-check-for-killed-summary) (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 imapdrop uid-alist mailbox data mp match) (unwind-protect (save-excursion ;;------------------------ (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)) (if (not (equal source (nth 2 data))) (progn (if process (progn (if did-delete (progn (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 imapdrop (vm-safe-imapdrop-string source)) (condition-case error-data (progn (message "Opening IMAP session to %s..." imapdrop) (setq process (vm-imap-make-session source)) (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) msg-count (car select-response) uid-validity (nth 1 select-response) read-write (nth 2 select-response) can-delete (nth 3 select-response)) (setq mp (vm-imap-clear-invalid-retrieval-entries source mp uid-validity)) (if (not (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)) (if (not can-delete) (error "Can't delete messages in mailbox %s, skipping..." mailbox)) (if (not read-write) (error "Mailbox %s is read-only, skipping..." mailbox)) (message "Expunging messages in %s..." imapdrop)) (error (if (cdr error-data) (apply 'message (cdr error-data)) (message "Couldn't open IMAP session to %s, skipping..." imapdrop)) (setq trouble (cons imapdrop trouble)) (sleep-for 2) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t))) (if (zerop msg-count) (progn (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)))) (if (setq match (rassoc (car data) uid-alist)) (progn (vm-imap-delete-message process (car match)) (setq did-delete t) (vm-increment delete-count)))) (error (setq trouble (cons imapdrop trouble)) (message "Something signaled: %s" (prin1-to-string error-data)) (sleep-for 2) (message "Skipping rest of mailbox %s..." imapdrop) (sleep-for 2) (while (equal (nth 2 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t))) (setq mp (cdr mp)))) (if did-delete (progn (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))) (message "%s IMAP message%s expunged." (if (zerop delete-count) "No" delete-count) (if (= delete-count 1) "" "s"))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (and process (vm-imap-end-session process))) (or trouble (setq vm-imap-retrieved-messages nil)))) (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) (vm-check-for-killed-summary) (vm-error-if-virtual-folder) (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)) (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) (message "No messages to be pruned") (set-buffer-modified-p t) (vm-update-summary-and-mode-line) (message "%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-nopwd retrieved uid-validity) (let ((x retrieved) (prev nil)) (while x (if (and (equal source-nopwd (nth 2 (car x))) (not (equal (nth 1 (car x)) uid-validity))) (if prev (setcdr prev (cdr x)) (setq retrieved (cdr retrieved)))) (setq x (cdr x))) retrieved )) ;; -------------------------------------------------------------------- ;; Server-side ;; ;; vm-establish-new-folder-imap-session: (&optional interactive) -> void ;; vm-re-establish-folder-imap-session: (&optional interactive) -> void ;; ;; -- 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) -> ;; (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-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-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. ;; Create a process for a new IMAP session to the account SOURCE and ;; return it. ;;;###autoload (defun vm-imap-make-session (source) "Create a new IMAP session for the IMAP mail box SOURCE." (let ((process-to-shutdown nil) (folder-type vm-folder-type) process ooo (imapdrop (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 source-list process-buffer source-nopwd-nombox) (unwind-protect (catch 'end-of-session ;; 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-password-and-mailbox source)) (cond ((equal auth "preauth") t) ((equal "imap-ssl" (car source-list)) (setq use-ssl t session-name "IMAP over SSL") (if (null vm-stunnel-program) (error "vm-stunnel-program must be non-nil to use IMAP over SSL."))) ((equal "imap-ssh" (car source-list)) (setq use-ssh t session-name "IMAP over SSH") (if (null vm-ssh-program) (error "vm-ssh-program must be non-nil to use IMAP over SSH.")))) ;; carp if parts are missing (if (null host) (error "No host in IMAP maildrop specification, \"%s\"" source)) (if (null port) (error "No port in IMAP maildrop specification, \"%s\"" source)) (if (string-match "^[0-9]+$" port) (setq port (string-to-number port))) (if (null auth) (error "No authentication method in IMAP maildrop specification, \"%s\"" source)) (if (null user) (error "No user in IMAP maildrop specification, \"%s\"" source)) (if (null pass) (error "No password in IMAP maildrop specification, \"%s\"" source)) (if (and (equal pass "*") (not (equal auth "preauth"))) (progn (setq pass (car (cdr (assoc source-nopwd-nombox vm-imap-passwords)))) (if (null pass) (if (null vm-imap-ok-to-ask) (progn (message "Need password for %s" imapdrop) (throw 'end-of-session nil)) (setq pass (read-passwd (format "IMAP password for %s: " imapdrop))))))) ;; save the password for the sake of ;; vm-expunge-imap-messages, which passes password-less ;; imapdrop specifications to vm-make-imap-session. (if (null (assoc source-nopwd-nombox vm-imap-passwords)) (setq vm-imap-passwords (cons (list source-nopwd-nombox pass) vm-imap-passwords))) ;; get the trace buffer (setq process-buffer (vm-make-work-buffer (format "trace of %s session to %s" session-name host))) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer process-buffer) (setq vm-folder-type (or folder-type vm-default-folder-type)) (buffer-disable-undo process-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) "\n") (insert (format "connecting to %s:%s\n" host port)) ;; open the connection to the server (cond (use-ssl (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 'end-of-session nil)) (insert-before-markers "connected\n")) (setq vm-imap-read-point (point)) (vm-process-kill-without-query process) (if (null (setq greeting (vm-imap-read-greeting process))) (progn (delete-process process) (throw 'end-of-session nil))) (setq process-to-shutdown process) (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))) (if (null (vm-imap-read-ok-response process)) (progn (setq vm-imap-passwords (delete (list source-nopwd-nombox pass) vm-imap-passwords)) (message "IMAP password for %s incorrect" imapdrop) ;; don't sleep unless we're running synchronously. (if vm-imap-ok-to-ask (sleep-for 2)) (throw 'end-of-session nil)) ;;-------------------------------- (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) (if (null (vm-imap-read-ok-response process)) (progn (setq vm-imap-passwords (delete (list source-nopwd-nombox pass) vm-imap-passwords)) (message "IMAP password for %s incorrect" imapdrop) ;; don't sleep unless we're running synchronously. (if vm-imap-ok-to-ask (sleep-for 2)) (throw 'end-of-session nil)) ;;------------------------------- (vm-imap-session-type:set 'active) ;;------------------------------- ))) ((equal auth "preauth") (if (not (eq greeting 'preauth)) (progn (message "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)) ;;------------------------------- (vm-imap-session-type:set 'active) ;;------------------------------- )) (t (error "Don't know how to authenticate using %s" auth))) (setq process-to-shutdown nil) ;;------------------- (vm-buffer-type:exit) ;;------------------- process )) (if process-to-shutdown ; unwind-protection (vm-imap-end-session process-to-shutdown t)) (vm-tear-down-stunnel-random-data)))) ;; Kill the IMAP session represented by PROCESS. If the optional ;; argument KEEP-BUFFER is non-nil, the process buffer is retained, ;; otherwise it is killed as well ;;;###autoload (defun vm-imap-end-session (process &optional keep-buffer) "End the IMAP session denoted by PROCESS. Unless the optional argument KEEP-BUFFER is non-nil, the process-buffer is deleted. See also `vm-imap-keep-trace-buffer'." (if (and (memq (process-status process) '(open run)) (buffer-live-p (process-buffer process))) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer 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. (if vm-imap-session-done ;;------------------------------------- (vm-imap-session-type:assert 'inactive) ;;------------------------------------- (vm-imap-send-command process "LOGOUT") (setq vm-imap-session-done t) ;; we don't care about the response. ;; try reading it anyway and see who complains. (vm-imap-read-ok-response process) ;;---------------------------------- (vm-imap-session-type:set 'inactive) ;;---------------------------------- (if (and (not vm-imap-keep-trace-buffer) (not keep-buffer)) (kill-buffer (process-buffer process)) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) (rename-buffer (concat "saved " (buffer-name)) t) (vm-keep-some-buffers (current-buffer) 'vm-kept-imap-buffers vm-imap-keep-failed-trace-buffers) ;;------------------- (vm-buffer-type:exit) ;;------------------- )) (if (fboundp 'add-async-timeout) (add-async-timeout 2 'delete-process process) (run-at-time 2 nil 'delete-process process))) ;;---------------------------------- (vm-buffer-type:exit) ;;---------------------------------- ))) ;; Status indicator vector ;; timer (defun vm-imap-stat-timer (o) (aref o 0)) ;; whether the current status has been reported already (defun vm-imap-stat-did-report (o) (aref o 1)) ;; mailbox specification (defun vm-imap-stat-x-box (o) (aref o 2)) ;; message number (count) of the message currently being retrieved (defun vm-imap-stat-x-currmsg (o) (aref o 3)) ;; total number of mesasges that need to be retrieved in this round (defun vm-imap-stat-x-maxmsg (o) (aref o 4)) ;; amount of the current message that has been retrieved (defun vm-imap-stat-x-got (o) (aref o 5)) ;; size of the current message (defun vm-imap-stat-x-need (o) (aref o 6)) ;; Data for the message last reported (defun vm-imap-stat-y-box (o) (aref o 7)) (defun vm-imap-stat-y-currmsg (o) (aref o 8)) (defun vm-imap-stat-y-maxmsg (o) (aref o 9)) (defun vm-imap-stat-y-got (o) (aref o 10)) (defun vm-imap-stat-y-need (o) (aref o 11)) (defun vm-set-imap-stat-timer (o val) (aset o 0 val)) (defun vm-set-imap-stat-did-report (o val) (aset o 1 val)) (defun vm-set-imap-stat-x-box (o val) (aset o 2 val)) (defun vm-set-imap-stat-x-currmsg (o val) (aset o 3 val)) (defun vm-set-imap-stat-x-maxmsg (o val) (aset o 4 val)) (defun vm-set-imap-stat-x-got (o val) (aset o 5 val)) (defun vm-set-imap-stat-x-need (o val) (aset o 6 val)) (defun vm-set-imap-stat-y-box (o val) (aset o 7 val)) (defun vm-set-imap-stat-y-currmsg (o val) (aset o 8 val)) (defun vm-set-imap-stat-y-maxmsg (o val) (aset o 9 val)) (defun vm-set-imap-stat-y-got (o val) (aset o 10 val)) (defun vm-set-imap-stat-y-need (o val) (aset o 11 val)) (defun vm-imap-start-status-timer () (let ((blob (make-vector 12 nil)) timer) (setq timer (add-timeout 5 'vm-imap-report-retrieval-status blob 5)) (vm-set-imap-stat-timer blob timer) blob )) (defun vm-imap-stop-status-timer (status-blob) (if (vm-imap-stat-did-report status-blob) (message "")) (if (fboundp 'disable-timeout) (disable-timeout (vm-imap-stat-timer status-blob)) (cancel-timer (vm-imap-stat-timer status-blob)))) (defun vm-imap-report-retrieval-status (o) (vm-set-imap-stat-did-report o t) (cond ((null (vm-imap-stat-x-got o)) t) ;; should not be possible, but better safe... ((not (eq (vm-imap-stat-x-box o) (vm-imap-stat-y-box o))) t) ((not (eq (vm-imap-stat-x-currmsg o) (vm-imap-stat-y-currmsg o))) t) (t (message "Retrieving message %d (of %d) from %s, %s..." (vm-imap-stat-x-currmsg o) (vm-imap-stat-x-maxmsg o) (vm-imap-stat-x-box o) (if (vm-imap-stat-x-need o) (format "%d%s of %d%s" (vm-imap-stat-x-got o) (if (> (vm-imap-stat-x-got o) (vm-imap-stat-x-need o)) "!" "") (vm-imap-stat-x-need o) (if (eq (vm-imap-stat-x-got o) (vm-imap-stat-y-got o)) " (stalled)" "")) "post processing")))) (vm-set-imap-stat-y-box o (vm-imap-stat-x-box o)) (vm-set-imap-stat-y-currmsg o (vm-imap-stat-x-currmsg o)) (vm-set-imap-stat-y-maxmsg o (vm-imap-stat-x-maxmsg o)) (vm-set-imap-stat-y-got o (vm-imap-stat-x-got o)) (vm-set-imap-stat-y-need o (vm-imap-stat-x-need o))) (defun vm-imap-check-connection (process) (cond ((not (memq (process-status process) '(open run))) (vm-imap-protocol-error "IMAP connection not open: %s" process)) ((not (buffer-live-p (process-buffer process))) (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-buffer-type:assert 'process) ;;------------------------------ (vm-imap-check-connection process) (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-examine) ;; I/O function to select an IMAP mailbox ;; PROCESS - the IMAP process ;; MAILBOX - the name fo the mailbox to be selected ;; JUST-EXAMINE - select the mailbox in a read-only (examine) mode ;; Returns a list containing: ;; int msg-count - number of 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) (uid-validity nil) (read-write (not just-examine)) (can-delete t) (need-ok t)) (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 '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 t)) ((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")) (if (vm-imap-scan-list-for-flag permanent-flags "\\*") (if (vm-imap-scan-list-for-flag flags "\\Seen") nil (message "Warning: No permanent changes permitted for the mailbox")) (message "Warning: Only basic message flags available for the mailbox") ) ;;------------------------------- (vm-imap-session-type:set 'active) ;;------------------------------- (list msg-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 ) (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 assoc list 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 (let ((list nil) (imap-buffer (current-buffer)) tok msg-num uid response p (need-ok t)) ;;---------------------------------- (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)))) ;; 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) ;; Or gives an error if the message has an invalid uid (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-protocol-error "message has invalid uid")) ;;---------------------------------- (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-protocol-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 ;; or nil indicating failure ;; If there are no messages in the range then (nil) is returned (let ((list nil) (imap-buffer (current-buffer)) tok msg-num uid size flag flags response p pl (need-ok t)) ;;---------------------------------- (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)))) ;; returning nil means the fetch failed so return ;; something other than nil if there aren't any messages. (if (null list) (cons nil 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 ;;------------------------ (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 vm-visible-headers vm-invisible-header-regexp))) (set-window-point (selected-window) (point)) ;;------------------- (vm-buffer-type:exit) ;;------------------- (if (y-or-n-p (format "Retrieve message %d (size = %d)? " n size)) 'retrieve (if (y-or-n-p (format "Delete message %d from maildrop? " n)) 'delete 'skip)))) (and 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))) (let ((***start vm-imap-read-point) ; avoid dynamic binding of 'start' end fetch-response list p) (goto-char ***start) (vm-set-imap-stat-x-got statblob 0) (let* ((func (function (lambda (beg end len) (if vm-imap-read-point (progn (vm-set-imap-stat-x-got statblob (- end ***start)) (if (zerop (% (random) 10)) (vm-imap-report-retrieval-status statblob))))))) ;; this seems to slow things down ;;(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-protocol-error "Expected FETCH response not received")))) ;; 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 (if (not (vm-imap-response-matches list 'BODY '(vector) 'string)) (vm-imap-protocol-error "expected (BODY[] string) in FETCH response")) (setq p (nth 2 list) ***start (nth 1 p))) (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-stat-x-need statblob nil) (vm-imap-cleanup-region ***start end) (vm-munge-message-separators vm-folder-type ***start end) (goto-char ***start) (vm-set-imap-stat-x-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) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'unknown) ;;---------------------------- (set-buffer target) ;;------------------- (vm-buffer-type:exit) ;;------------------- (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)) ;; 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. ;; ;; HP Openmail seems to have this problem. (if (and (not (eq ?\n (char-after (1- (point))))) (memq vm-folder-type '(From_-with-Content-Length BellFrom_))) (insert-before-markers "\n")) (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 ;;---------------------------- (vm-buffer-type:enter 'unknown) ;;---------------------------- (set-buffer target) (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-protocol-error "STORE ... +FLAGS.SILENT (\\Deleted) failed"))) (defun vm-imap-get-message-size (process n) (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-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))) (if (not (vm-imap-response-matches p 'RFC822\.SIZE 'atom)) (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-read-capability-response (process) ;;---------------------------------- (vm-buffer-type:assert 'process) ;;---------------------------------- (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) ;;---------------------------------- (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) ;;---------------------------------- (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)) (t (setq retval nil done t)))) 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))) ;;-------------------------------------------- (let ((list nil) tail obj) (goto-char vm-imap-read-point) (while (not (eq (car (setq obj (vm-imap-read-object process))) 'end-of-line)) (if (null list) (setq list (cons obj nil) tail list) (setcdr tail (cons obj nil)) (setq tail (cdr tail)))) list )) (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-protocol-error (format "server said NO to %s" (or command-desc "command")))) (if (vm-imap-response-matches response 'VM 'BAD) (vm-imap-protocol-error (format "server said BAD to %s" (or command-desc "command")))) (if (vm-imap-response-matches response '* 'BYE) (vm-imap-protocol-error (format "server said BYE to %s" (or command-desc "command")))) 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. (if vm-buffer-type-debug (vm-buffer-type:assert 'process)) ;;---------------------------------- (let ((done nil) opoint (token nil)) (while (not done) (skip-chars-forward " \t") (cond ((< (- (point-max) (point)) 2) (setq opoint (point)) (vm-imap-check-connection process) (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 "\\[") (forward-char 1) (let* ((list (list 'vector)) (tail list) obj) (while (not (eq (car (setq obj (vm-imap-read-object process t))) 'close-bracket)) (if (eq (car obj) 'close-paren) (vm-imap-protocol-error "unexpected )")) (setcdr tail (cons obj nil)) (setq tail (cdr tail))) (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) (while (not (eq (car (setq obj (vm-imap-read-object process t))) 'close-paren)) (if (eq (car obj) 'close-bracket) (vm-imap-protocol-error "unexpected ]")) (setcdr tail (cons obj nil)) (setq tail (cdr tail))) (setq token list done t))) ((looking-at ")") (forward-char 1) (setq token '(close-paren) done t)) ((looking-at "{") (forward-char 1) (let (start obj n-octets) (setq obj (vm-imap-read-object process)) (if (not (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)) (if (not (eq (car obj) 'close-brace)) (vm-imap-protocol-error "} expected")) (setq obj (vm-imap-read-object process)) (if (not (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) (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) (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 "unexpected 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) (accept-process-output process) (goto-char curpoint)) (setq token (list 'atom start curpoint))))))) (setq vm-imap-read-point (point)) token )) (defun vm-imap-response-matches (response &rest expr) (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-protocol-error (&rest args) (set (make-local-variable 'vm-imap-keep-trace-buffer) t) (signal 'vm-imap-protocol-error (list (apply 'format args)))) (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-re-establish-folder-imap-session (&optional interactive) (let ((process (vm-folder-imap-process))) (if (and (processp process) (memq (process-status process) '(open run))) process (vm-establish-new-folder-imap-session interactive)))) ;; Kill and restart the IMAP session for the current folder. This is ;; necessary because we might unexpected EXPUNGE responses which we ;; don't know how to deal with. (defun vm-establish-new-folder-imap-session (&optional interactive) (let ((process (vm-folder-imap-process)) mailbox select mailbox-count uid-validity permanent-flags read-write can-delete body-peek (vm-imap-ok-to-ask interactive)) (if (processp process) (vm-imap-end-session process)) (setq process (vm-imap-make-session (vm-folder-imap-maildrop-spec))) (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)) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) (setq select (vm-imap-select-mailbox process mailbox)) (setq mailbox-count (nth 0 select) uid-validity (nth 1 select) read-write (nth 2 select) can-delete (nth 3 select) permanent-flags (nth 4 select) body-peek (vm-imap-capability 'IMAP4REV1)) ;;--------------------------------- (vm-imap-session-type:set 'active) (vm-buffer-type:exit) ;;--------------------------------- ) (vm-set-folder-imap-uid-validity uid-validity) ; unique per session (vm-set-folder-imap-mailbox-count mailbox-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-imap-retrieve-uid-and-flags-data () ;;------------------------------ (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) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer 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) (vm-buffer-type:exit) ;;------------------------------- ) (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)) (save-excursion (set-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) (if (not (equal (vm-imap-uid-validity-of m) (vm-folder-imap-uid-validity))) (vm-imap-protocol-error "message has invalid uid")) (save-excursion ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (set-buffer (process-buffer process)) (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 "\\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))))) ;;------------------- (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 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") (if (null (vm-replied-flag m)) (vm-set-replied-flag m t norecord))) ((string= flag "\\deleted") (if (null (vm-deleted-flag m)) (vm-set-deleted-flag m t norecord)) (setq saw-Deleted t)) ((string= flag "\\seen") (if (vm-unread-flag m) (vm-set-unread-flag m nil norecord)) (if (vm-new-flag m) (vm-set-new-flag m nil norecord)) (setq saw-Seen t)) ((string= flag "\\recent") (if (null (vm-new-flag m)) (vm-set-new-flag m t norecord))) ((string= flag "forwarded") (if (null (vm-forwarded-flag m)) (vm-set-forwarded-flag m t norecord))) ((string= flag "redistributed") (if (null (vm-redistributed-flag m)) (vm-set-redistributed-flag m t norecord))) ((string= flag "filed") (if (null (vm-filed-flag m)) (vm-set-filed-flag m t norecord))) ((string= flag "written") (if (null (vm-written-flag m)) (vm-set-written-flag m t norecord))) (t ; all other flags including \flagged (setq seen-labels (cons flag seen-labels))) ) (setq flags (cdr flags))) (if (not saw-Seen) (if (null (vm-unread-flag m)) (vm-set-unread-flag m t norecord))) (if (not saw-Deleted) (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 servers as necessary. Irreversible ;; flags, however, are not deleted. ;; Optional argument BY-UID says that the save messages 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. ;;----------------------------------------------------- (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-protocol-error "message has invalid uid")) (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))) (server-flags (and (boundp uid-key2) (symbol-value uid-key2))) ; leave uid as the dummy header (labels (vm-labels-of m)) 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))) ;; Irreversible flags (if (and (vm-replied-flag m) (not (member "\\answered" server-flags))) (setq flags+ (cons (intern "\\Answered") flags+))) (if (and (vm-filed-flag m) (not (member "filed" server-flags))) (setq flags+ (cons 'filed flags+))) (if (and (vm-written-flag m) (not (member "written" server-flags))) (setq flags+ (cons 'written flags+))) (if (and (vm-forwarded-flag m) (not (member "forwarded" server-flags))) (setq flags+ (cons 'forwarded flags+))) (if (and (vm-redistributed-flag m) (not (member "redistributed" server-flags))) (setq flags+ (cons 'redistributed flags+))) (mapcar (lambda (flag) (delete flag server-flags)) '("\\answered" "filed" "written" "forwarded" "redistributed")) ;; Make a copy of labels for side effects (setq labels (cons nil (copy-sequence labels))) ;; Ignore labels that are both in vm and the server (delete-common-elements labels server-flags 'string<) ;; Ignore reversible flags that we have locally reversed -- Why? ;; (mapcar (lambda (flag) (delete flag server-flags)) ;; '("\\seen" "\\deleted" "\\flagged")) ;; Flags to be added to the server (setq flags+ (append (mapcar 'intern (cdr labels)) flags+)) ;; Flags to be deleted from the server (setq flags- (append (mapcar 'intern (cdr server-flags)) flags-)) (save-excursion (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) 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))))) (when flags- (vm-imap-send-command process (format "%sSTORE %s -FLAGS.SILENT %s" (if by-uid "UID " "") (if by-uid uid message-num) 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))))) (vm-set-attribute-modflag-of m nil) ;;------------------- (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))) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'folder) ;;---------------------------- (set-buffer (vm-buffer-of m)) (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) ;;------------------- ) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) (condition-case nil (vm-imap-create-mailbox process mailbox) (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)))) ;;------------------- (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")) (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))) ;; (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 & bool & bool & bool) -> void ;; vm-imap-save-attributes: (&optional interactive) -> void ;; vm-imap-folder-check-for-mail: (&optional interactive) -> ? ;; ;; vm-imap-get-synchronization-data: (&optional bool) -> ;; (retrieve-list: (uid . int) list & ;; 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, hence, need to be retrieved. ;; 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 expunge-list stale-list uid mp) (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 expunge-list (cons (car mp) expunge-list))))) (setq mp (cdr mp))) ;; Figure out messages that need to be retrieved (mapatoms (function (lambda (sym) (if (and (not (boundp (intern (symbol-name sym) here))) (or do-full-retrieve (not (assoc (symbol-name sym) vm-imap-retrieved-messages)))) ;; don't retrieve messages that have been ;; retrieved previously ;; This is bad because if a message got lost ;; somehow, it won't be retrieved! USR (setq retrieve-list (cons (cons (symbol-name sym) (symbol-value sym)) retrieve-list))))) there) (setq retrieve-list (sort retrieve-list (lambda (**pair1 **pair2) (< (cdr **pair1) (cdr **pair2))))) (list retrieve-list expunge-list stale-list))) ;;;###autoload (defun vm-imap-synchronize-folder (&optional interactive do-remote-expunges do-local-expunges do-retrieves save-attributes retrieve-attributes) "* 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. 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) ;;-------------------------- (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-imap-session interactive))) nil (if do-retrieves (vm-assimilate-new-messages)) ; Funny that this should be ; necessary. Indicates bugs? (message "Logging into the IMAP server...") (let* ((sync-data (vm-imap-get-synchronization-data do-retrieves)) (retrieve-list (nth 0 sync-data)) (expunge-list (nth 1 sync-data)) (stale-list (nth 2 sync-data)) (flags (vm-folder-imap-flags-obarray)) (process (vm-folder-imap-process)) (n 1) (statblob nil) (m nil) (mflags nil) (uid nil) (uid-validity (vm-folder-imap-uid-validity)) (imapdrop (vm-folder-imap-maildrop-spec)) (safe-imapdrop (vm-safe-imapdrop-string imapdrop)) (use-body-peek (vm-folder-imap-body-peek)) r-list range k mp got-some message-size old-eob (folder-buffer (current-buffer))) (when save-attributes (let ((mp vm-message-list)) ;; (perm-flags (vm-folder-imap-permanent-flags)) (message "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 (vm-buffer-type:set 'folder)))) (setq mp (cdr mp))) (message "Updating attributes on the IMAP server... done"))) (when retrieve-attributes (let ((mp vm-message-list) (len (length vm-message-list)) (n 0)) (message "Retrieving message attributes and labels... ") (while mp (setq m (car mp)) (setq uid (vm-imap-uid-of m)) (if (and (equal (vm-imap-uid-validity-of m) uid-validity) (boundp (intern uid flags)) (setq mflags (cdr (symbol-value (intern uid flags))))) (vm-imap-update-message-flags m mflags t)) ;; (message "Retrieving message attributes and labels... %d%%" ;; (* (/ (+ n 0.0) len) 100)) (setq mp (cdr mp) n (1+ n))) (message "Retrieving message atrributes and labels... done") )) (when (and do-retrieves retrieve-list) (save-excursion (message "Retrieving new messages... ") (vm-save-restriction (widen) (setq old-eob (point-max)) (goto-char (point-max)) (unwind-protect (condition-case error-data (save-excursion ;;---------------------------- (vm-buffer-type:enter 'process) ;;---------------------------- (set-buffer (process-buffer process)) (setq statblob (vm-imap-start-status-timer)) (vm-set-imap-stat-x-box statblob safe-imapdrop) (vm-set-imap-stat-x-maxmsg statblob (length retrieve-list)) (setq r-list (vm-imap-bunch-messages (mapcar (function cdr) retrieve-list))) (while r-list (setq range (car r-list)) (vm-set-imap-stat-x-currmsg statblob n) (setq message-size (vm-imap-get-message-size process (car range))) ; sloppy (vm-set-imap-stat-x-need statblob message-size) ;;---------------------------------- (vm-imap-session-type:assert 'valid) ;;---------------------------------- (vm-imap-fetch-messages process (car range) (cdr range) use-body-peek vm-load-headers-only) (setq k (1+ (- (cdr range) (car range)))) (while (> k 0) (vm-imap-retrieve-to-target process folder-buffer statblob use-body-peek) (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-protocol-error (message "Retrieval from %s signaled: %s" safe-imapdrop error-data)) ;; Continue with whatever messages have been read (quit (delete-region old-eob (point-max)) (error (format "Quit received during retrieval from %s" safe-imapdrop)))) ;; cleanup (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) (intern (buffer-name) vm-buffers-needing-display-update) (message "Updating summary... ") (vm-update-summary-and-mode-line) (setq mp (vm-assimilate-new-messages t)) (setq got-some mp) (if got-some (vm-increment vm-modification-counter)) (setq r-list retrieve-list) (while mp ;; headers-only loading is still experimental. USR, 2010-01-12 (if vm-load-headers-only (vm-set-body-to-be-retrieved (car mp) t)) (setq uid (car (car r-list))) (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) (car (symbol-value (intern uid flags)))) (vm-imap-update-message-flags (car mp) (cdr (symbol-value (intern uid flags))) t) (setq mp (cdr mp) r-list (cdr r-list))) ))) (when do-local-expunges (message "Expunging messages in cache... ") (vm-expunge-folder t t 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 t t stale-list) (message "They will be labelled 'stale'") (mapcar (lambda (m) (vm-set-labels m (cons "stale" (vm-labels-of m))) (vm-set-attribute-modflag-of m t) (vm-set-stuff-flag-of m t)) stale-list) )) (message "Expunging messages in cache... done")) (when (and do-remote-expunges vm-imap-messages-to-expunge) ;; New code. Kyle's version was piggybacking on IMAP spool ;; file code and wasn't ideal. (save-excursion ;;----------------------------- (vm-buffer-type:duplicate) ;;----------------------------- (message "Expunging messages on the server... ") (condition-case error-data (let ((mailbox-count (vm-folder-imap-mailbox-count)) (expunge-count (length vm-imap-messages-to-expunge)) (uid-obarray (vm-folder-imap-uid-obarray)) uids-to-delete m-list message e-list count) ;; uids-to-delete to have UID's of all UID-valid messages in ;; vm-imap-messages-to-expunge (while vm-imap-messages-to-expunge (setq message (car vm-imap-messages-to-expunge)) (if (equal (cdr message) uid-validity) (setq uids-to-delete (cons (car message) uids-to-delete))) (setq vm-imap-messages-to-expunge (cdr vm-imap-messages-to-expunge))) (if (not (equal expunge-count (length uids-to-delete))) (progn (message "%s stale deleted messages are ignored" (- expunge-count (length uids-to-delete))) (sit-for 2))) ;;--------------------------- (vm-buffer-type:set 'process) ;;--------------------------- (set-buffer (process-buffer process)) ;; (setq uid-alist (vm-imap-get-uid-list ;; process 1 mailbox-count)) ;; m-list to have the 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 (delete nil (mapcar (lambda (uid) (let* ((key (intern uid uid-obarray))) (and (boundp key) (progn (vm-imap-delete-message process (symbol-value key)) (symbol-value key))))) uids-to-delete))) (setq m-list (cons nil (sort 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) '>)) (while e-list ; for each message expunged (let ((e (car e-list)) (pair m-list) (done nil)) (while (not done) ; remove it from m-list (cond ((null (cdr pair)) (setq done t)) ((> (car (cdr pair)) e) ; decrement the message sequence ; numbers following e in m-list (rplaca (cdr pair) (- (car (cdr pair)) 1))) ((= (car (cdr pair)) e) (rplacd pair (cdr (cdr pair))) (setq done t)) ((< (car (cdr pair)) e) ; oops. somebody expunged e!?! (setq done t))) (setq pair (cdr pair))) (setq e-list (cdr e-list)))) ;; m-list has message sequence numbers of messages ;; that haven't yet been expunged (if (cdr m-list) (message "%s messages yet to be expunged" (length (cdr m-list)))) ; try again, if the user wants us to (setq count (1+ count))) (message "Expunging messages on the server... done")) (vm-imap-protocol-error (message "Expunge from %s signalled: %s" safe-imapdrop error-data)) (quit (error "Quit received during expunge from %s" safe-imapdrop))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (vm-imap-dump-uid-and-flags-data)) got-some))) (defvar vm-imap-message-bunch-size 10 "* Number of messages in a bunch to be used for IMAP server operations") (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." (let ((body-buffer (current-buffer))) (save-excursion ;;---------------------------------- (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)) (safe-imapdrop (vm-safe-imapdrop-string imapdrop)) (process (vm-re-establish-folder-imap-session imapdrop)) (use-body-peek (vm-folder-imap-body-peek)) (server-uid-validity (vm-folder-imap-uid-validity)) (uid-key1 (intern-soft uid (vm-folder-imap-uid-obarray))) (uid-key2 (intern-soft uid (vm-folder-imap-flags-obarray))) (old-eob (point-max)) message-num message-size ) (when (null uid-key1) (vm-imap-retrieve-uid-and-flags-data) (setq uid-key1 (intern-soft uid (vm-folder-imap-uid-obarray))) (setq uid-key2 (intern-soft uid (vm-folder-imap-flags-obarray)))) (setq message-num (symbol-value uid-key1)) (setq message-size (string-to-number (car (symbol-value uid-key2)))) (message "Retrieving message body... ") (condition-case error-data (save-excursion (set-buffer (process-buffer process)) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert 'valid) ;;---------------------------------- (setq statblob (vm-imap-start-status-timer)) (vm-set-imap-stat-x-box statblob safe-imapdrop) (vm-set-imap-stat-x-maxmsg statblob 1) (vm-set-imap-stat-x-currmsg statblob message-num) ;; (setq message-size (vm-imap-get-message-size process message-num)) (vm-set-imap-stat-x-need statblob message-size) (vm-imap-fetch-message process message-num use-body-peek nil) (vm-imap-retrieve-to-target process body-buffer statblob use-body-peek) (vm-imap-read-ok-response process) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (vm-imap-protocol-error ;;------------------- (vm-buffer-type:exit) ;;------------------- (message "Retrieval from %s signaled: %s" safe-imapdrop error-data) ;; Continue with whatever messages have been read ) (quit ;;------------------- (vm-buffer-type:exit) ;;------------------- (delete-region old-eob (point-max)) (error (format "Quit received during retrieval from %s" safe-imapdrop)))) (message "Retrieving message body... done") ) ;;------------------- (vm-buffer-type:exit) ;;------------------- ))) ;;;###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." (interactive "p") (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist (vm-select-marked-or-prefixed-messages count)) (buffer-read-only nil) (inhibit-read-only t) (buffer-undo-list t) (text-begin nil) (text-end nil) m mm) ;; (if (not used-marks) ;; (setq mlist (list (car vm-message-pointer)))) (save-excursion (while mlist (setq m (car mlist)) (setq mm (vm-real-message-of m)) (set-buffer (vm-buffer-of mm)) (if (not (eq vm-folder-access-method 'imap)) (error "This is currently available only for imap folders.")) (vm-save-restriction (widen) (setq text-begin (marker-position (vm-text-of mm))) (setq text-end (marker-position (vm-text-end-of mm))) (narrow-to-region (marker-position (vm-headers-of mm)) text-end) (goto-char text-begin) (delete-region (point) (point-max)) (apply (intern (format "vm-fetch-%s-message" "imap")) mm nil) ;; delete the new headers (delete-region text-begin (or (re-search-forward "\n\n" (point-max) t) (point-max))) ;; fix markers now ;; FIXME the text-end is guessed (set-marker (vm-text-of mm) text-begin) (set-marker (vm-text-end-of mm) (save-excursion (goto-char (point-max)) (end-of-line 0) ; move back one line (kill-line 1) (point))) (goto-char text-begin) ;; now care for the layout of the message (vm-set-mime-layout-of mm (vm-mime-parse-entity-safe mm)) (vm-set-body-to-be-retrieved mm nil) (setq mlist (cdr mlist))))) )) ;;;###autoload (defun vm-refresh-message (&optional count) "This is an alias for vm-load-message." (interactive "p") (call-interactively (function vm-load-message))) ;;;###autoload (defun vm-unload-message (&optional count) "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." (interactive "p") (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (let ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist (vm-select-marked-or-prefixed-messages count)) (buffer-read-only nil) (inhibit-read-only t) (buffer-undo-list t) (text-begin nil) (text-end nil) m mm) ;; (if (not used-marks) ;; (setq mlist (list (car vm-message-pointer)))) (save-excursion (while mlist (setq m (car mlist)) (setq mm (vm-real-message-of m)) (set-buffer (vm-buffer-of mm)) (if (not (eq vm-folder-access-method 'imap)) (error "This is currently available only for imap folders.")) (vm-save-restriction (widen) (setq text-begin (marker-position (vm-text-of mm))) (setq text-end (marker-position (vm-text-end-of mm))) (goto-char text-begin) (delete-region (point) text-end) (vm-set-mime-layout-of mm nil) (vm-set-body-to-be-retrieved mm t) (setq mlist (cdr mlist))))) )) (defun vm-imap-save-attributes (&optional interactive all-flags) "* 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)) ;; (perm-flags (vm-folder-imap-permanent-flags)) (message "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 (vm-buffer-type:set 'folder)))) (setq mp (cdr mp))) (message "Updating attributes on the IMAP server... done"))) (defun vm-imap-synchronize (&optional all-flags) "Synchronize the current folder with the IMAP mailbox. Deleted messages are not expunged. Changes made to the buffer are uploaded to the server first before downloading the server data. Prefix argument ALL-FLAGS says that all the messages' flags should be written to the server irrespective of whether they were changed in the VM session. This is useful for saving offline work." (interactive "P") (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-display nil nil '(vm-imap-synchronize) '(vm-imap-synchronize)) (if (not (eq vm-folder-access-method 'imap)) (message "This is not an IMAP folder") (if (null (vm-establish-new-folder-imap-session t)) nil (vm-imap-retrieve-uid-and-flags-data) (vm-imap-save-attributes all-flags) ;; (vm-imap-synchronize-folder t nil nil nil ;; (if all-flags 'all t) nil) ; save-attributes (vm-imap-synchronize-folder t t t 'full nil t) ; do-remote-expunges, ; do-local-expunges, ; do-retrieves and ; retrieve-attributes ;; stuff the attributes of messages that need it. ;; (message "Stuffing attributes...") ;; (vm-stuff-folder-attributes nil) ;; (message "Stuffing attributes... done") ;; stuff bookmark and header variable values (if vm-message-list (progn ;; get summary cache up-to-date (message "Updating summary... ") (vm-update-summary-and-mode-line) (message "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-for-mail (&optional interactive) "Check if there is new mail in th current IMAP folder. The optional argument INTERACTIVE says if the function is being invoked interactively." ;;-------------------------- (vm-buffer-type:set 'folder) ;;-------------------------- (if (or vm-global-block-new-mail (null (vm-establish-new-folder-imap-session interactive))) nil (let ((result (car (vm-imap-get-synchronization-data)))) (vm-imap-end-session (vm-folder-imap-process)) result ))) ;; ----------- 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." (save-excursion (set-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"))))) (defun vm-imap-normalize-spec (spec) (let (list) (setq list (vm-imap-parse-spec-to-list spec)) (setcar (vm-last list) "*") ; scrub password (setcar list "imap") ; standardise protocol name (setcar (nthcdr 2 list) "*") ; scrub portnumber (setcar (nthcdr 4 list) "*") ; scrub authentication method (setq spec (mapconcat (function identity) list ":")) spec )) ;;;###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 account.") (defun vm-imap-folder-completion-list (string predicate flag) ;; selectable-only is used via dynamic binding (let ((completion-list (mapcar (lambda (a) (list (concat (cadr a) ":"))) vm-imap-account-alist)) folder account spec process mailbox-list) ;; check for account (setq folder (try-completion (or string "") completion-list predicate)) ;; get folders of this account (if (stringp folder) (setq account (car (vm-parse folder "\\([^:]+\\):?" 1))) (setq account (car (vm-parse string "\\([^:]+\\):?" 1)))) (when account (setq mailbox-list (cdr (assoc account vm-imap-account-folder-cache))) (setq spec (car (rassoc (list account) vm-imap-account-alist))) (when (and (null mailbox-list) spec) (setq process (vm-imap-make-session spec)) (when process (setq mailbox-list (vm-imap-mailbox-list process selectable-only)) (vm-imap-end-session process) (when mailbox-list (add-to-list 'vm-imap-account-folder-cache (cons account mailbox-list))))) (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 "")) (if (eq folder t) (setq folder string)) (cond ((null flag) folder) ((or (eq t flag) (string= " " folder)) (mapcar 'car completion-list)) ((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 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 (car (rassoc (list account) vm-imap-account-alist))) (if (null folder) (error "IMAP folder required in the format account-name:folder-name")) (if (null spec) (error "Unknown IMAP account-name:folder-name")) (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) (save-excursion (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-session-type:set 'active) ;;-------------------------------- (vm-imap-dump-uid-and-flags-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")))) ;;------------------- (vm-buffer-type:exit) ;;------------------- sep ))) (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) (save-excursion (set-buffer (process-buffer process)) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process "LIST \"\" \"*\"") (vm-imap-dump-uid-and-flags-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) (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))))))) ;;------------------- (vm-buffer-type:exit) ;;------------------- c-list ))) ;; 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) (save-excursion (set-buffer (process-buffer process)) ;;---------------------------------- (vm-buffer-type:enter 'process) (vm-imap-session-type:assert-active) ;;---------------------------------- (vm-imap-send-command process (concat "LIST \"\" \"" mailbox "\"")) (vm-imap-dump-uid-and-flags-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) (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))))))) ;;------------------- (vm-buffer-type:exit) ;;------------------- c-list ))) (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) (error "server said BYE")) ((vm-imap-response-matches response 'VM 'BAD) (vm-imap-protocol-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-protocol-error "IMAP CREATE 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-protocol-error "IMAP DELETE 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-protocol-error "IMAP RENAME 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'." (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) (vm-check-for-killed-folder) (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) (save-excursion (setq process (vm-imap-make-session folder)) (if (null process) (error "Couldn't open IMAP session for %s" (vm-safe-imapdrop-string folder))) ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (set-buffer (process-buffer process)) (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder))) (vm-imap-create-mailbox process mailbox t) (message "Folder %s created" (vm-safe-imapdrop-string folder)) ;;------------------- (vm-buffer-type:exit) ;;------------------- (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process))) )) ;;;###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'." (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) (vm-check-for-killed-folder) (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) (setq process (vm-imap-make-session folder)) (if (null process) (error "Couldn't open IMAP session for %s" (vm-safe-imapdrop-string folder))) (save-excursion ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- (set-buffer (process-buffer process)) (setq mailbox (nth 3 (vm-imap-parse-spec-to-list folder))) (vm-imap-delete-mailbox process mailbox) (message "Folder %s deleted" (vm-safe-imapdrop-string folder)) ;;------------------- (vm-buffer-type:exit) ;;------------------- (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ))) ;;;###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'." (interactive (save-excursion ;;------------------------ (vm-buffer-type:duplicate) ;;------------------------ (vm-session-initialization) (vm-check-for-killed-folder) (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: " (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)) (if (null process) (error "Couldn't open IMAP session for %s" (vm-safe-imapdrop-string source))) (save-excursion ;;----------------------------- (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) (message "Folder %s renamed to %s" (vm-safe-imapdrop-string source) (vm-safe-imapdrop-string dest)) ;;------------------- (vm-buffer-type:exit) ;;------------------- (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process)) ))) ;;; 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." (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) (save-excursion ;;---------------------------- (vm-buffer-type:enter 'folder) ;;---------------------------- (vm-select-folder-buffer) (setq m (car vm-message-pointer)) (if m (set-buffer (vm-buffer-of (vm-real-message-of m)))) (if (not (eq vm-folder-access-method 'imap)) (error "Cannot do IMAP-FCC because the parent folder is not an IMAP folder")) (vm-establish-new-folder-imap-session) (vm-imap-dump-uid-and-flags-data) (setq process (vm-folder-imap-process)) (setq mailboxes (list (cons mailbox process))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (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)) (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)))) (while mailboxes (setq mailbox (car (car mailboxes))) (setq process (cdr (car mailboxes))) (unwind-protect (save-excursion ;;----------------------------- (vm-buffer-type:enter 'process) ;;----------------------------- ;; this can go awry if the process has died... (set-buffer (process-buffer process)) (condition-case nil (vm-imap-create-mailbox process mailbox) (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))) ;; 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-protocol-error "server said NO to APPEND command")) ((vm-imap-response-matches response 'VM 'BAD) (vm-imap-protocol-error "server said BAD to APPEND command")) ((vm-imap-response-matches response '* 'BYE) (vm-imap-protocol-error "server said BYE to APPEND command")) ((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))))) ;;------------------- (vm-buffer-type:exit) ;;------------------- ) (when (and (processp process) (memq (process-status process) '(open run))) (vm-imap-end-session process))) (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) (setq vm-kept-imap-buffers nil) (setq vm-imap-keep-trace-buffer t) (setq vm-imap-keep-failed-trace-buffers 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) (if (or vm-imap-keep-trace-buffer (y-or-n-p "Did you run vm-imap-start-bug-report earlier? ")) (message "Thank you. Preparing the bug report... ") (message "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 (save-excursion (set-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 m nil) (vm-set-body-to-be-retrieved m vm-load-headers-only)) (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-excursion (vm-select-folder-buffer) (let ((mp vm-message-list)) (while mp (vm-set-body-to-be-retrieved (car mp) nil) (setq mp (cdr mp)))) (message "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-excursion (vm-select-folder-buffer) (let ((mp vm-message-list)) (while mp (vm-set-byte-count-of (car mp) nil) (setq mp (cdr mp)))) (message "Unset the byte counts of %s messages" (length vm-message-list)) )) (provide 'vm-imap) ;;; vm-imap.el ends here vm-8.1.2/lisp/vm-pcrisis.el0000644000175000017500000016722511725175471016032 0ustar srivastasrivasta;;; vm-pcrisis.el --- wide-ranging auto-setup for personalities in VM ;; ;; Copyright (C) 1999 Rob Hodges, ;; 2006 Robert Widhopf, Robert P. Goldman ;; ;; Package: Personality Crisis for VM ;; Author: Rob Hodges ;; ;; Maintainer: Robert Widhopf-Fenk ;; 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, 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 and HTML formats. You should have ;; downloaded one or the other along with this package at the URL ;; above. ;;; Code: (eval-when-compile (require 'vm-version) (require 'vm-message) (require 'vm-macro) (require 'vm-reply) ;; 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!") (sit-for 5)))) ;; 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) (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 (i) (list i (list 'vmpc-substitute-header "From" i))) 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 (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? (set-extent-property extent 'start-open start) (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 (extent-start-position exerlay) (overlay-start exerlay))) (defun vmpc-exerlay-end (exerlay) "Return buffer position of the end of EXERLAY." (if vm-xemacs-p (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 (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 (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) (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 (detach-extent exerlay) (delete-overlay exerlay))) (defun vmpc-make-exerlay (startpos endpos) "Create a new exerlay spanning from STARTPOS to ENDPOS." (if vm-xemacs-p (make-extent startpos endpos (current-buffer)) (make-overlay startpos endpos (current-buffer)))) (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-marked-or-prefixed-messages 1))) 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-marked-or-prefixed-messages 1))) (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 (&optional prompt 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 (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 (car (cdr 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-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vmpc-build-true-conditions-list) (message "VMPC true conditions: %S" vmpc-true-conditions) vmpc-true-conditions)) (defun vmpc-build-true-conditions-list () "Built list of true conditions and store it in variable `vmpc-true-conditions'." (setq vmpc-true-conditions nil) (mapcar (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 () "Built 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 (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) (mapcar (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 (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) (interactive-p)) (setq vmpc-actions-to-run (vmpc-read-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) ;; 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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) ;; 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))) (provide 'vm-pcrisis) ;;; vm-pcrisis.el ends here vm-8.1.2/lisp/vm-search.el0000644000175000017500000001212611725175471015610 0ustar srivastasrivasta;;; vm-search.el --- Incremental search through a mail folder ;; ;; 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: ;;;###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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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))))) (provide 'vm-search) ;;; vm-search.el ends here vm-8.1.2/lisp/vm-summary-faces.el0000644000175000017500000002144411725175471017122 0ustar srivastasrivasta;;; vm-summary-faces.el --- faces support for VM summary buffers ;; ;; Copyright (C) 2001 Robert Fenk ;; ;; 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 ;; ;; (require 'vm-summary-faces) ;; (vm-summary-faces-mode 1) ;; (defgroup vm nil "VM" :group 'mail) (defgroup vm-summary-faces nil "VM additional virtual folder selectors and functions." :group 'vm) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when-compile (require 'cl)) (eval-and-compile (require 'advice) (require 'vm-summary) (require 'vm-virtual)) (eval-and-compile (if vm-xemacs-p (require 'overlay))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defface vm-summary-selected-face '((t (:bold on))) "The face used in VM Summary buffers for the selected message." :group 'vm-summary-faces) (defface vm-summary-marked-face '((((type x)) (:foreground "red3"))) "The face used in VM Summary buffers for marked messages." :group 'vm-summary-faces) (defface vm-summary-deleted-face (if (featurep 'xemacs) '((t (:foreground "grey50" :strikethru t))) '((t (:foreground "grey50" :strike-through "grey70")))) "The face used in VM Summary buffers for deleted messages." :group 'vm-summary-faces) (defface vm-summary-new-face '((t (:foreground "blue"))) "The face used in VM Summary buffers for new messages." :group 'vm-summary-faces) (defface vm-summary-unread-face '((t (:foreground "blue4"))) "The face used in VM Summary buffers for unread messages." :group 'vm-summary-faces) (defface vm-summary-filed-face '((t (:foreground "green4" :underline t))) "The face used in VM Summary buffers for filed messages." :group 'vm-summary-faces) (defface vm-summary-written-face '((t (:foreground "green4" :underline t))) "The face used in VM Summary buffers for written messages." :group 'vm-summary-faces) (defface vm-summary-replied-face '((t (:foreground "grey50"))) "The face used in VM Summary buffers for replied messages." :group 'vm-summary-faces) (defface vm-summary-forwarded-face '((t (:foreground "grey50"))) "The face used in VM Summary buffers for forwarded messages." :group 'vm-summary-faces) (defface vm-summary-edited-face nil "The face used in VM Summary buffers for edited messages." :group 'vm-summary-faces) (defface vm-summary-redistributed-face '((t (:foreground "grey50"))) "The face used in VM Summary buffers for redistributed messages." :group 'vm-summary-faces) (defface vm-summary-outgoing-face '((t (:foreground "grey50"))) "The face used in VM Summary buffers for outgoing messages." :group 'vm-summary-faces) (defface vm-summary-high-priority-face '((t (:foreground "red"))) "The face used in VM Summary buffers for high-priority messages." :group 'vm-summary-faces) (defface vm-summary-default-face nil "The default face used in VM Summary buffers." :group 'vm-summary-faces) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defcustom vm-summary-faces-alist '( ((or (header "Priority: urgent") (header "Importance: high") (header "X-Priority: 1") (label "!") (label "\\flagged") (header "X-VM-postponed-data:")) vm-summary-high-priority-face) ((deleted) vm-summary-deleted-face) ((new) vm-summary-new-face) ((unread) vm-summary-unread-face) ((filed) vm-summary-filed-face) ((written) vm-summary-written-face) ((replied) vm-summary-replied-face) ((forwarded) vm-summary-forwarded-face) ((edited) vm-summary-edited-face) ((redistributed) vm-summary-redistributed-face) ((marked) vm-summary-marked-face) ((outgoing) vm-summary-outgoing-face) ((any) vm-summary-default-face)) "*Alist of virtual folder conditions and corresponding faces. Order matters. The first matching one will be used as face." :type '(repeat (cons (sexp) (face))) :group 'vm-summary-faces) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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 face) "Toggle visibility of messages with FACE. When called with a prefix arg prompt for the face." (interactive "P") (if (and (listp face) (numberp (car face))) (setq face (completing-read "Face name: " (mapcar (lambda (f) (list (format "%s" (caar f)))) vm-summary-faces-alist) nil t "deleted"))) (setq face (or face vm-summary-faces-hide "deleted")) (vm-summarize) (vm-select-folder-buffer) (set-buffer vm-summary-buffer) (let ((extents (vm-summary-faces-list-extents)) (face (intern (concat "vm-summary-" face "-face"))) x) (while extents (setq x (car extents)) (when (equal face (vm-extent-property x 'face)) (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))) (vm-set-extent-property x 'face (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))))) (defvar vm-summary-faces-mode nil) ;;;###autoload (defun vm-summary-faces-mode (&optional arg) "Toggle `vm-summary-faces-mode'. Remove/add the `vm-summary-fontify-buffer' hook from the hook variable `vm-summary-mode-hook' and when in a summary buffer, then toggle the `font-lock-mode'." (interactive "P") (if (null arg) (setq vm-summary-faces-mode (not vm-summary-faces-mode)) (if (> (prefix-numeric-value arg) 0) (setq vm-summary-faces-mode t) (setq vm-summary-faces-mode nil))) (when (interactive-p) (message "VM summary faces mode is %s" (if vm-summary-faces-mode "on" "off"))) (if (memq major-mode '(vm-mode vm-virtual-mode vm-summary-mode vm-presentation-mode)) (save-excursion (vm-select-folder-buffer) (vm-summarize) (set-buffer vm-summary-buffer) (if vm-summary-faces-mode (let ((mp vm-message-list)) (while mp (vm-summary-faces-add (car mp)) (setq mp (cdr mp)))) (vm-summary-faces-destroy) (if vm-summary-overlay (vm-set-extent-property vm-summary-overlay 'face vm-summary-highlight-face)))))) (defadvice vm-mouse-set-mouse-track-highlight (after vm-summary-faces activate) (when (and vm-summary-faces-mode (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-faces-mode 'vm-summary-selected-face vm-summary-highlight-face)))) (add-hook 'vm-summary-pointer-update-hook 'vm-summary-faces-fix-pointer) (provide 'vm-summary-faces) vm-8.1.2/lisp/vm-startup.el0000644000175000017500000000015011725175471016037 0ustar srivastasrivasta;;; This file is only here for compatibility with older VM versions (require 'vm) (provide 'vm-startup) vm-8.1.2/lisp/vm-autoload.el0000644000175000017500000000020711725175471016150 0ustar srivastasrivasta;; only for compatibility with older BBDB and others (if (not (featurep 'xemacs)) (require 'vm-autoloads)) (provide 'vm-autoload) vm-8.1.2/lisp/vm-build.el0000644000175000017500000000750011725175471015442 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) ;; (setq byte-compile-warnings '(free-vars)) (setq byte-compile-warnings '(not unresolved suspicious)) ;; (setq byte-compile-warnings '(not suspicious)) ;; (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-version) (require 'vm-message) (require 'vm-macro) (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") (if (>= emacs-major-version 22) (update-directory-autoloads source-dir) (if (>= emacs-major-version 21) (update-autoloads-from-directories source-dir) (error "Do not know how to generate autoloads")))))) (provide 'vm-build) vm-8.1.2/lisp/vm-message-history.el0000644000175000017500000002117111725175471017466 0ustar srivastasrivasta;;; vm-message-history.el --- Move backward & forward through selected messages ;; -*-unibyte: t; coding: iso-8859-1;-*- ;; 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: (eval-and-compile (require 'easymenu) (require 'vm-version) (require 'vm-menu) (require 'vm-vars)) (defgroup vm-message-history nil "Message history for VM folders." :group 'vm) (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) (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-preview-current-message) (vm-record-and-change-message-pointer vm-message-pointer (memq (car vm-message-history-pointer) vm-message-list)) (vm-preview-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) (vm-record-and-change-message-pointer vm-message-pointer mp) (vm-preview-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) (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) (provide 'vm-message-history) ;;; vm-message-history.el ends here vm-8.1.2/lisp/vm-avirtual.el0000644000175000017500000013033511725175471016175 0ustar srivastasrivasta;;; vm-avirtual.el --- additional functions for virtual folder selectors ;; ;; 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 selector offer the best ;; way of specifying conditions, but they only work on messages within ;; folders and not on messages which are currently composed. So I decided to ;; extent virtual folder selectors also to message composing, although not ;; all of the selectors are meaning full 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 ;; beet 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 which are not directed to 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 sent me any comments or bug reports. ;; ;;; Code: (require 'vm-virtual) (defgroup vm nil "VM" :group 'mail) (defgroup vm-avirtual nil "VM additional virtual folder selectors and functions." :group 'vm) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-when-compile (require 'cl)) (eval-and-compile (require 'advice) (require 'regexp-opt) (require 'vm-version) (require 'vm-message) (require 'vm-macro) (require 'vm-vars) (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) ; dummyd 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) (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) (message "%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-get-selector-member (folder-name folder-list) (let (match ) (while folder-list (if (string-match (car folder-list) folder-name) (setq folder-list nil match t)) (setq folder-list (cdr folder-list))) match)) ;;;###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 (list (save-excursion (vm-select-folder-buffer) (buffer-name)))))) (let ((sels (assoc vfolder vm-virtual-folder-alist)) selector folder-name) (setq sels (and sels (cadr sels))) (when sels (if (not valid-folder-list) (setq selector (append (cdr sels) selector)) (setq folder-name valid-folder-list) (while folder-name (if (vm-virtual-get-selector-member (car folder-name) (car sels)) (setq selector (append (cdr sels) selector))) (setq folder-name (cdr folder-name))))) 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) (vm-error-if-folder-empty) (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 (interactive-p) (vm-follow-summary-cursor) (setq selector (vm-virtual-get-selector (vm-read-string "Virtual folder: " vm-virtual-folder-alist)) function (key-or-menu-binding (read-key-sequence "VM command: ")))) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((mlist (vm-select-marked-or-prefixed-messages (or count 1))) (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) (let ((new-messages (or message-list (vm-select-marked-or-prefixed-messages count))) 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-preview-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 "thread")))))) (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) (if (not (eq major-mode 'vm-virtual-mode)) (error "This is no virtual folder.")) (let ((old-messages (or message-list (vm-select-marked-or-prefixed-messages count))) 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 "thread")) 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 (function (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 t t 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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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-pessage-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 can be seen as an more powerful replacement of `vm-auto-select-folder' and it is used by `vm-virtual-save-message'. It might also be applied to messages which are composed in order to find the right FCC." (when (not m) (setq m (car vm-message-pointer) avfolder-alist vm-virtual-folder-alist 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 (interactive-p) (vm-sort-messages "auto-folder")) (save-excursion (vm-select-folder-buffer) ;; 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 it 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-excursion (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-error-if-folder-read-only) (message "Archiving...") (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-marked-or-prefixed-messages 0) vm-message-list)) (done nil) stop-point (vm-last-save-folder vm-last-save-folder) (vm-move-after-deleting nil)) ;; 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) (message "%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) (message "No messages were archived") (message "%d message%s archived" archived (if (= 1 archived) "" "s"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;###autoload (defun vm-virtual-make-folder-persistent () "Save all mails of current virtual folder to the real folder with the same name." (interactive) (save-excursion (vm-select-folder-buffer) (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)) (message "Saved virtual folder in file \"%s\"" file)) (error "This is no virtual folder!")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide 'vm-avirtual) ;;; vm-rfaddons.el ends here vm-8.1.2/lisp/vm.el0000644000175000017500000013513711725175471014355 0ustar srivastasrivasta;;; vm.el --- Entry points for 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: (defvar enable-multibyte-characters) (require 'vm-version) ;; 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 read-only access-method reload) "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 buffer is put into VM mode, a major mode for reading mail. 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 the primary inbox normally causes any contents of the system mailbox to be moved and appended to the resulting 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. See the documentation for vm-mode for more information." ;; 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. ;; 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 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 access-method reload)) ;; 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-recognize-imap-maildrops (string-match vm-recognize-imap-maildrops f)) (setq access-method 'imap folder f)) ((and (stringp f) vm-recognize-pop-maildrops (string-match vm-recognize-pop-maildrops f)) (setq access-method 'pop folder f))))) (let ((full-startup (and (not reload) (not (bufferp folder)))) ;; not clear why full-startup isn't always true - USR, 2010-01-02 (did-read-index-file nil) folder-buffer first-time totals-blurb folder-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)) (setq folder (vm-imap-make-filename-for-spec remote-spec)))) (setq folder-buffer (if (bufferp folder) folder (vm-read-folder folder remote-spec))) (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))) (when (and (stringp folder) (memq access-method '(pop imap))) (if (not (equal folder-name (buffer-name))) (rename-buffer folder-name t))) (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. (or (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)))) ;; 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. (vm-assimilate-new-messages nil (not did-read-index-file) nil t) (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))) (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)))) ;; say this NOW, before the non-previewers read a message, ;; alter the new message count and confuse themselves. (if full-startup (progn ;; save blurb so we can repeat it later as necessary. (setq totals-blurb (vm-emit-totals-blurb)) (and 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) (and vm-use-menus (vm-menu-support-possible-p) (vm-menu-install-visited-folders-menu)) (if full-startup (progn (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-frames vm-frame-per-summary vm-raise-frame-at-startup) (vm-raise-frame)) ;; if vm-mutable-windows is nil, the startup ;; configuration can't be applied, so do ;; something to get a VM buffer on the screen (if vm-mutable-windows (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-preview-current-message))) (run-hooks 'vm-visit-folder-hook) ;; Warn user about auto save file, if appropriate. (if preserve-auto-save-file (message (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)) (message totals-blurb) (if (and vm-auto-get-new-mail (not vm-block-new-mail) (not vm-folder-read-only)) (progn (message "Checking for new mail for %s..." (or buffer-file-name (buffer-name))) (if (vm-get-spooled-mail t) (progn (setq totals-blurb (vm-emit-totals-blurb)) (if (vm-thoughtfully-select-message) (vm-preview-current-message) (vm-update-summary-and-mode-line)))) (message totals-blurb))) ;; Display copyright and copying info. (if (and (interactive-p) (not vm-startup-message-displayed)) (progn (vm-display-startup-message) (if (not (input-pending-p)) (message 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)) (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))) (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) (vm-display nil nil '(vm-mode) '(vm-mode))) ;;;###autoload (defun vm-visit-folder (folder &optional read-only) "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." (interactive (save-excursion (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 (stringp vm-recognize-pop-maildrops) (string-match vm-recognize-pop-maildrops folder) (setq foo (vm-pop-find-name-for-spec folder))) (setq folder foo access-method 'pop vm-last-visit-pop-folder folder)) ((and (stringp vm-recognize-imap-maildrops) (string-match vm-recognize-imap-maildrops 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 access-method))) ;;;###autoload (defun vm-visit-folder-other-frame (folder &optional read-only) "Like vm-visit-folder, but run in a newly created frame." (interactive (save-excursion (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-excursion (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-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-excursion (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 '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-excursion (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-excursion (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-excursion (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 (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) (vm-check-for-killed-summary) (setq vm-last-visit-imap-folder folder) (vm folder read-only '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-excursion (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-excursion (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))) (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) (if (not (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))) (if first-time (progn (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) (and (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)) (if vm-summary-show-threads (vm-sort-messages "thread")) (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-preview-current-message) (setq mp nil)) (setq mp (cdr mp)))))) (if (null vm-message-pointer) (if (vm-thoughtfully-select-message) (vm-preview-current-message) (vm-update-summary-and-mode-line))) (message 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) (if first-time (progn (if (vm-should-generate-summary) (progn (vm-summarize t nil) (message blurb))) ;; raise the summary frame if the user wants frames ;; raised and if there is a summary frame. (if (and vm-summary-buffer vm-mutable-frames vm-frame-per-summary vm-raise-frame-at-startup) (vm-raise-frame)) ;; if vm-mutable-windows is nil, the startup ;; configuration can't be applied, so do ;; something to get a VM buffer on the screen (if vm-mutable-windows (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. (and (interactive-p) (not vm-startup-message-displayed) (vm-display-startup-message) (message 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) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (vm-mail-internal nil to 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) (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) (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)) (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-send-actions) ;;;###autoload (defun vm-compose-mail (&optional to subject other-headers continue switch-function yank-action send-actions) (interactive) (vm-session-initialization) (if continue (vm-continue-composing-message) (let ((buffer (vm-mail-internal (if to (format "message to %s" (vm-truncate-roman-string to 20)) nil) to 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)))) ;;;###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) (setq varlist (apropos-internal "^\\(vm\\|vmpc\\)-" 'user-variable-p) varlist (sort varlist (lambda (v1 v2) (string-lessp (format "%s" v1) (format "%s" v2))))) (let ((vars-to-delete '(vm-shrunken-headers-keymap ; big and wasteful vm-auto-folder-alist ; a bit private vm-mail-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 )) ;; delete any passwords stored in maildrop strings (vm-spool-files (if (listp (car vm-spool-files)) (vm-mapcar (lambda (elem-xyz) (vm-mapcar (function vm-maildrop-sans-password) elem-xyz))) (vm-mapcar (function vm-maildrop-sans-password) vm-spool-files))) (vm-pop-folder-alist (vm-maildrop-alist-sans-password vm-pop-folder-alist)) (vm-imap-server-list (vm-mapcar (function vm-maildrop-sans-password) vm-imap-server-list)) (vm-imap-account-alist (vm-maildrop-alist-sans-password vm-imap-account-alist)) (vm-pop-auto-expunge-alist (vm-maildrop-alist-sans-password vm-pop-auto-expunge-alist)) (vm-imap-auto-expunge-alist (vm-maildrop-alist-sans-password 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 (concat "VM " (vm-version)) varlist nil nil "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. (They will be kept confidential.) - Please remove these instructions and other stuff which is unrelated to the bug from your message. ") (goto-char (point-min)) (mail-position-on-field "Subject") (insert "VM-BUG: ")))) (defun vm-edit-init-file () "Edit the `vm-init-file'." (interactive) (find-file-other-frame vm-init-file)) (defun vm-load-init-file (&optional interactive) (interactive "p") (if (or (not vm-init-file-loaded) interactive) (progn (and vm-init-file (load vm-init-file (not interactive) (not interactive) t)) (and vm-preferences-file (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))) (defun vm-check-emacs-version () (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))))) (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 )))) (defvar vm-postponed-folder) (defvar vm-drafts-exist nil) (defvar vm-ml-draft-count "" "The current number of drafts in the `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 () ;; (vm-set-debug-flags) ;; If this is the first time VM has been run in this Emacs session, ;; do some necessary preparations. (if (or (not (boundp 'vm-session-beginning)) vm-session-beginning) (progn (vm-check-emacs-version) (require 'vm-vars) (require 'vm-macro) (require 'vm-misc) (require 'vm-message) (require 'vm-minibuf) (require 'vm-motion) (require 'vm-page) (require 'vm-mouse) (require 'vm-summary) (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) (when (or (eq t vm-enable-addons) (member 'summary-faces vm-enable-addons)) (require 'vm-summary-faces) (vm-summary-faces-mode 1))) (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"))))) ;; default value of vm-mime-button-face is 'gui-button-face ;; this face doesn't exist by default in FSF Emacs 19.34. ;; Create it and initialize it to something reasonable. (if (and vm-fsfemacs-p (featurep 'faces) (not (facep 'gui-button-face))) (progn (make-face 'gui-button-face) (cond ((eq window-system 'x) (set-face-foreground 'gui-button-face "black") (set-face-background 'gui-button-face "gray75")) (t ;; use primary color names, since fancier ;; names may not be valid. (set-face-foreground 'gui-button-face "white") (set-face-background 'gui-button-face "red"))))) ;; gui-button-face might not exist under XEmacs either. ;; This can happen if XEmacs is built without window ;; system support. In any case, create it anyway. (if (and vm-xemacs-p (not (find-face 'gui-button-face))) (progn (make-face 'gui-button-face) (set-face-foreground 'gui-button-face "black" nil '(win)) (set-face-background 'gui-button-face "gray75" nil '(win)) (set-face-foreground 'gui-button-face "white" nil '(tty)) (set-face-background 'gui-button-face "red" nil '(tty)))) (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") (autoload 'vm-easy-menu-define "vm-easymenu" nil 'macro) (autoload 'vm-easy-menu-do-define "vm-easymenu") (provide 'vm) ;;; vm.el ends here vm-8.1.2/lisp/vm-grepmail.el0000644000175000017500000002216411725175471016146 0ustar srivastasrivasta;;; vm-grepmail.el --- VM interface for grepmail ;; ;; 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: (eval-when-compile (require 'cl)) (eval-and-compile (require 'vm-version) (require 'vm-macro) (require 'vm-misc) (require 'vm-undo) (require 'vm-startup) (require 'vm-motion) (require 'vm-summary) (require 'vm-folder) (require 'vm-window) (require 'vm-vars)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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)) (provide 'vm-grepmail) ;;; vm-grepmail.el ends here vm-8.1.2/lisp/vm-message.el0000644000175000017500000003736211725175471016000 0ustar srivastasrivasta;;; vm-message.el --- Macros and functions dealing with accessing VM message struct fields ;; ;; 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: ;; data that is always shared with virtual folders (defsubst vm-location-data-of (message) (aref message 0)) ;; 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 (defsubst vm-vheaders-of (message) (or (aref (aref message 0) 2) (progn (vm-reorder-message-headers message nil nil) (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 (defsubst vm-softdata-of (message) (aref message 1)) (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)) ;; message attribute vector (defsubst vm-attributes-of (message) (aref message 2)) (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)) ;; message cached data (defsubst vm-cache-of (message) (aref message 3)) ;; 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. (defsubst vm-headers-to-be-retrieved-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)) ;; 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 (defsubst vm-mirror-data-of (message) (aref message 4)) ;; 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-location-data-of (message vdata) (aset message 0 vdata)) (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-softdata-of (message data) (aset message 1 data)) (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-attributes-of (message attrs) (aset message 2 attrs)) ;; 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-attributes message) (vm-set-stuff-flag-of message t)) (and (not (buffer-modified-p)) (vm-set-buffer-modified-p t)) (vm-clear-modification-flag-undos)) (defsubst vm-set-cache-of (message cache) (aset message 3 cache)) (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 (message val) (aset (aref message 3) 21 val)) (defsubst vm-set-body-to-be-retrieved (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-mirror-data-of (message data) (aset message 4 data)) (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-make-message () (let ((v (make-vector 5 nil)) sym) (vm-set-softdata-of v (make-vector vm-softdata-vector-length nil)) (vm-set-location-data-of v (make-vector vm-location-data-vector-length nil)) (vm-set-mirror-data-of v (make-vector vm-mirror-data-vector-length nil)) (vm-set-message-id-number-of v (int-to-string vm-message-id-number)) (vm-increment vm-message-id-number) (vm-set-buffer-of v (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 v) (vm-set-real-message-sym-of v sym) ;; Another uninterned symbol for the virtual messages list. (setq sym (make-symbol "")) (set sym nil) (vm-set-virtual-messages-sym-of v sym) ;; Another uninterned symbol for the reverse link ;; into the message list. (setq sym (make-symbol "<--")) (vm-set-reverse-link-sym-of v sym) v )) (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))))) (defun vm-virtual-message-p (m) (not (eq m (vm-real-message-of m)))) (provide 'vm-message) ;;; vm-message.el ends here vm-8.1.2/lisp/vm-misc.el0000644000175000017500000013154111725175471015301 0ustar srivastasrivasta;;; vm-misc.el --- Miscellaneous functions for 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: (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) (if (null string) () (let (work-buffer) (save-excursion (unwind-protect (let (list start s char) (setq work-buffer (vm-make-work-buffer)) (set-buffer work-buffer) (insert string) (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 'vmrf-fix-quoted-address (reverse list))) (and work-buffer (kill-buffer work-buffer))))))) (defun vmrf-fix-quoted-address (a) "RF: evetually there are qp-encoded addresses not quoted by \" and thus we need to add quotes or leave them undecoded." (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)))) (defun vm-parse-structured-header (string &optional sepchar keep-quotes) (if (null string) () (let ((work-buffer nil)) (save-excursion (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)))) (setq work-buffer (vm-make-work-buffer)) (buffer-disable-undo work-buffer) (set-buffer work-buffer) (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 nil)) (unwind-protect (save-excursion (setq temp-buffer (generate-new-buffer "*vm-work*")) (set-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 () (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 () (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 () (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) (while (cdr-safe list) (setq list (cdr list))) 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-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) (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 (function &rest lists) (let (arglist) (while (car lists) (setq arglist (mapcar 'car lists)) (apply function arglist) (setq lists (mapcar 'cdr lists))))) (defun vm-delete (predicate list &optional reverse) (let ((p list) (reverse (if reverse 'not 'identity)) prev) (while p (if (funcall reverse (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-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))) (fset 'vm-view-file-other-frame (if (fboundp 'view-file-other-frame) 'view-file-other-frame 'view-file-other-window)) (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) ;; ignore it if undefined because calls to add-hook will add them locally )) (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))) (save-excursion (set-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) (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-message-hook (message &optional hook-variable) (save-excursion (set-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-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) (save-excursion (set-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 nil)) (condition-case nil (unwind-protect (save-excursion (setq temp-buffer (vm-make-work-buffer)) (set-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-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)))) (defun vm-set-region-face (start end face) (let ((e (vm-make-extent start end))) (vm-set-extent-property e 'face face))) (defun vm-default-buffer-substring-no-properties (beg end &optional buffer) (let ((s (if buffer (save-excursion (set-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))) (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-extent-properties)) (if vm-fsfemacs-p (fset 'vm-extent-properties 'overlay-properties) (fset 'vm-extent-properties 'extent-properties))) (defun vm-extent-at (pos &optional object property) (if (fboundp 'extent-at) (extent-at pos object 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-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) (let ((default-enable-multibyte-characters nil) work-buffer) (setq work-buffer (generate-new-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? ;; (save-excursion ;; (set-buffer work-buffer) ;; (setq buffer-offer-save nil)) work-buffer )) (defun vm-make-multibyte-work-buffer (&optional name) (let ((default-enable-multibyte-characters t) work-buffer) (setq work-buffer (generate-new-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? ;; (save-excursion ;; (set-buffer work-buffer) ;; (setq buffer-offer-save nil)) work-buffer )) (defun vm-insert-char (char &optional count ignored buffer) (condition-case nil (progn (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) (save-excursion (set-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-set-buffer-variable (buffer var value) (save-excursion (set-buffer buffer) (set var value))) (defun vm-buffer-variable-value (buffer var) (save-excursion (set-buffer buffer) (symbol-value var))) (defsubst vm-with-string-as-temp-buffer (string function) (let ((work-buffer nil)) (unwind-protect (save-excursion (setq work-buffer (vm-make-multibyte-work-buffer)) (set-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-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))) (cond ((fboundp 'coding-system-name) (fset 'vm-coding-system-name 'coding-system-name)) (t (fset 'vm-coding-system-name 'symbol-name))) (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))) (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 nil)) (unwind-protect (save-excursion (setq work-buffer (vm-make-work-buffer)) (set-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 (message "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 (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) ;; (message "Nothing to fill!") ;; (message "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) (if (memq buffer (symbol-value ring-variable)) (set ring-variable (delq buffer (symbol-value ring-variable)))) (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)))) (mapcar (function (lambda (b) (and (buffer-name b) (or (not (buffer-modified-p b)) (not (vm-buffer-variable-value 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)) (message "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))) ;; 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))) ;; 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) (defun vm-buffer-type:enter (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))) (defun vm-buffer-type:exit () (if vm-buffer-type-debug (setq vm-buffer-type-trail (cons 'exit vm-buffer-type-trail))) (setq vm-buffer-types (cdr vm-buffer-types))) (defun vm-buffer-type:duplicate () (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) (when vm-buffer-type-debug (if (and (eq type 'folder) vm-buffer-types (eq (car vm-buffer-types) 'process)) (debug "folder buffer being entered at inner level")) (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) (vm-assert (eq (car vm-buffer-types) type))) (provide 'vm-misc) ;;; vm-misc.el ends here vm-8.1.2/lisp/vm-crypto.el0000644000175000017500000001650611725175471015671 0ustar srivastasrivasta;;; vm-crypto.el --- Encryption and related functions for 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: ;; 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)) (provide 'vm-crypto) ;;; vm-crypto.el ends here vm-8.1.2/lisp/vm-thread.el0000644000175000017500000003152011725175471015611 0ustar srivastasrivasta;;; vm-thread.el --- Thread support for VM ;; ;; Copyright (C) 1994, 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: ;;;###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 and thread indentation (via the %I summary format specifier) will be visible." (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) ;; 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)) (if vm-summary-show-threads (vm-sort-messages "thread") (vm-sort-messages "physical-order"))) ;;;###autoload (defun vm-build-threads (message-list) (if (not (vectorp vm-thread-obarray)) (setq vm-thread-obarray (make-vector 641 0) vm-thread-subject-obarray (make-vector 641 0))) (let ((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) (while mp (setq m (car mp) parent (vm-th-parent m) id (vm-su-message-id m) id-sym (intern id vm-thread-obarray) date (vm-so-sortable-datestring m)) (put id-sym 'messages (cons m (get id-sym 'messages))) (put id-sym 'date date) (if (and (null (cdr (get id-sym 'messages))) schedule-reindents) (vm-thread-mark-for-summary-update (get id-sym 'children))) (if parent (progn (setq parent-sym (intern parent vm-thread-obarray)) (cond ((or (not (boundp id-sym)) (null (symbol-value id-sym)) (eq (symbol-value id-sym) parent-sym)) (set id-sym parent-sym)) (t (setq old-parent-sym (symbol-value id-sym)) (put old-parent-sym 'children (let ((kids (get old-parent-sym 'children)) (msgs (get id-sym 'messages))) (while msgs (setq kids (delq (car msgs) kids) msgs (cdr msgs))) kids )) (set id-sym parent-sym) (if schedule-reindents (vm-thread-mark-for-summary-update (get id-sym 'messages))))) (put parent-sym 'children (cons m (get parent-sym 'children)))) (if (not (boundp id-sym)) (set id-sym nil))) ;; 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. (if (cdr (setq refs (vm-th-references m))) (let (parent-sym id-sym msgs) (setq parent-sym (intern (car refs) vm-thread-obarray) refs (cdr refs)) (while refs (setq id-sym (intern (car refs) vm-thread-obarray)) (if (and (boundp id-sym) (symbol-value id-sym)) nil (set id-sym parent-sym) (if (setq msgs (get id-sym 'messages)) (put parent-sym 'children (append msgs (get parent-sym 'children)))) (if schedule-reindents (vm-thread-mark-for-summary-update msgs))) (setq parent-sym id-sym refs (cdr refs))))) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (message "Building threads (by reference)... %d" n))) (if vm-thread-using-subject (progn (setq n 0 mp (or message-list vm-message-list)) (while mp (setq m (car mp) parent (vm-th-parent m) id (vm-su-message-id m) id-sym (intern id vm-thread-obarray) date (vm-so-sortable-datestring m)) ;; inhibit-quit because we need to make sure the asets ;; below are an atomic group. (let* ((inhibit-quit t) (subject (vm-so-sortable-subject m)) (subject-sym (intern subject vm-thread-subject-obarray))) ;; if this subject was never seen before create the ;; information vector. (if (not (boundp subject-sym)) (set subject-sym (vector id-sym date nil (list m))) ;; this subject seen before (aset (symbol-value subject-sym) 3 (cons m (aref (symbol-value subject-sym) 3))) (if (string< date (aref (symbol-value subject-sym) 1)) (let* ((vect (symbol-value subject-sym)) (i-sym (aref vect 0))) ;; optimization: if we know that this message ;; already has a parent, then don't bother ;; adding it to the list of child messages ;; since we know that it will be threaded and ;; unthreaded using the parent information. (if (or (not (boundp i-sym)) (null (symbol-value i-sym))) (aset vect 2 (append (get i-sym 'messages) (aref vect 2)))) (aset vect 0 id-sym) (aset vect 1 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. (if schedule-reindents (let ((inhibit-quit nil)) (vm-thread-mark-for-summary-update (aref vect 2))))) ;; optimization: if we know that this message ;; already has a parent, then don't bother adding ;; it to the list of child messages, since we ;; know that it will be threaded and unthreaded ;; using the parent information. (if (null parent) (aset (symbol-value subject-sym) 2 (cons m (aref (symbol-value subject-sym) 2))))))) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) (message "Building threads (by subject)... %d" n))))) (if (> n modulus) (message "Building threads... done")))) ;; used by the thread sort code. ;; ;; vm-th-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 () (let ((mp vm-message-list)) (while mp (vm-th-thread-list (car mp)) (setq mp (cdr mp))))) (defun vm-thread-mark-for-summary-update (message-list) (let (m) (while message-list (setq m (car message-list)) ;; 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 (get (intern (vm-su-message-id m) vm-thread-obarray) 'children))) (setq message-list (cdr message-list))))) (defun vm-thread-list (message) (let ((done nil) (m message) (loop-recovery-point nil) (date (vm-so-sortable-datestring message)) thread-list id-sym subject-sym loop-sym root-date youngest-date) (save-excursion (set-buffer (vm-buffer-of m)) (fillarray vm-thread-loop-obarray 0) (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray) thread-list (list 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 (get id-sym 'oldest-date)) (if (or (null root-date) (string< date root-date)) (put id-sym 'oldest-date date)) ;; save the date of the youngest message in this thread (setq youngest-date (get id-sym 'youngest-date)) (if (or (null root-date) (string< youngest-date date)) (put id-sym 'youngest-date date)) (if (and (boundp id-sym) (symbol-value id-sym)) (progn (setq id-sym (symbol-value 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) m (car (get id-sym 'messages))))) (if (null m) (setq done t) (if (null vm-thread-using-subject) (setq done t) (setq subject-sym (intern (vm-so-sortable-subject m) vm-thread-subject-obarray)) (if (or (not (boundp subject-sym)) (eq (aref (symbol-value subject-sym) 0) id-sym)) (setq done t) (setq id-sym (aref (symbol-value subject-sym) 0) ;; seems to cause more trouble than it fixes ;; revisit this later. ;; loop-recovery-point (or loop-recovery-point ;; thread-list) 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) m (car (get id-sym 'messages))))))))) 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 (message &optional message-changing) (save-excursion (let ((mp (cons message (vm-virtual-messages-of message))) m id-sym subject-sym vect p-sym) (while mp (setq m (car mp)) (set-buffer (vm-buffer-of m)) (if (not (vectorp vm-thread-obarray)) nil (let ((inhibit-quit t)) (vm-set-thread-list-of m nil) (vm-set-thread-indentation-of m nil) (setq id-sym (intern (vm-su-message-id m) vm-thread-obarray) subject-sym (intern (vm-so-sortable-subject m) vm-thread-subject-obarray)) (if (boundp id-sym) (progn (put id-sym 'messages (delq m (get id-sym 'messages))) (vm-thread-mark-for-summary-update (get id-sym 'children)) (setq p-sym (symbol-value id-sym)) (and p-sym (put p-sym 'children (delq m (get p-sym 'children)))) (if message-changing (set id-sym nil)))) (if (and (boundp subject-sym) (setq vect (symbol-value subject-sym))) (if (not (eq id-sym (aref vect 0))) (aset vect 2 (delq m (aref vect 2))) (if message-changing (if (null (cdr (aref vect 3))) (makunbound subject-sym) (let ((p (aref vect 3)) oldest-msg oldest-date children) (setq oldest-msg (car p) oldest-date (vm-so-sortable-datestring (car p)) p (cdr p)) (while p (if (and (string-lessp (vm-so-sortable-datestring (car p)) oldest-date) (not (eq m (car p)))) (setq oldest-msg (car p) oldest-date (vm-so-sortable-datestring (car p)))) (setq p (cdr p))) (aset vect 0 (intern (vm-su-message-id oldest-msg) vm-thread-obarray)) (aset vect 1 oldest-date) (setq children (delq oldest-msg (aref vect 2))) (aset vect 2 children) (aset vect 3 (delq m (aref vect 3))) ;; I'm not sure there aren't situations ;; where this might loop forever. (let ((inhibit-quit nil)) (vm-thread-mark-for-summary-update children))))))))) (setq mp (cdr mp)))))) (defun vm-th-references (m) (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 "[^<]*\\(<[^>]+>\\)")))))) (defun vm-th-parent (m) (or (vm-parent-of m) (vm-set-parent-of m (or (car (vm-last (vm-th-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 (if (< (length id) (length (car ids))) (setq id (car ids))) (setq ids (cdr ids))) (and id (vm-set-references-of m (list id))) id ))))) ;;;###autoload (defun vm-th-thread-indentation (m) (or (vm-thread-indentation-of m) (let ((p (vm-th-thread-list m))) (while (and p (null (get (car p) 'messages))) (setq p (cdr p))) (vm-set-thread-indentation-of m (1- (length p))) (vm-thread-indentation-of m)))) ;;;###autoload (defun vm-th-thread-list (m) (or (vm-thread-list-of m) (progn (vm-set-thread-list-of m (vm-thread-list m)) (vm-thread-list-of m)))) (provide 'vm-thread) ;;; vm-thread.el ends here vm-8.1.2/lisp/vm-biff.el0000644000175000017500000004050511725175471015253 0ustar srivastasrivasta;;; vm-biff.el --- a xlbiff like tool 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! ;; (eval-when-compile (require 'cl)) (when vm-xemacs-p (require 'overlay)) (when vm-fsfemacs-p (defvar horizontal-scrollbar-visible-p nil)) (defgroup vm nil "VM" :group 'mail) (defgroup vm-biff nil "The VM biff lib" :group 'vm) (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 (get-buffer-window buf (vm-biff-x-p) (frame-device)) (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) (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 (and vm-mouse-track-summary (vm-mouse-support-possible-p))) (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) (vm-summary-highlight-region start (point) vm-summary-highlight-face) (when do-mouse-track (vm-mouse-set-mouse-track-highlight start (point))) (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 (get-buffer-window buf t (frame-device)) (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)) (setq h (- (window-displayed-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) (provide 'vm-biff) vm-8.1.2/lisp/vm-motion.el0000644000175000017500000004166311725175471015660 0ustar srivastasrivasta;;; vm-motion.el --- Commands to move around in a VM folder ;; ;; 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: (defun vm-record-and-change-message-pointer (old new) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-preview-current-message) (vm-record-and-change-message-pointer vm-message-pointer cons) (vm-preview-current-message))))) ;;;###autoload (defun vm-goto-message-last-seen () "Go to the message last previewed." (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-preview-current-message)))) ;;;###autoload (defun vm-goto-parent-message () "Go to the parent of the current message." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-build-threads-if-unbuilt) (vm-display nil nil '(vm-goto-parent-message) '(vm-goto-parent-message)) (let ((list (vm-th-thread-list (car vm-message-pointer))) message) (if (null (cdr list)) (message "Message has no parent.") (while (cdr (cdr list)) (setq list (cdr list))) (setq message (car (get (car list) 'messages))) (if (null message) (message "Parent message is not in this folder.") (vm-record-and-change-message-pointer vm-message-pointer (memq message vm-message-list)) (vm-preview-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) (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) (if skip-dogmatically (or (and vm-skip-deleted-messages (vm-deleted-flag (car mp))) (and vm-skip-read-messages (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))))) (or (and (eq vm-skip-deleted-messages t) (vm-deleted-flag (car mp))) (and (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))))))) ;;;###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") (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) ;; 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)) (and signal-errors (vm-error-if-folder-empty)) (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)))) (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. (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)))))) (if (not (eq vm-message-pointer oldmp)) (progn (vm-record-and-change-message-pointer oldmp vm-message-pointer) (vm-preview-current-message))) (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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-display nil nil '(vm-next-message-no-skip) '(vm-next-message-no-skip)) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil)) (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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-display nil nil '(vm-previous-message-no-skip) '(vm-previous-message-no-skip)) (let ((vm-skip-deleted-messages nil) (vm-skip-read-messages nil)) (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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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 (message "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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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 (message "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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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-preview-current-message)) (end-of-folder (setq vm-message-pointer oldmp) (message "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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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-preview-current-message)) (beginning-of-folder (setq vm-message-pointer oldmp) (message "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 () (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." (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 ) ;; make the position at eob belong to the last message ((eobp) (setq mp (vm-last message-pointer)) (save-excursion (set-buffer vm-mail-buffer) (vm-record-and-change-message-pointer vm-message-pointer mp) (vm-preview-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 (and (not (eq mp message-pointer)) (>= point (vm-su-end-of (car mp)))) (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) (vm-preview-current-message) ;; return non-nil so the caller will know that ;; a new message was selected. t ))))))) (provide 'vm-motion) ;;; vm-motion.el ends here vm-8.1.2/lisp/vm-mark.el0000644000175000017500000004021411725175471015274 0ustar srivastasrivasta;;; vm-mark.el --- Commands for handling messages marks ;; ;; 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: ;;;###autoload (defun vm-clear-all-marks () "Removes all message marks in the current folder." (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (message "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) (message "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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (message "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) (message "Toggling all marks... done")) ;;;###autoload (defun vm-mark-all-messages () "Mark all messages in the current folder." (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (message "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) (message "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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((mlist (vm-select-marked-or-prefixed-messages count))) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (message "%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)) (vm-select-folder-buffer) (vm-read-virtual-selector "Mark messages: "))) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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)) (vm-select-folder-buffer) (vm-read-virtual-selector "Unmark messages: "))) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-mark-or-unmark-thread-subtree nil)) (defun vm-mark-or-unmark-thread-subtree (mark) (vm-build-threads-if-unbuilt) (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 (car (vm-last (vm-th-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 (get id-sym 'children))) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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))) (if (zerop mark-count) (message "No messages %smarked" (if mark "" "un")) (message "%d message%s %smarked" mark-count (if (= 1 mark-count) "" "s") (if mark "" "un")))) (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)) ;;;###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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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))) (if (zerop mark-count) (message "No messages %smarked" (if mark "" "un")) (message "%d message%s %smarked" mark-count (if (= 1 mark-count) "" "s") (if mark "" "un")))) (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)) (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) (message "%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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (message "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)) (message "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ...")) (provide 'vm-mark) ;;; vm-mark.el ends here vm-8.1.2/lisp/vm-vars.el0000644000175000017500000067757011725175471015342 0ustar srivastasrivasta;;; vm-vars.el --- VM user and internal variable initialization ;; ;; 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: (require 'vm-version) (defgroup vm nil "The VM mail reader." :group 'mail) (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 :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 :type 'file) (defcustom vm-preferences-file "~/.vm.preferences" "Unused. *Secondary startup file for VM, loaded after `vm-init-file'. This file is written and overwritten by VM and is not meant for users to edit directly." :group 'vm :type 'file) (defcustom vm-folder-directory nil "*Directory where folders of mail are kept." :group 'vm :type '(choice (const nil) directory)) (defcustom vm-primary-inbox "~/INBOX" "*Mail is moved from the system mailbox to this file for reading." :group 'vm :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 nil, `vm-primary-inbox' with `vm-crash-box-suffix' appende will be used as crash boxdot set." :group 'vm :type '(choice file (const :tag "Automatic" 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 :type '(choice directory (const :tag "No not keep crash boxes" nil))) (defcustom vm-index-file-suffix nil "*Suffix used to construct VM index file names. 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 :type '(choice string (const nil))) ;; This is added by Uday Reddy as a temporary measure. 2008-04-15 ;; It should really be folder-specific and saved with the folders on ;; the file system. (defvar vm-load-headers-only nil "If non-nil, asks VM to load headers of mail folders whenever possible, without loading the message bodies. This allows faster start-ups and smaller memory images of Emacs sessions, at the cost of short delays when messages are viewed. As of April 2008, this facility is still experimental and is only available for IMAP folders.") ;; 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. You must have the stunnel program installed and the variable `vm-stunnel-program' naming it in order for POP over SSL to work. 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. You must have the stunnel program installed and the variable `vm-stunnel-program' naming it in order for IMAP over SSL to work. 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 :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 :type '(repeat string)) (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 :type '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 :type '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 :type 'function) (defcustom vm-pop-md5-program "md5" "*Program that reads a message on its standard input and writes an MD5 digest on its output." :group 'vm :type 'string) (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 :type '(choice (const nil) integer)) (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 :type '(choice (const 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 :type '(choice (const nil) integer)) (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 :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 :type '(repeat (cons string boolean))) (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 :type 'boolean) (defcustom vm-recognize-pop-maildrops "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?[^:]+:[^:]+:[^:]+:[^:]+:.+" "*Value if non-nil should be a regular expression that matches spool names found in `vm-spool-files' that should be considered POP maildrops. A nil value tells VM that all the spool names are to be considered files except those matched by `vm-recognize-imap-maildrops'." :group 'vm :type 'regexp) (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 :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 :type '(choice (const nil) directory)) (defcustom vm-imap-max-message-size nil "*If VM is about to retrieve via IMAP a message larger than this size (in bytes) it will ask 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-imap-max-message-size' means no size limit." :group 'vm :type '(choice (const nil) integer)) (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 :type '(choice (const 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 :type '(choice (const nil) integer)) (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 :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 :type '(repeat (cons string boolean))) (defcustom vm-recognize-imap-maildrops "^\\(imap\\|imap-ssl\\|imap-ssh\\):[^:]+:[^:]+:[^:]+:[^:]+:[^:]+:.+" "*Value if non-nil should be a regular expression that matches spool names found in `vm-spool-files' that should be considered IMAP maildrops. A nil value tells VM that all the spool names are to be considered files except those matched by `vm-recognize-pop-maildrops'." :group 'vm :type 'regexp) (defcustom 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:*\" ) )" :group 'vm :type '(repeat string)) (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 :type '(repeat (list string string))) (defcustom vm-imap-tolerant-of-bad-imap 0 "*Level of tolerance that vm should use for IMAP servers that don't follow the IMAP specification. Default of 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 :type '(choice (const nil) integer)) (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 :type '(choice (const nil) directory)) (defcustom vm-imap-save-to-server nil "*If this variable is non-NIL, then the save-message command should save to IMAP folders on the server, rather than to local files." :group 'vm :type '(choice (const nil) (const t))) (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) (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 :type '(choice (const t) (const nil))) (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 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 :type '(choice boolean integer)) (defcustom vm-mail-check-interval 300 "*Numeric value specifies the number of seconds between checks for new mail. 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 :type '(choice (const nil) integer)) (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 :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 :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 :type '(choice (const nil) (const crlf) (const cr) (const 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 :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 :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 :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-visible-headers '("Resent-" "From:" "Sender:" "To:" "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 :type '(list 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 :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 :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 :type 'boolean) (defgroup vm-faces nil "VM additional virtual folder selectors and functions." :group 'vm) (defcustom vm-highlighted-header-face 'bold "*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 :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 :type 'boolean) (defcustom vm-always-use-presentation-buffer t "****This variable is deprecated. Starting from version 8.2.0, the behaviour will be equivalent to setting this variable to t. Please remove all settings for this variable and report any problems that you might encounter. 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." :group 'vm :type 'boolean) (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 :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 :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 :type '(choice (const nil) (const window-width) (const wrap) integer)) (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 :type '(choice (const nil) (const window-width) (const wrap) integer)) (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 :type 'integer) (defcustom vm-fill-long-lines-in-reply-column (default-value 'fill-column) "*Fill lines spanning that many columns or more in replies." :type '(choice (const nil) (const window-width) integer) :group 'vm) (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 :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 :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 :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 :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 :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 :type 'boolean) (defcustom vm-honor-mime-content-disposition nil "*Non-nil value means use information from the Content-Disposition header to display MIME messages. 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 :type 'boolean) (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 :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 :type 'boolean) (defcustom vm-auto-displayed-mime-content-types '("text" "image" "multipart" "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-auto-displayed-mime-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 some types are processed specially, and this variable does not apply to them. 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 :type '(choice (const t) (repeat string))) (defcustom vm-auto-displayed-mime-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-auto-displayed-mime-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-auto-displayed-mime-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 :type '(repeat string)) (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 display 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 :type '(choice (const t) (const nil) (repeat string))) (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 :type '(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 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, 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\" \"netscape\") (\"image/gif\" \"xv\") (\"image/jpeg\" \"xv\") (\"video/mpeg\" \"mpeg_play\") (\"video\" \"xanim\") ) ) The first matching list element will be used. No multipart message will ever be sent to an external viewer." :group 'vm :type '(repeat (list string string))) (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 :type '(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 :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 :type '(repeat (list (string :tag "From type") (string :tag "To type") (string :tag "Converter program")))) (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 :type '(repeat (list string string string))) (defcustom vm-mime-alternative-select-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. 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 :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 :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 :type 'regexp) (defcustom vm-mime-text/html-blocker-exceptions nil "*Regexp matching URL which should not be blocked." :group 'vm :type '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 :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 :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 :type '(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 :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 :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 ; (message "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 :type '(choice string (const nil))) (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 :type '(choice string (const nil))) (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 :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 :type 'boolean) (defcustom vm-mime-savable-types (append '("application" "x-unknown" "application/x-gzip") (mapcar (lambda (a) (car a)) vm-mime-external-content-types-alist)) "*List of MIME types which should be saved." :group 'vm :type '(repeat (string :tag "MIME type" nil))) (defcustom vm-mime-savable-type-exceptions '("text") "*List of MIME types which should not be saved." :group 'vm :type '(repeat (string :tag "MIME type" nil))) (defcustom vm-mime-deletable-types (append '("application" "x-unknown" "application/x-gzip") (mapcar (lambda (a) (car a)) vm-mime-external-content-types-alist)) "*List of MIME types which should be deleted." :group 'vm :type '(repeat (string :tag "MIME type" nil))) (defcustom vm-mime-deletable-type-exceptions '("text") "*List of MIME types which should not be deleted." :group 'vm :type '(repeat (string :tag "MIME type" nil))) (defvar vm-mime-auto-save-all-attachments-avoid-recursion nil "For internal use.") (defcustom vm-mime-button-face 'gui-button-face "*Face used for text in buttons that trigger the display of MIME objects." :group 'vm-faces :type 'boolean) (defcustom vm-mime-button-format-alist '(("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 :type '(repeat (cons string 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 :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 :type '(choice (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 :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 :type 'boolean) (defcustom vm-mime-attachment-auto-type-alist '( ("\\.jpe?g$" . "image/jpeg") ("\\.gif$" . "image/gif") ("\\.png$" . "image/png") ("\\.tiff?$" . "image/tiff") ("\\.pcx$" . "image/x-pcx") ("\\.txt$" . "text/plain") ("\\.html?$" . "text/html") ("\\.vcf$" . "text/x-vcard") ("\\.au$" . "audio/basic") ("\\.mpe?g$" . "video/mpeg") ("\\.mov$" . "video/quicktime") ("\\.zip$" . "application/zip") ("\\.e?ps$" . "application/postscript") ("\\.pdf$" . "application/pdf") ("\\.doc$" . "application/msword") ("\\.xls$" . "application/vnd.ms-excel") ("\\.ppt$" . "application/vnd.ms-powerpoint") ("\\.mdb$" . "application/vnd.ms-access") ("\\.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-mime-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 :type '(repeat (cons regexp string))) (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 :type '(repeat (cons string string))) (defcustom vm-mime-encode-headers-regexp "Subject\\|\\(\\(Resent-\\)?\\(From\\|To\\|CC\\|BCC\\)\\)\\|Organization" "*A regexp matching the headers which should be encoded." :group 'vm :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 :type '(regexp)) (defcustom vm-mime-encode-headers-type 'Q "*The encoding type to use for encoding headers." :group 'vm :type '(choice (const Q) (const 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 :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 :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 :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-mime-attach-file' prompts you for the name of a file to attach, any relative pathnames will be relative to this directory." :group 'vm :type '(choice (const nil) directory)) (defcustom vm-mime-all-attachments-directory nil "*Directory to where the attachments should go or come from." :group 'vm :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.") (defcustom vm-mime-yank-attachments nil "*Non-nil value enables yanking of attachments. Otherwise only the button label will be yanked. (This functionally is currently part of vm-pine.el.)" :group 'vm :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 :type 'boolean) (defcustom vm-mime-attachment-infer-type-for-text-attachments 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 :type 'boolean) (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 :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 :type '(choice string (const nil))) (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 :type '(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 :type '(choice string (const nil))) (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 :type '(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 :type '(choice string (const nil))) (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 :type '(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 :type '(choice string (const nil))) (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 :type '(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 :type '(choice string (const nil))) (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 :type '(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 :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 :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 :type 'boolean) (defvar 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 :type 'file) (defcustom vm-confirm-quit 0 "*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 :type '(choice (const t) (const nil) (const 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 :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 :type '(choice (const nil) (const t) (const 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 :type 'boolean) (defcustom vm-flush-interval 90 "*Non-nil value specifies how often VM flushes its cached internal data. 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 :type '(choice boolean integer)) (defcustom vm-visit-when-saving 0 "*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 that is not nil and not t means VM will save to a folder's buffer if that folder is being visited, otherwise VM saves to the folder file itself." :group 'vm :type '(choice boolean (const if-already-visited))) (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 :type '(repeat (cons regexp (repeat (cons regexp sexp))))) (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 :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-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 :type 'sexp) (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 :type 'boolean) (make-variable-buffer-local 'vm-virtual-mirror) (defcustom 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." :group 'vm :type 'boolean) (make-variable-buffer-local 'vm-folder-read-only) (defcustom vm-included-text-prefix " > " "*String used to prefix included text in replies." :group 'vm :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 :type '(choice boolean integer)) (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 :type 'boolean) (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 :type '(choice (const nil) string)) (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 :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 :type 'boolean) (defcustom vm-mail-header-order '("From:" "Organization:" "Subject:" "Date:" "Priority:" "X-Priority:" "Importance:" "Message-ID:" "MIME-Version:" "Content-Type:" "To:" "CC:" "BCC:" "Reply-To:") "*Order of headers when calling `vm-reorder-message-headers' interactively in a composition buffer." :group 'vm :type '(list string)) (defcustom vm-mail-reorder-message-headers nil "*Reorder message headers before sending." :group 'vm :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 :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 :type '(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 :type '(repeat regexp)) (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 :type 'boolean) (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 :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 :type '(choice (const nil) string)) (defcustom vm-included-mime-types-list nil "*If non-nil, the list of mime type/subtype pairs that should be included in quote text in a reply message. A suitable value could be '(\"text/plain\" \"text/enriched\" \"message/rfc822\") If it is nil, it means that the default MIME displaying mechanism of VM is used to generate the included text, as controlled by variables like `vm-auto-displayed-mime-content-types'. The defaut value is nil." :group 'vm :type '(repeat string)) (defcustom vm-include-text-from-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." :group 'vm :type 'boolean) (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 only headers matched by that variable will be omitted; 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 :type '(repeat regexp)) (defcustom vm-included-text-discard-header-regexp nil "*Non-nil value should be a regular expression header 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 :type '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 :type 'string) (defcustom vm-forwarded-headers nil "*List of headers that should be forwarded by `vm-forward-message'. These 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 only headers matched by that variable will be omitted; all 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 :type '(repeat regexp)) (defcustom vm-unforwarded-header-regexp "only-drop-this-header" "*Non-nil value should be a regular expression header that tells what headers should not be forwarded by `vm-forward-message'. 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 headers matched by this variable will not be forwarded; all 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 :type '(choice (const nil) regexp)) (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 a message. Legal values of this variable are: \"rfc934\" \"rfc1153\" \"mime\" nil A nil value means don't use a digest, just mark the beginning and end of the forwarded message." :group 'vm :type '(choice (const "rfc934") (const "rfc1153") (const "mime") (const :tag "Do not use digests" nil))) (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 method 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 :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 :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 :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 :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 :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 :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\" " :group 'vm :type '(choice (const "rfc934") (const "rfc1153") (const "mime"))) (defcustom vm-rfc934-digest-headers '("Resent-" "From:" "Sender:" "To:" "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 :type '(repeat regexp)) (defcustom vm-rfc934-digest-discard-header-regexp nil "*Non-nil value should be a regular expression header 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 :type 'regexp) (defcustom vm-rfc1153-digest-headers '("Resent-" "Date:" "From:" "Sender:" "To:" "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 :type '(repeat regexp)) (defcustom vm-rfc1153-digest-discard-header-regexp "\\(X400-\\)?Received:" "*Non-nil value should be a regular expression header 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 :type 'regexp) (defcustom vm-mime-digest-headers '("Resent-" "From:" "Sender:" "To:" "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 :type '(repeat regexp)) (defcustom vm-mime-digest-discard-header-regexp nil "*Non-nil value should be a regular expression header 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 :type 'regexp) (defcustom vm-resend-bounced-headers '("MIME-Version:" "Content-" "From:" "Sender:" "Reply-To:" "To:" "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 :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 :type '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 :type '(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 :type '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 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. 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. 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 :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 :type 'boolean) (defcustom vm-summary-postponed-indicator "P" "*Indicator shown for postponed messages." :group 'vm :type 'string) (defcustom vm-summary-attachment-indicator "$" "*Indicator shown for messages containing an attachments." :group 'vm :type '(choice (string :tag "A string to display" "$") (symbol :tag "Display the 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 :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 :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 :type 'string) (defcustom vm-summary-highlight-face 'bold "*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 :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 :type 'boolean) (make-variable-buffer-local 'vm-summary-show-threads) (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 :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 :type 'boolean) (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 :type 'boolean) (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 :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 :type 'string) (defcustom vm-auto-center-summary 0 "*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 :type '(choice (const nil) (const t) (const yes-if-not-only-window))) (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 :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 :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 :type '(choice (const nil) integer)) (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 :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 :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 :type '(repeat directory)) (defcustom vm-mutable-windows 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 :type 'boolean) (defcustom vm-mutable-frames 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 :type 'boolean) (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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :type 'boolean) (defvar vm-configure-datadir nil "A directory VM will search for data files. It will be set at built 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 built 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 (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 :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 :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 19.12 and beyond. Under FSF Emacs 21 the toolbar is always at the top of the frame." :group 'vm :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 :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 :type 'sexp) (defcustom vm-use-menus (nconc (list 'folder 'motion 'send 'mark 'label 'sort 'virtual) (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) nil) (t (list 'undo))) (list 'dispose) (cond ((string-match ".*-.*-\\(win95\\|nt\\)" system-configuration) nil) (t (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 :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-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 :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 :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 :type '(set (const lynx) (const wget) (const w3m) (const fetch) (const curl) (const url-w3))) (defcustom vm-url-browser (cond ((fboundp 'w3-fetch-other-frame) 'w3-fetch-other-frame) ((fboundp 'w3-fetch) 'w3-fetch) (t 'vm-mouse-send-url-to-netscape)) "*Non-nil value means VM should enable URL passing. This means that VM will search for URLs (Uniform Resource Locators) in messages and make it possible for you to pass them to a World Wide Web browser. Clicking mouse-2 on the URL will send it to the browser. By default clicking mouse-3 on the URL will pop up a menu of browsers and you can pick which one you want to use. If `vm-popup-menu-on-mouse-3' is set to nil, you will not see the menu. Moving point to a character within the URL and pressing RETURN will send the URL to the 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 program as its first and only argument. Use (setq vm-url-browser 'vm-mouse-send-url-to-netscape) for Netscape, and (setq vm-url-browser 'vm-mouse-send-url-to-mmosaic) for mMosaic, and (setq vm-url-browser 'vm-mouse-send-url-to-mosaic) for Mosaic. The advantage of using them is that they will display an URL using an existing Mosaic or Netscape process, if possible. A nil value means VM should not enable URL passing to browsers." :group 'vm :type '(choice (const nil) function string)) (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 :type '(repeat string)) (defcustom vm-highlight-url-face 'bold-italic "*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 :type '(choice (const nil) integer)) (defcustom vm-display-xfaces nil "*Non-nil means display images as specified in X-Face headers. This requires at least XEmacs 19.12 with native xface support compiled in." :group 'vm :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 :type '(choice (const t) (const nil) integer)) (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 :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 :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 :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 :type '(choice (const nil) (const t) (const 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 :type '(choice (const nil) (const t) (const skip-if-some-undeleted))) (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 :type '(choice (const nil) (const t) (const 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 :type '(choice (const nil) (const t) (const 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 :type '(choice (const nil) (const t) (const 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 :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 :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 :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 :type '(choice (const nil) (const t) (const 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 :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 :type 'boolean) (defcustom vm-edit-message-mode 'text-mode "*Major mode to use when editing messages in VM." :group 'vm :type 'function) (defvar lpr-command) (defcustom vm-print-command (if (boundp 'lpr-command) lpr-command "lpr") "*Command VM uses to print messages." :group 'vm :type '(choice string (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 :type '(repeat string)) (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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :type 'hook) (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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :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 :type 'hook) (defcustom vm-iconify-frame-hook nil "*List of hook functions that are run whenever VM iconifies a frame." :group 'vm :type 'hook) (defcustom vm-menu-setup-hook nil "*List of hook functions that are run just after all menus are initialized." :group 'vm :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 :type 'function) (defcustom vm-mime-deleted-object-label "[Deleted %f (%d;%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 :type 'string) (defcustom vm-mime-show-alternatives nil "*This variable is deprecated. You can set `vm-mime-alternative-select-method' to 'all to get the same effect as setting this one to t." :group 'vm :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 :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 :type 'hook) (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)) (defcustom 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." :group 'vm :type 'function) (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 :type 'string) (defcustom vm-movemail-program-switches nil "*List of command line flags to pass to the movemail program named by `vm-movemail-program'." :group 'vm :type '(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 :type 'string) (defcustom vm-netscape-program-switches nil "*List of command line switches to pass to Netscape." :group 'vm :type '(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 :type 'string) (defcustom vm-opera-program-switches nil "*List of command line switches to pass to Opera." :group 'vm :type '(repeat string)) (defcustom vm-mozilla-program "mozilla" "*Name of program to use to run Mozilla. `vm-mouse-send-url-to-mozilla' uses this." :group 'vm :type 'string) (defcustom vm-mozilla-program-switches nil "*List of command line switches to pass to Mozilla." :group 'vm :type '(repeat string)) (defcustom vm-mosaic-program "Mosaic" "*Name of program to use to run Mosaic. `vm-mouse-send-url-to-mosaic' uses this." :group 'vm :type 'string) (defcustom vm-mosaic-program-switches nil "*List of command line switches to pass to Mosaic." :group 'vm :type '(repeat string)) (defcustom vm-mmosaic-program "mMosaic" "*Name of program to use to run mMosaic. `vm-mouse-send-url-to-mosaic' uses this." :group 'vm :type 'string) (defcustom vm-mmosaic-program-switches nil "*List of command line switches to pass to mMosaic." :group 'vm :type '(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 :type 'string) (defcustom vm-konqueror-program-switches nil "*List of command line switches to pass to Konqueror." :group 'vm :type '(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 :type 'string) (defcustom vm-konqueror-client-program-switches nil "*List of command line switches to pass to Konqueror client." :group 'vm :type '(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 :type 'string) (defcustom vm-firefox-program-switches nil "*List of command line switches to pass to Mozilla Firefox." :group 'vm :type '(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 :type 'string) (defcustom vm-firefox-client-program-switches '("-remote") "*List of command line switches to pass to Mozilla Firefox client." :group 'vm :type '(repeat string)) (defcustom vm-wget-program "wget" "*Name of program to use to run wget. This is used to retrieve URLs." :group 'vm :type 'string) (defcustom vm-w3m-program "w3m" "*Name of program to use to run w3m. This is used to retrieve URLs." :group 'vm :type 'string) (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 :type 'string) (defcustom vm-curl-program "curl" "*Name of program to use to run curl. This is used to retrieve URLs." :group 'vm :type 'string) (defcustom vm-lynx-program "lynx" "*Name of program to use to run lynx. This is used to retrieve URLs." :group 'vm :type 'string) (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 :type '(choice string (const nil))) (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. Set this to nil and VM will not use it." :group 'vm :type '(choice string (const nil))) (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 :type '(list 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 te ncessary 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 :type 'string) (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 :type '(choice (const 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 :type '(choice string (const nil))) (defcustom vm-ssh-program-switches nil "*List of command line switches to pass to SSH." :group 'vm :type '(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 :type 'string) (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 :type '(choice string (const nil))) (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 :type '(choice string (const nil))) (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-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 :type 'directory) (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 :type 'boolean) (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 :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 :type '(repeat 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 :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 :type '(choice (const :tag "Disabled" nil) (regexp :tag "Enabled" "[^ a-zA-Z0-9.,_\"'+-]") (regexp :tag "Custom regexp"))) (defcustom vm-buffer-name-limit 80 "*The limit for a generated buffer name." :group 'vm :type '(choice (const :tag "Disabled" nil) (integer :tag "Enabled" 80) (integer :tag "Length"))) (defconst vm-maintainer-address "vm@lists.launchpad.net" "Where to send VM bug reports.") (defvar vm-mode-map (let ((map (make-keymap))) ;; unneeded now that VM buffers all have buffer-read-only == t. ;; (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-goto-message) (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-scroll-backward) (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-unread-message) (define-key map "e" 'vm-edit-message) (define-key map "a" 'vm-set-message-attributes) (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 "c" 'vm-continue-composing-message) (define-key map "@" 'vm-send-digest) (define-key map "*" 'vm-burst-digest) (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-save-message-sans-headers) (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-pipe-message-to-command) (define-key map "|d" 'vm-pipe-message-to-command-discard-output) (define-key map "|s" 'vm-pipe-messages-to-command) (define-key map "|n" 'vm-pipe-messages-to-command-discard-output) (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-iconify-frame) (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 "!" 'shell-command) (define-key map "<" 'vm-beginning-of-message) (define-key map ">" 'vm-end-of-message) (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-summarize) (define-key map "L" 'vm-load-init-file) (define-key map "\M-l" 'vm-edit-init-file) (define-key map "l" (make-sparse-keymap)) (define-key map "la" 'vm-add-message-labels) (define-key map "le" 'vm-add-existing-message-labels) (define-key map "ld" 'vm-delete-message-labels) (define-key map "V" (make-sparse-keymap)) (define-key map "VV" 'vm-visit-virtual-folder) (define-key map "VC" 'vm-create-virtual-folder) (define-key map "VA" 'vm-create-virtual-folder-same-author) (define-key map "VS" 'vm-create-virtual-folder-same-subject) (define-key map "VX" 'vm-apply-virtual-folder) (define-key map "VM" 'vm-toggle-virtual-mirror) (define-key map "V?" 'vm-virtual-help) (define-key map "M" (make-sparse-keymap)) (define-key map "MN" 'vm-next-command-uses-marks) (define-key map "Mn" 'vm-next-command-uses-marks) (define-key map "MM" 'vm-mark-message) (define-key map "MU" 'vm-unmark-message) (define-key map "Mm" 'vm-mark-all-messages) (define-key map "Mu" 'vm-clear-all-marks) (define-key map "MC" 'vm-mark-matching-messages) (define-key map "Mc" 'vm-unmark-matching-messages) (define-key map "MT" 'vm-mark-thread-subtree) (define-key map "Mt" 'vm-unmark-thread-subtree) (define-key map "MS" 'vm-mark-messages-same-subject) (define-key map "Ms" 'vm-unmark-messages-same-subject) (define-key map "MA" 'vm-mark-messages-same-author) (define-key map "Ma" 'vm-unmark-messages-same-author) (define-key map "MR" 'vm-mark-summary-region) (define-key map "Mr" 'vm-unmark-summary-region) (define-key map "MV" 'vm-toggle-all-marks) (define-key map "MX" 'vm-mark-matching-messages-with-virtual-folder) (define-key map "Mx" 'vm-unmark-matching-messages-with-virtual-folder) (define-key map "M?" 'vm-mark-help) (define-key map "W" (make-sparse-keymap)) (define-key map "WW" 'vm-apply-window-configuration) (define-key map "WS" 'vm-save-window-configuration) (define-key map "WD" 'vm-delete-window-configuration) (define-key map "W?" 'vm-window-help) (define-key map "\C-t" 'vm-toggle-threads-display) (define-key map "\M-t" 'vm-summary-toggle-thread-folding) (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-change-folder-type) (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-mime-save-all-attachments) (define-key map "\C-c\C-d" 'vm-mime-delete-all-attachments) ;; 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"))) map ) "Keymap for VM mode.") (defvar vm-summary-toggle-thread-folding nil "Enables folding of threads in VM summary windows. (This functionality is highly experimental!)") (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-mime-attach-file) (define-key map "\C-c\C-b" 'vm-mime-attach-buffer) (define-key map "\C-c\C-m" 'vm-mime-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) (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 "$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-attach-object-from-message) (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.") ;; for sixth arg of read-file-name in early version of Emacs 21. (defun vm-folder-history (&rest ignored) t) ;; internal vars (defvar vm-folder-type nil) (make-variable-buffer-local 'vm-folder-type) (defvar vm-folder-access-method nil) (make-variable-buffer-local 'vm-folder-access-method) (defvar vm-folder-access-data nil) (make-variable-buffer-local 'vm-folder-access-data) (defvar vm-message-list nil) (make-variable-buffer-local 'vm-message-list) (defvar vm-virtual-folder-definition nil) (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-message-pointer nil) (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) (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) (make-variable-buffer-local 'vm-mail-buffer) (defvar vm-presentation-buffer nil) (make-variable-buffer-local 'vm-presentation-buffer) (defvar vm-presentation-buffer-handle nil) (make-variable-buffer-local 'vm-presentation-buffer-handle) (defvar vm-mime-decoded nil) (make-variable-buffer-local 'vm-mime-decoded) (defvar vm-summary-buffer nil) (make-variable-buffer-local 'vm-summary-buffer) (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) (make-variable-buffer-local 'vm-undo-record-list) (defvar vm-saved-undo-record-list nil) (make-variable-buffer-local 'vm-saved-undo-record-list) (defvar vm-undo-record-pointer nil) (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) (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) (defvar vm-buffers-needing-undo-boundaries nil) (defvar vm-numbering-redo-start-point nil) (make-variable-buffer-local 'vm-numbering-redo-start-point) (defvar vm-numbering-redo-end-point nil) (make-variable-buffer-local 'vm-numbering-redo-end-point) (defvar vm-summary-redo-start-point nil) (make-variable-buffer-local 'vm-summary-redo-start-point) (defvar vm-need-summary-pointer-update nil) (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-\\|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-all-headers") ("vm-forward-message-all-headers-other-frame") ("vm-forward-message-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-mime-attach-buffer") ("vm-mime-attach-file") ("vm-mime-attach-message") ("vm-mime-attach-mime-file") ("vm-mime-attach-object-from-message") ("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-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-unread-message") ("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") )) (defcustom vm-vs-attachment-regexp "^Content-Disposition: attachment" "Regexp used to detect attachments in a message." :group 'vm :type 'regexp) (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 :type 'file) (defcustom vm-vs-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)) "A list of headers to look for spam scores." :group 'vm :type '(repeat (list (string :tag "Header regexp") (regexp :tag "Regexp matching the score") (function :tag "Function converting the score to a number")))) (defconst vm-supported-sort-keys '("date" "reversed-date" "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") ("virtual-folder-member") ("header") ("label") ("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") ("deleted") ("replied") ("forwarded") ("redistributed") ("filed") ("written") ("edited") ("marked") ("undeleted") ("unreplied") ("unforwarded") ("unredistributed") ("unfiled") ("unwritten") ("unedited") ("unmarked") ("spam-word") ("spam-score") )) (defconst vm-virtual-selector-function-alist '((any . vm-vs-any) (virtual-folder-member . vm-vs-virtual-folder-member) (and . vm-vs-and) (or . vm-vs-or) (not . vm-vs-not) (header . vm-vs-header) (label . vm-vs-label) (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) (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) )) (defconst vm-supported-attribute-names '("new" "unread" "read" "deleted" "replied" "forwarded" "redistributed" "filed" "written" "edited" "undeleted" "unreplied" "unforwarded" "unredistributed" "unfiled" "unwritten" "unedited" ;; for babyl cogniscenti "recent" "unseen" "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-attributes-vector-length 9) (defconst vm-cache-vector-length 26) (defconst vm-softdata-vector-length 20) (defconst vm-location-data-vector-length 6) (defconst vm-mirror-data-vector-length 6) (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 (defvar 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 "%-")) (defvar vm-mode-line-format-classic '("" " %&%& " ("VM " vm-version ": " (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)) (defvar vm-mode-line-format vm-mode-line-format-classic) (defvar 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) ;; 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) (defvar vm-imap-ok-to-ask nil) (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) ;; list of messages to be expunged on the server during the next save (defvar vm-imap-messages-to-expunge nil) (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 (defvar vm-pop-keep-failed-trace-buffers 5) (defvar vm-imap-keep-failed-trace-buffers 5) ;; Lists of trace buffers remembered for debugging purposes (defvar vm-kept-pop-buffers nil) (make-variable-buffer-local 'vm-kept-pop-buffers) (defvar vm-kept-imap-buffers nil) (make-variable-buffer-local 'vm-kept-imap-buffers) ;; Flag to make POP/IMAP code remember old trace buffers (defvar vm-pop-keep-trace-buffer nil) (defvar vm-imap-keep-trace-buffer nil) (defvar vm-imap-session-done nil) (defvar vm-reply-list nil) (defvar vm-forward-list nil) (defvar vm-redistribute-list nil) ;; 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)) ;; For verification of imap 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) (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 (defvar highlight-headers-regexp "Subject[ \t]*:") (defvar 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) (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) (defvar vm-mime-default-action-string-alist '(("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"))) (defvar 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") ("image/gif" . "GIF image") ("image/tiff" . "TIFF image") ("image/jpeg" . "JPEG image") ("image/png" . "PNG image") ("message/rfc822" . "mail message") ("message/news" . "USENET news article") ("message/partial" . "message fragment") ("message/external-body" . "external object") ("application/postscript" . "PostScript") ("application/msword" . "Word document") ("application/vnd.ms-excel" . "Excel spreadsheet") ("application/octet-stream" . "untyped binary 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) (make-variable-buffer-local 'vm-message-garbage-alist) (defvar vm-folder-garbage-alist nil) (make-variable-buffer-local 'vm-folder-garbage-alist) (defvar vm-global-garbage-alist nil) (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-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.") (defvar 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.") (defvar 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.") (defconst vm-mime-charset-completion-alist '( ("us-ascii") ("iso-8859-1") ("iso-8859-2") ("iso-8859-3") ("iso-8859-4") ("iso-8859-5") ("iso-8859-6") ("iso-8859-7") ("iso-8859-8") ("iso-8859-9") ("iso-2022-jp") ("iso-2022-jp-2") ("iso-2022-int-1") ("iso-2022-kr") )) (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 :type '(set (const :tag "Enable faces in the summary buffer" summary-faces) (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-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 :type '(repeat symbol)) (defcustom vm-mail-mode-hidden-headers '("References" "In-Reply-To" "X-Mailer") "*A list of header 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")))) (provide 'vm-vars) ;;; vm-vars.el ends here vm-8.1.2/lisp/vm-undo.el0000644000175000017500000005126011725175471015312 0ustar srivastasrivasta;;; vm-undo.el --- Commands to undo message attribute changes in 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: (defun vm-set-buffer-modified-p (flag &optional buffer) (save-excursion (and buffer (set-buffer buffer)) (set-buffer-modified-p flag) (vm-increment vm-modification-counter) (intern (buffer-name) vm-buffers-needing-display-update) (if (null flag) (setq vm-messages-not-on-disk 0)))) (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))) (if b (progn (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 (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 (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 (message "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)) (message "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-preview-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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-display nil nil '(vm-undo) '(vm-undo)) (let ((modified (buffer-modified-p))) (if (not (eq last-command 'vm-undo)) (setq vm-undo-record-pointer vm-undo-record-list)) (if (not 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))) (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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (vm-display nil nil '(vm-set-message-attributes) '(vm-set-message-attributes)) (let ((name-list (vm-parse string "[ \t]*\\([^ \t]+\\)")) (m-list (vm-select-marked-or-prefixed-messages count)) 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. (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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (vm-add-or-delete-message-labels string count 'all)) ;;;###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. (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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (let ((ignored-labels (vm-add-or-delete-message-labels string count '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. (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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (vm-add-or-delete-message-labels string count nil)) (defun vm-add-or-delete-message-labels (string count add) (vm-display nil nil '(vm-add-message-labels vm-delete-message-labels) (list this-command)) (setq string (downcase string)) (let ((m-list (vm-select-marked-or-prefixed-messages count)) (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) (if (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)))) (if (null action-labels) (setq m-list nil)) (while m-list (setq m (car m-list)) (if (and add (vm-virtual-message-p m)) (let ((labels action-labels)) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of m))) (while labels (intern (car labels) vm-label-obarray) (setq labels (cdr labels)))))) (if add (save-excursion (setq mm-list (vm-virtual-messages-of m)) (while mm-list (let ((labels action-labels)) (set-buffer (vm-buffer-of (car mm-list))) (while labels (intern (car labels) vm-label-obarray) (setq labels (cdr labels)))) (setq mm-list (cdr mm-list))))) (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)))) (if 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) (let ((m-list nil) vmp) (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))) ;; do nothing it is is already set (not (eq flag (aref (vm-attributes-of m) attr-index)))) (cond ((not norecord) (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m))) (while vmp (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp))) (setq m-list (cons (car vmp) m-list))) (setq vmp (cdr vmp))) (if (null m-list) (setq m-list (cons m m-list))) (while m-list (save-excursion (set-buffer (vm-buffer-of (car m-list))) (cond ((not (buffer-modified-p)) (vm-set-buffer-modified-p t) (vm-undo-record (list 'vm-set-buffer-modified-p nil)))) (vm-undo-record (list function (car m-list) (not flag))) ;;; (vm-undo-boundary) (vm-increment vm-modification-counter)) (setq m-list (cdr m-list))))) (aset (vm-attributes-of m) attr-index flag) (vm-mark-for-summary-update m) (if (not norecord) (progn (vm-set-attribute-modflag-of m t) (if (eq vm-flush-interval t) (vm-stuff-virtual-attributes m) (vm-set-stuff-flag-of m t)))))))) (defun vm-set-labels (m labels) (let ((m-list nil) (old-labels (vm-labels-of m)) vmp) (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)))) (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m))) (while vmp (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp))) (setq m-list (cons (car vmp) m-list))) (setq vmp (cdr vmp))) (if (null m-list) (setq m-list (cons m m-list))) (while m-list (save-excursion (set-buffer (vm-buffer-of (car m-list))) (cond ((not (buffer-modified-p)) (vm-set-buffer-modified-p t) (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)) (setq m-list (cdr m-list))) (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-attributes m) (vm-set-stuff-flag-of m t)))))) (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)) ;; 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)) ;; this is solely for the use of vm-stuff-attributes 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)) (provide 'vm-undo) ;;; vm-undo.el ends here vm-8.1.2/lisp/vm-save.el0000644000175000017500000011310011725175471015273 0ustar srivastasrivasta;;; vm-save.el --- Saving and piping messages under 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: ;;;###autoload (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)) ;;;###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)) ", ")) (if (null header) () (setq tuple-list (cdr (car 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-auto-select-folder mp result))) (if 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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (message "Archiving...") (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-marked-or-prefixed-messages 0) vm-message-list)) (done nil) stop-point (vm-last-save-folder vm-last-save-folder) (vm-move-after-deleting nil)) ;; 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) (vm-increment archived) (message "%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) (message "No messages were archived") (message "%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-excursion (vm-select-folder-buffer) (eq vm-folder-access-method 'imap))) ;;;--------------------------------------------------------------------------- ;; New shell defun to handle both IMAP and local saving. ;;--------------------------------------------------------------------------- ;;;###autoload (defun vm-save-message (folder &optional count) "Save the current message. This may be done either by saving it to an IMAP folder or by saving it to a local filesystem folder. Which is done is controlled by the type of the current vm-folder buffer and the variable `vm-imap-save-to-server'." (interactive (if (and vm-imap-save-to-server (vm-imap-folder-p)) ;; IMAP saving --- argument parsing taken from ;; vm-save-message-to-imap-folder (let ((this-command this-command) (last-command last-command)) (vm-follow-summary-cursor) (save-excursion (vm-session-initialization) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (list (vm-read-imap-folder-name "Save to IMAP folder: " t) (prefix-numeric-value current-prefix-arg)))) ;; saving to local filesystem. argument parsing taken from old ;; vm-save-message (now vm-save-message-to-local-folder) (list ;; protect value of last-command (let ((last-command last-command) (this-command this-command)) (vm-follow-summary-cursor) (let ((default (save-excursion (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (or (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist) 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)) (default (vm-read-file-name (format "Save in folder: (default %s) " default) dir default)) (t (vm-read-file-name "Save in folder: " dir nil))))) (prefix-numeric-value current-prefix-arg)))) (cond ((and vm-imap-save-to-server (vm-imap-folder-p)) (vm-save-message-to-imap-folder folder count)) ((and (stringp vm-recognize-imap-maildrops) (string-match vm-recognize-imap-maildrops folder)) (vm-save-message-to-imap-folder folder count)) (t (vm-save-message-to-local-folder folder count)))) ;;;###autoload (defun vm-save-message-to-local-folder (folder &optional count) "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. 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) (let ((default (save-excursion (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (or (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist) 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)) (default (vm-read-file-name (format "Save in folder: (default %s) " default) dir default)) (t (vm-read-file-name "Save in folder: " dir nil))))) (prefix-numeric-value current-prefix-arg))) (let (auto-folder unexpanded-folder) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (setq unexpanded-folder folder auto-folder (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)) (vm-display nil nil '(vm-save-message) '(vm-save-message)) (or count (setq count 1)) ;; Expand the filename, forcing relative paths to resolve ;; into the folder directory. (let ((default-directory (expand-file-name (or vm-folder-directory default-directory)))) (setq folder (expand-file-name folder))) ;; Confirm new folders, if the user requested this. (if (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. (if (and (not vm-visit-when-saving) (vm-get-file-buffer folder)) (error "Folder %s is being visited, cannot save." folder)) (let ((mlist (vm-select-marked-or-prefixed-messages count)) (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) (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)))) (if (and mlist vm-check-folder-types) (progn (setq target-type (or (vm-get-folder-type folder) vm-default-folder-type (and mlist (vm-message-type-of (car mlist))))) (if (eq target-type 'unknown) (error "Folder %s's type is unrecognized" folder)))) (unwind-protect (save-excursion (and 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. (if mlist (let ((attrs (file-attributes folder))) (if (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)))))) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of m) (error "Message %s body has not been retrieved" (vm-number-of (car mlist)))) (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-attributes m t) (if (null folder-buffer) (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 mlist))) (error "Folder type mismatch: %s, %s" (vm-message-type-of m) target-type) (error "Message %s type mismatches folder %s: %s, %s" (vm-number-of (car mlist)) 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)))) (save-excursion (set-buffer folder-buffer) ;; if the buffer is a live VM folder ;; honor vm-folder-read-only. (if 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 mlist))) (error "Folder type mismatch: %s, %s" (vm-message-type-of m) target-type) (error "Message %s type mismatches folder %s: %s, %s" (vm-number-of (car mlist)) folder (vm-message-type-of m) target-type)) (vm-write-string (current-buffer) (vm-leading-message-separator target-type m t)) (if (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))))))) (if (null (vm-filed-flag m)) (vm-set-filed-flag m t)) (vm-increment count) (vm-modify-folder-totals folder 'saved 1 m) (vm-update-summary-and-mode-line) (setq mlist (cdr mlist))))) (and oldmodebits (set-default-file-modes oldmodebits))) (if m (if folder-buffer (progn (save-excursion (set-buffer folder-buffer) (if (eq major-mode 'vm-mode) (progn (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-preview-current-message)) (vm-update-summary-and-mode-line))))) (message "%d message%s saved to buffer %s" count (if (/= 1 count) "s" "") (buffer-name folder-buffer))) (message "%d message%s saved to %s" count (if (/= 1 count) "s" "") folder)))) (if (or (null vm-last-save-folder) (not (equal unexpanded-folder auto-folder))) (setq vm-last-save-folder unexpanded-folder)) (if (and vm-delete-after-saving (not vm-folder-read-only)) (vm-delete-message count)) folder )) ;;;###autoload (defun vm-save-message-sans-headers (file &optional count) "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. 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)) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-display nil nil '(vm-save-message-sans-headers) '(vm-save-message-sans-headers)) (or count (setq count 1)) (setq file (expand-file-name file)) ;; Check and see if we are currently visiting the file ;; that the user wants to save to. (if (and (not vm-visit-when-saving) (vm-get-file-buffer file)) (error "File %s is being visited, cannot save." file)) (let ((mlist (vm-select-marked-or-prefixed-messages count)) (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)))) (if (and (not (memq (vm-get-folder-type file) '(nil unknown))) (not (y-or-n-p "This file looks like a mail folder, append to it anyway? "))) (error "Aborted")) (unwind-protect (save-excursion (and 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 try to load the body before saving (if (vm-body-to-be-retrieved-of m) (error "Message %s body has not been retrieved" (vm-number-of (car mlist)))) (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)))))))) (if (null (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))) (if m (if file-buffer (message "Message%s written to buffer %s" (if (/= 1 count) "s" "") (buffer-name file-buffer)) (message "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) (message "Command '%s' produced no output." command) (if discard-output (message "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. 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)) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-windows t))) ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-marked-or-prefixed-messages if we're using marks. (mlist (if (eq last-command 'vm-next-command-uses-marks) (vm-select-marked-or-prefixed-messages 0) (list (car vm-message-pointer))))) (save-excursion (set-buffer buffer) (erase-buffer)) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of m) (error "Message %s body has not been retrieved" (vm-number-of (car mlist)))) (save-restriction (widen) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows 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)) (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)) (message "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)) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (setq vm-last-pipe-command command) (let ((buffer (get-buffer-create "*Shell Command Output*")) (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-marked-or-prefixed-messages if we're using marks. (mlist (if (eq last-command 'vm-next-command-uses-marks) (vm-select-marked-or-prefixed-messages 0) (list (car vm-message-pointer)))) m process) (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))) (message "Command '%s' changed state to %s." ,command status)))) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of m) (error "Message %s body has not been retrieved" (vm-number-of (car mlist)))) (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)) (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)) (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. Output, if any, is displayed. The message is not altered." (interactive "p") (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-windows t))) (mlist (vm-select-marked-or-prefixed-messages count))) (save-excursion (set-buffer buffer) (erase-buffer)) (while mlist (setq m (vm-real-message-of (car mlist))) (set-buffer (vm-buffer-of m)) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of m) (error "Message %s body has not been retrieved" (vm-number-of (car mlist)))) (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-auto-displayed-mime-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-windows 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-windows 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 (target-folder &optional count) "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. The saved messages are flagged as `filed'." (interactive (let ((this-command this-command) (last-command last-command)) (vm-follow-summary-cursor) (save-excursion (vm-session-initialization) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (list (vm-read-imap-folder-name "Save to IMAP folder: " t nil (or vm-last-save-imap-folder vm-last-visit-imap-folder)) (prefix-numeric-value current-prefix-arg))))) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-display nil nil '(vm-save-message-to-imap-folder) '(vm-save-message-to-imap-folder)) (or count (setq count 1)) (let (source-spec-list (target-spec-list (vm-imap-parse-spec-to-list target-folder)) (mlist (vm-select-marked-or-prefixed-messages count)) (count 0) server-to-server-p mailbox m process ) (setq mailbox (nth 3 target-spec-list)) (unwind-protect (save-excursion (message "Saving messages...") (while mlist (setq m (vm-real-message-of (car mlist))) (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 mlist)))) ;; 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-attributes m t) (if server-to-server-p ; economise on upstream data traffic (let ((process (vm-re-establish-folder-imap-session))) (vm-imap-copy-message process m mailbox)) (unless process (setq process (vm-imap-make-session target-folder))) (vm-imap-save-message process m mailbox)) (unless (vm-filed-flag m) (vm-set-filed-flag m t)) ;; 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-increment count) (message "Saving messages... %s" count) (vm-modify-folder-totals target-folder 'saved 1 m) (setq mlist (cdr mlist)))) (when process (vm-imap-end-session process))) (vm-update-summary-and-mode-line) (setq vm-last-save-imap-folder target-folder) (if (and vm-delete-after-saving (not vm-folder-read-only)) (vm-delete-message count)) (message "%d message%s saved to %s" count (if (/= 1 count) "s" "") (vm-safe-imapdrop-string target-folder)) target-folder )) (provide 'vm-save) ;;; vm-save.el ends here vm-8.1.2/lisp/vm-pop.el0000644000175000017500000012713011725175471015143 0ustar srivastasrivasta;;; vm-pop.el --- Simple POP (RFC 1939) client for 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: (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")) (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)) (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 (and (fboundp 'find-file-name-handler) (condition-case () (find-file-name-handler source 'vm-pop-move-mail) (wrong-number-of-arguments (find-file-name-handler source))))) (popdrop (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)) (t (if vm-pop-expunge-after-retrieving t (message (concat "Leaving messages on POP server; " "See info under \"POP Spool Files\"")) (sit-for 4) 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) (if (member msgid pop-retrieved-messages) (progn (if vm-pop-ok-to-ask (message "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 (message "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 (message "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 (message "Skipping message %d..." n) (message "Skipping message %d in %s, too large (%d > %d)..." n popdrop message-size vm-pop-max-message-size))) (throw 'skip t))) (message "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)))) (message "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 (and (fboundp 'find-file-name-handler) (condition-case () (find-file-name-handler source 'vm-pop-check-mail) (wrong-number-of-arguments (find-file-name-handler source))))) (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) (vm-check-for-killed-summary) (vm-error-if-virtual-folder) (if (and (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 (vm-safe-popdrop-string source)) (condition-case nil (progn (message "Opening POP session to %s..." popdrop) (setq process (vm-pop-make-session source)) (if (null process) (signal 'error nil)) (message "Expunging messages in %s..." popdrop)) (error (message "Couldn't open POP session to %s, skipping..." popdrop) (setq trouble (cons popdrop trouble)) (sleep-for 2) (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 (message "DELE %s failed on %s, skipping rest of mailbox..." (car match) popdrop) (setq trouble (cons popdrop trouble)) (sleep-for 2) (while (equal (nth 1 (car mp)) source) (setq mp (cdr mp))) (throw 'replay t)) (vm-uidl-failed (message "UIDL %s failed on %s, skipping this mailbox..." (car match) popdrop) (setq trouble (cons popdrop trouble)) (sleep-for 2) (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))) (message "%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 (folder-type vm-folder-type) (popdrop (vm-safe-popdrop-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 "POP") (process-connection-type nil) greeting timestamp ssh-process host port auth user pass 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. (if (= 6 (length source-list)) (progn (cond ((equal "pop-ssl" (car source-list)) (setq use-ssl t session-name "POP over SSL") (if (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") (if (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 (if (null host) (error "No host in POP maildrop specification, \"%s\"" source)) (if (null port) (error "No port in POP maildrop specification, \"%s\"" source)) (if (string-match "^[0-9]+$" port) (setq port (string-to-number port))) (if (null auth) (error "No authentication method in POP maildrop specification, \"%s\"" source)) (if (null user) (error "No user in POP maildrop specification, \"%s\"" source)) (if (null pass) (error "No password in POP maildrop specification, \"%s\"" source)) (if (equal pass "*") (progn (setq pass (car (cdr (assoc source-nopwd vm-pop-passwords)))) (if (null pass) (if (null vm-pop-ok-to-ask) (progn (message "Need password for %s" popdrop) (throw 'done nil)) (setq pass (read-passwd (format "POP password for %s: " popdrop))))))) ;; save the password for the sake of ;; vm-expunge-pop-messages, which passes password-less ;; popdrop specifications to vm-make-pop-session. (if (null (assoc source-nopwd vm-pop-passwords)) (setq vm-pop-passwords (cons (list source-nopwd pass) vm-pop-passwords))) ;; get the trace buffer (setq process-buffer (vm-make-work-buffer (format "trace of %s session to %s" 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. (if (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 (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) (if (null (setq greeting (vm-pop-read-response process t))) (progn (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)) (if (null (vm-pop-read-response process)) (progn (setq vm-pop-passwords (delete (list source-nopwd pass) vm-pop-passwords)) (message "POP password for %s incorrect" popdrop) ;; don't sleep unless we're running synchronously. (if vm-pop-ok-to-ask (sleep-for 2)) (throw 'done nil)))) ((equal auth "rpop") (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 "RPOP %s" pass)) (and (null (vm-pop-read-response process)) (throw 'done nil))) ((equal auth "apop") (setq timestamp (vm-parse greeting "[^<]+\\(<[^>]+>\\)") timestamp (car timestamp)) (if (null timestamp) (progn (goto-char (point-max)) (insert-before-markers "<<< ooops, no timestamp found in greeting! >>>\n") (message "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)))) (if (null (vm-pop-read-response process)) (progn (setq vm-pop-passwords (delete (list source-nopwd pass) vm-pop-passwords)) (message "POP password for %s incorrect" popdrop) (if vm-pop-ok-to-ask (sleep-for 2)) (throw 'done nil)))) (t (error "Don't know how to authenticate using %s" auth))) (setq process-to-shutdown nil) process )) (if process-to-shutdown (vm-pop-end-session process-to-shutdown t)) (vm-tear-down-stunnel-random-data)))) (defun vm-pop-end-session (process &optional keep-buffer verbose) (if (and (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 (message "Waiting for response to POP QUIT command...")) (vm-pop-read-response process) (and verbose (message "Waiting for response to POP QUIT command... done")))))) (if (and (not keep-buffer) (not vm-pop-keep-trace-buffer)) (if (buffer-live-p (process-buffer process)) (kill-buffer (process-buffer process))) (save-excursion (set-buffer (process-buffer process)) (rename-buffer (concat "saved " (buffer-name)) t) (vm-keep-some-buffers (current-buffer) 'vm-kept-pop-buffers vm-pop-keep-failed-trace-buffers))) (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) (message "")) (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 (message "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 vm-visible-headers 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 interactive do-remote-expunges do-local-expunges do-retrieves) (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 (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 (message "Retrieval from %s signaled: %s" safe-popdrop error-data)) (quit (message "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 t)) (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 t t 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-for-mail (&optional interactive) (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 ))) ;;;###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) (setq vm-kept-pop-buffers nil) (setq vm-pop-keep-trace-buffer t) (setq vm-pop-keep-failed-trace-buffers 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) (if (or vm-pop-keep-trace-buffer (y-or-n-p "Did you run vm-pop-start-bug-report earlier? ")) (message "Thank you. Preparing the bug report... ") (message "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 m nil) (vm-set-body-to-be-retrieved m nil)) (provide 'vm-pop) ;;; vm-pop.el ends here vm-8.1.2/lisp/vm-macro.el0000644000175000017500000001104711725175471015445 0ustar srivastasrivasta;;; vm-macro.el --- Random VM macros ;; ;; 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: (defsubst vm-marker (pos &optional buffer) (set-marker (make-marker) pos buffer)) (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 ;; (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 ;; (vm-buffer-type:set 'folder) ;;-------------------------- ) (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-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))) (provide 'vm-macro) ;;; vm-macro.el ends here vm-8.1.2/lisp/vm-delete.el0000644000175000017500000004105511725175471015610 0ustar srivastasrivasta;;; vm-delete.el --- Delete and expunge commands for 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: ;;;###autoload (defun vm-delete-message (count) "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." (interactive "p") (if (interactive-p) (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 ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist (vm-select-marked-or-prefixed-messages count)) (del-count 0)) (while mlist (if (not (vm-deleted-flag (car mlist))) (progn (vm-set-deleted-flag (car mlist) t) (vm-increment del-count))) (setq mlist (cdr mlist))) (vm-display nil nil '(vm-delete-message vm-delete-message-backward) (list this-command)) (if (and used-marks (interactive-p)) (if (zerop del-count) (message "No messages deleted") (message "%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 (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." (interactive "p") (if (interactive-p) (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 ((used-marks (eq last-command 'vm-next-command-uses-marks)) (mlist (vm-select-marked-or-prefixed-messages count)) (undel-count 0)) (while mlist (if (vm-deleted-flag (car mlist)) (progn (vm-set-deleted-flag (car mlist) nil) (vm-increment undel-count))) (setq mlist (cdr mlist))) (if (and used-marks (interactive-p)) (if (zerop undel-count) (message "No messages undeleted") (message "%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-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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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)))) (progn (vm-set-deleted-flag (car mp) t) (vm-increment n))) (setq mp (cdr mp))) (and (interactive-p) (if (zerop n) (message "No messages deleted.") (message "%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-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 hashed or considerd for deletion." (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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 (setq mp (vm-select-marked-or-prefixed-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) (vm-set-deleted-flag (car mp) t) (setq n (1+ n))) (intern mid table)))) (setq mp (cdr mp))) (and (interactive-p) (message "%d duplicate%s marked deleted" n (if (= n 1) "" "s"))) (vm-update-summary-and-mode-line) (when vm-move-after-killing (let ((vm-circular-folders (and vm-circular-folders (eq vm-move-after-killing t)))) (vm-next-message 1 t executing-kbd-macro))) 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 ofeach non-deleted message in the folder and deleting messages that have a hash that has already been seen. Messages that 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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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)) (if used-marks (setq mlist (vm-select-marked-or-prefixed-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) (progn (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)) (if (zerop del-count) (message "No messages deleted") (message "%d message%s deleted" del-count (if (= 1 del-count) "" "s"))) (vm-update-summary-and-mode-line))) ;;;###autoload (defun vm-expunge-folder (&optional shaddap just-these-messages messages-to-expunge) "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) (vm-check-for-killed-summary) (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) (if (not shaddap) (message "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) messages-to-expunge) (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 (vm-real-message-of (car mp)))) ;; 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))) (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-set-buffer-modified-p t))) (setq vms (cdr vms)))))) (cond ((or (not virtual-messages) (not virtual)) (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-set-buffer-modified-p t) (vm-increment vm-modification-counter)))) (if (eq (vm-attributes-of (car mp)) (vm-attributes-of (vm-real-message-of (car mp)))) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) (cond ((eq vm-folder-access-method 'pop) (setq vm-pop-messages-to-expunge (cons (vm-pop-uidl-of (vm-real-message-of (car mp))) 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 (vm-real-message-of (car mp))) (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 (vm-real-message-of (car mp))) (vm-imap-uid-validity-of (vm-real-message-of (car mp)))) 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. vm-imap-retrieved-messages (cons (list (vm-imap-uid-of (vm-real-message-of (car mp))) (vm-imap-uid-validity-of (vm-real-message-of (car mp))) (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 (vm-real-message-of (car mp))) (vm-end-of (vm-real-message-of (car mp))))))))) (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)) (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-preview-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)) (if (not shaddap) (message "Deleted messages expunged."))) (t (message "No messages are flagged for deletion."))))) (provide 'vm-delete) ;;; vm-delete.el ends here vm-8.1.2/lisp/vm-window.el0000644000175000017500000006226511725175471015663 0ustar srivastasrivasta;;; vm-window.el --- Window management code for 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: (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-windows t)) (pop-up-frames (and pop-up-frames vm-mutable-frames))) (if (or pop-up-frames (and (eq vm-mutable-windows 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-frames (and vm-mutable-frames 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-windows) (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-windows 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) (message "%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) (message "%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) (message "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-check-for-killed-summary) (vm-select-folder-buffer) (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-windows t) (vm-window-loop 'delete buffer)) (and vm-mutable-frames (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-get-buffer-window (buffer) (condition-case nil (or (get-buffer-window buffer nil nil) (and vm-search-other-frames (get-buffer-window buffer t t))) (wrong-number-of-arguments (condition-case nil (or (get-buffer-window buffer nil) (and vm-search-other-frames (get-buffer-window buffer t))) (wrong-number-of-arguments (get-buffer-window buffer)))))) (defun vm-get-visible-buffer-window (buffer) (condition-case nil (or (get-buffer-window buffer nil nil) (and vm-search-other-frames (get-buffer-window buffer t nil))) (wrong-number-of-arguments (condition-case nil (or (get-buffer-window buffer nil) (and vm-search-other-frames (get-buffer-window buffer 'visible))) (wrong-number-of-arguments (get-buffer-window buffer)))))) (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-frames 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) (select-frame (make-frame params))) ((fboundp 'make-screen) (select-screen (make-screen params))) ((fboundp 'new-screen) (select-screen (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-frames 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-frames 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-frames 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 (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 ;; 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 (unfocus-frame))))))) (fset 'vm-selected-frame (symbol-function (cond ((fboundp 'selected-frame) 'selected-frame) ((fboundp 'selected-screen) 'selected-screen) (t 'ignore)))) (fset 'vm-delete-frame (symbol-function (cond ((fboundp 'delete-frame) 'delete-frame) ((fboundp 'delete-screen) 'delete-screen) (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) (iconify-screen (or frame (selected-screen)))))) (fset 'vm-raise-frame (symbol-function (cond ((fboundp 'raise-frame) 'raise-frame) ((fboundp 'raise-screen) 'raise-screen) (t 'ignore)))) (fset 'vm-frame-visible-p (symbol-function (cond ((fboundp 'frame-visible-p) 'frame-visible-p) ((fboundp 'screen-visible-p) 'screen-visible-p) (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))) (provide 'vm-window) ;;; vm-window.el ends here vm-8.1.2/lisp/u-vm-color.el0000644000175000017500000007030611725175471015727 0ustar srivastasrivasta;;; u-vm-color.el --- Font-lock support 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 $ (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-summary-mode-hook 'u-vm-color-summary-mode) ;; (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-decode-mime-message (after u-vm-color activate) ;; (u-vm-color-fontify-buffer-even-more)) ;; If you are using auto-fill, ie when the variable ;; `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: ;; 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) (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)))) (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-has-been-modified-before (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))) (set-buffer-modified-p buffer-has-been-modified-before))) ;;;###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))) (provide 'u-vm-color) ;;; u-vm-color.el ends here vm-8.1.2/lisp/vm-reply.el0000644000175000017500000021167111725175471015504 0ustar srivastasrivasta;;; vm-reply.el --- Mailing, forwarding, and replying commands ;; ;; 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: (defun vm-add-reply-subject-prefix (message &optional start) (when (not start) (goto-char (point-min)) (re-search-forward (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 (regexp-quote mail-header-separator) (point-max)) (forward-line 1) (point)) (point-max)))) ;;;###autoload (defun vm-do-reply (to-all include-text count) (let ((mlist (vm-select-marked-or-prefixed-messages count)) (dir default-directory) (message-pointer vm-message-pointer) (case-fold-search t) to cc subject in-reply-to references mp tmp tmp2 newsgroups) (setq mp mlist) (while mp (cond ((add-to-list 'to (let ((reply-to (vm-get-header-contents (car mp) "Reply-To:" ", "))) (if (vm-ignored-reply-to reply-to) nil reply-to )))) ((add-to-list 'to (vm-get-header-contents (car mp) "From:" ", "))) ;; bad, but better than nothing for some ((add-to-list 'to (vm-grok-From_-author (car mp)))) (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))) (cond ((setq tmp (vm-get-header-contents (car mp) "Reply-To:" ", ")) (if (not (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"))) (if to-all (progn (setq tmp (vm-get-header-contents (car mp) "To:" ", ")) (setq tmp2 (vm-get-header-contents (car mp) "Cc:" ", ")) (if tmp (if cc (setq cc (concat cc "," tmp)) (setq cc tmp))) (if 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))) (if (null to) nil (setq tmp (car to)) (setq to (cdr to)) (while to (setq tmp (concat tmp ", " (car to))) (setq to (cdr to))) (setq to tmp)) (if 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)) (if 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)) (and to (setq to (mapconcat 'identity to ",\n "))) (and cc (setq cc (mapconcat 'identity cc ",\n "))) (and (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 (format "reply to %s%s" (vm-su-full-name (car mlist)) (if (cdr mlist) ", ..." "")) to subject in-reply-to cc references newsgroups) (make-local-variable 'vm-reply-list) (setq vm-system-state 'replying vm-reply-list mlist default-directory dir) (if 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))))) (if 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 (if (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 vm-included-text-headers vm-included-text-discard-header-regexp) ;; if all the headers are gone, delete the trailing blank line, too. (if (eq (following-char) ?\n) (delete-char 1)) (if (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)) (if (not (eq major-mode 'vm-mode)) (vm-mode)) (if vm-presentation-buffer-handle (vm-bury-buffer vm-presentation-buffer-handle)) (if (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))) (if (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-excursion (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))) (if (null (setq mp (nthcdr (1- result) vm-message-list))) (error "No such message."))) (car mp)))) (if (not (bufferp vm-mail-buffer)) (error "This is not a VM Mail mode buffer.")) (if (null (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)) (setq message (vm-real-message-of message)) (let ((layout (vm-mm-layout message)) (start (point)) (end (point-marker))) (save-excursion (cond ((or (and vm-include-text-from-presentation (not (vm-mime-plain-message-p message))) (vm-body-to-be-retrieved-of message)) (vm-yank-message-presentation message) (setq end (point-marker))) ((null vm-included-mime-types-list) (vm-yank-message-mime message layout) (setq end (point-marker))) (t (vm-yank-message-text message layout) (setq end (point-marker))) ) ;; decode MIME encoded words so supercite and other ;; mail-citation-hook denizens won't have to eat 'em. (if 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 (message) ;; 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) ;; ensure the current message is presented (vm-show-current-message) (vm-select-folder-buffer) (if vm-presentation-buffer (set-buffer vm-presentation-buffer)) (current-buffer))) (save-excursion (goto-char start) (if (looking-at "From ") (delete-region start (1+ (line-end-position))))))) (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)) (let ((vm-mime-alternative-select-method 'best-internal)) ; override 'all and 'best (vm-decode-mime-layout layout)) (if vm-mime-yank-attachments ;; FIXME This uses a function of vm-pine.el (vm-decode-postponed-mime-message))))) (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)) alternatives 0 parts (list layout)) (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/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) (setq res (vm-mime-display-internal-text/plain layout t))) ;; convert the layout if possible ((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)))) (if res ;; we have found a part to insert, thus skip the ;; remaining alternatives (while (> alternatives 1) (setq parts (cdr parts) alternatives (1- alternatives))) (if (not (member (downcase (car (vm-mm-layout-type layout))) vm-included-mime-types-list)) nil ;; 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 alternatives (1- alternatives)) (setq parts (cdr parts))) ;; burst composite types ((vm-mime-composite-type-p (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)))) ;; skip non-text 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) (if (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 () (if (not vm-mail-header-insert-message-id) nil (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:"))))) (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)) (if (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. (if (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:"))) (vm-mime-encode-composition)) (if vm-mail-reorder-message-headers (vm-reorder-message-headers nil vm-mail-header-order '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. (if (eq (current-buffer) composition-buffer) (progn (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-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (vm-do-reply t t count)) ;;;###autoload (defun vm-forward-message-all-headers () "Like vm-forward-message but always 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 () "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." (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (if (and (eq last-command 'vm-next-command-uses-marks) (cdr (vm-select-marked-or-prefixed-messages 0))) (let ((vm-digest-send-type vm-forwarding-digest-type)) (setq this-command 'vm-next-command-uses-marks) (command-execute 'vm-send-digest)) (let ((dir default-directory) (miming (and vm-send-using-mime (equal vm-forwarding-digest-type "mime"))) reply-buffer header-end (mp (vm-select-marked-or-prefixed-messages 1))) (save-restriction (widen) (vm-mail-internal (format "forward of %s's note re: %s" (vm-su-full-name (car vm-message-pointer)) (vm-su-subject (car vm-message-pointer))) nil (and vm-forwarding-subject-format (let ((vm-summary-uninteresting-senders nil)) (vm-summary-sprintf vm-forwarding-subject-format (car mp))))) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list (list (car mp)) default-directory dir) ;; current-buffer is now the reply buffer (if (vm-body-to-be-retrieved-of (car mp)) (error "Message %s body has not been retrieved" (vm-number-of (car mp)))) (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 ((equal vm-forwarding-digest-type "mime") (vm-mime-encapsulate-messages (list (car mp)) vm-forwarded-headers vm-unforwarded-header-regexp 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. (if vm-fsfemacs-mule-p (set-buffer-multibyte t))) ; is this safe? ((equal vm-forwarding-digest-type "rfc934") (vm-rfc934-encapsulate-messages vm-forward-list vm-forwarded-headers vm-unforwarded-header-regexp)) ((equal vm-forwarding-digest-type "rfc1153") (vm-rfc1153-encapsulate-messages vm-forward-list vm-forwarded-headers vm-unforwarded-header-regexp)) ((equal vm-forwarding-digest-type nil) (vm-no-frills-encapsulate-message (car vm-forward-list) vm-forwarded-headers vm-unforwarded-header-regexp))) (if miming (let ((b (current-buffer))) (set-buffer reply-buffer) (mail-text) (vm-mime-attach-object b "message/rfc822" nil "forwarded message" t) (add-hook 'kill-buffer-hook (list 'lambda () (list 'if (list 'eq reply-buffer '(current-buffer)) (list 'kill-buffer b)))))) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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)))) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of (car vm-message-pointer)) (error "Message %s body has not been retrieved" (vm-number-of (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 (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 nil "\\(X-VM-\\|Status:\\|Sender:\\)") (vm-reorder-message-headers nil vm-resend-bounced-headers 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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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)))) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of (car vm-message-pointer)) (error "Message %s body has not been retrieved" (vm-number-of (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 (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 nil "\\(X-VM-\\|Status:\\|Sender:\\)") (vm-reorder-message-headers nil vm-resend-headers 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) "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." (interactive "P") (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((dir default-directory) (miming (and vm-send-using-mime (equal vm-digest-send-type "mime"))) mp mail-buffer b ;; prefix arg doesn't have "normal" meaning here, so only call ;; vm-select-marked-or-prefixed-messages if we're using marks. (mlist (if (eq last-command 'vm-next-command-uses-marks) (vm-select-marked-or-prefixed-messages 0) vm-message-list)) ms start header-end boundary) ;; FIXME try to load the body before saving (setq ms mlist) (while ms (if (vm-body-to-be-retrieved-of (car ms)) (error "Message %s body has not been retrieved" (vm-number-of (car ms)))) (setq ms (cdr ms))) (save-restriction (widen) (vm-mail-internal (format "digest from %s" (buffer-name)) nil (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)))))))) (make-local-variable 'vm-forward-list) (setq vm-system-state 'forwarding vm-forward-list mlist default-directory dir) (if miming (progn (setq mail-buffer (current-buffer)) (set-buffer (vm-make-work-buffer "*vm-digest-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))) (message "Building %s digest..." vm-digest-send-type) (cond ((equal vm-digest-send-type "mime") (setq boundary (vm-mime-encapsulate-messages mlist vm-mime-digest-headers vm-mime-digest-discard-header-regexp 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) vm-forwarded-headers vm-unforwarded-header-regexp) (setq mlist (cdr mlist))))) (goto-char start) (setq mp mlist) (if miming (let ((b (current-buffer))) (set-buffer mail-buffer) (mail-text) (vm-mime-attach-object b "multipart/digest" (list (concat "boundary=\"" boundary "\"")) nil t) (add-hook 'kill-buffer-hook (list 'lambda () (list 'if (list 'eq mail-buffer '(current-buffer)) (list 'kill-buffer b)))))) (if prefix (save-excursion (message "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") (message "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-frames 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))) (message "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 nil to subject in-reply-to cc references 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))) ;; to quiet the v19 byte compiler (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.") (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)) ;;;###autoload (defun vm-mail-internal (&optional buffer-name 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)) (if (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-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. (if 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. (if (not 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)))) (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) (if (eq mail-aliases t) (progn (setq mail-aliases nil) (if (file-exists-p (or mail-personal-alias-file "~/.mailrc")) (build-mail-aliases))))) (if (stringp vm-mail-header-from) (insert "From: " vm-mail-header-from "\n")) (setq to (if to (vm-decode-mime-encoded-words-in-string 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 "") "\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"))) (if mail-default-reply-to (insert "Reply-To: " mail-default-reply-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")) (if mail-default-headers (insert mail-default-headers)) (if (not (= (preceding-char) ?\n)) (insert ?\n)) (insert mail-header-separator "\n") (if 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))))) ;; 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. (if (and vm-mutable-frames vm-frame-per-composition (vm-multiple-frames-possible-p)) (progn (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)) (if (null to) (mail-position-on-field "To")) (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") (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-reply count)) (if (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") (if (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)) (if (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") (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-followup count)) (if (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") (if (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)) (if (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) (if (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)) (if (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) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-forward-message)) (if (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) (if (vm-multiple-frames-possible-p) (vm-goto-new-frame 'composition)) (let ((vm-frame-per-composition nil) (vm-search-other-frames nil)) (vm-resend-message)) (if (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) (if (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)) (if (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") (if (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)) (if (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") (if (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)) (if (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") (if (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)) (if (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") (if (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)) (if (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) (if (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)) (or (vm-mail-mode-get-header-contents "From") (insert "From: " (user-login-name) "\n")) (or (vm-mail-mode-get-header-contents "Message-ID") (insert (format "Message-ID: \n" (random 1000000) (random 1000000)))) (or (vm-mail-mode-get-header-contents "Date") (insert "Date: " (format-time-string "%a, %d %b %Y %H%M%S %Z" (current-time)) "\n")) (and vm-send-using-mime (null (vm-mail-mode-get-header-contents "MIME-Version:")) (vm-mime-encode-composition)) (if vm-mail-reorder-message-headers (vm-reorder-message-headers nil vm-mail-header-order '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)) (if (not (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-auto-displayed-mime-content-types t)) (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode))) (message (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))) (and temp-buffer (kill-buffer temp-buffer))))) (defun vm-update-composition-buffer-name () (if (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)) (if (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"))) (if (equal newbufname curbufname) nil (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) (mapcar '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))))))) (defun vm-mail-mode-hide-headers-hook () "Hook which handles `vm-mail-mode-hidden-headers'." (if vm-mail-mode-hidden-headers (vm-mail-mode-hide-headers))) (add-hook 'vm-mail-mode-hook 'vm-mail-mode-hide-headers-hook) (provide 'vm-reply) ;;; vm-reply.el ends here vm-8.1.2/lisp/vm-sort.el0000644000175000017500000006101411725175471015332 0ustar srivastasrivasta;;; vm-sort.el --- Sorting and moving messages inside 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. ;;; Commentary: ;; ;;;###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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-set-buffer-modified-p t) (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-preview-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) (or (vm-sortable-datestring-of m) (progn (vm-set-sortable-datestring-of m (condition-case nil (vm-timezone-make-date-sortable (or (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) (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. You may sort by more than one particular message key. 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\" \"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) (vm-check-for-killed-summary) ;; only squawk if interactive. The thread display uses this ;; function and doesn't expect errors. (if (interactive-p) (vm-error-if-folder-empty)) ;; ditto (if (and (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))) (or key-list (error "No sort keys specified.")) (while key-list (setq key (car key-list)) (cond ((equal key "thread") (vm-build-threads-if-unbuilt) (vm-build-thread-lists) (setq key-funcs (cons 'vm-sort-compare-thread key-funcs))) ((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 "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))) (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))) ;; 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). (if (and vm-summary-show-threads (not (equal key-funcs '(vm-sort-compare-thread)))) (progn (setq vm-summary-show-threads nil) (vm-set-summary-redo-start-point t))) (message "Sorting...") (let ((vm-key-functions (nreverse 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)))) (message "Sorting... 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) (message "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))))) (message "Moving messages... done") (vm-set-buffer-modified-p t) (vm-clear-modification-flag-undos)) (if (and order-did-change (not vm-folder-read-only)) (progn (setq vm-message-order-changed t) (vm-set-buffer-modified-p t) (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-preview-current-message) (vm-update-summary-and-mode-line)) (if auto-folder-p (vm-sort-insert-auto-folder-names)))) ;;;###autoload (defun vm-sort-compare-xxxxxx (m1 m2) (let ((key-funcs vm-key-functions) result) (while (and key-funcs (eq '= (setq result (funcall (car key-funcs) m1 m2)))) (setq key-funcs (cdr key-funcs))) (and key-funcs result) )) (defun vm-sort-compare-thread (m1 m2) (let ((list1 (vm-th-thread-list m1)) (list2 (vm-th-thread-list m2)) (criterion (if vm-sort-threads-by-youngest-date 'youngest-date 'oldest-date)) p1 p2 d1 d2) (catch 'done (if (not (eq (car list1) (car list2))) (let ((date1 (get (car list1) criterion)) (date2 (get (car list2) criterion))) (cond ((string-lessp date1 date2) t) ((string-equal date1 date2) (string-lessp (car list1) (car list2))) (t nil))) (setq list1 (cdr list1) list2 (cdr list2)) (while (and list1 list2) (setq p1 (car list1) p2 (car list2)) (cond ((not (string-equal p1 p2)) (setq d1 (or (get p1 'date) "0") d2 (or (get p2 'date) "0")) (cond ((string-lessp d1 d2) (throw 'done t)) ((string-lessp d2 d1) (throw 'done nil)) ((string-lessp p1 p2) (throw 'done t)) (t (throw 'done nil))))) (setq list1 (cdr list1) list2 (cdr list2))) (cond ((and list1 (not list2)) nil) ((and list2 (not list1)) t) (t '=)))))) (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-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 ((n1 (vm-start-of m1)) (n2 (vm-start-of m2))) (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)))) (provide 'vm-sort) ;;; vm-sort.el ends here vm-8.1.2/lisp/vm-folder.el0000644000175000017500000051475711725175471015637 0ustar srivastasrivasta;;; vm-folder.el --- VM folder related functions ;; ;; 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: (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 (or start-point vm-message-list))) (if (and start-point (vm-reverse-link-of (car start-point))) (setq n (1+ (string-to-number (vm-number-of (car (vm-reverse-link-of (car 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." (intern (buffer-name) vm-buffers-needing-display-update) (if (eq vm-numbering-redo-start-point t) nil (if (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))) (if (null mp) (error "Something is wrong in vm-set-numbering-redo-start-point")) (if (eq (car mp) (car start-point)) (setq vm-numbering-redo-start-point start-point))) (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." (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." (if vm-numbering-redo-start-point (progn (vm-number-messages (and (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." (intern (buffer-name) vm-buffers-needing-display-update) (if (eq vm-summary-redo-start-point t) nil (if (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))) (if (null mp) (error "Something is wrong in vm-set-summary-redo-start-point")) (if (eq mp start-point) (setq vm-summary-redo-start-point start-point))) (setq vm-summary-redo-start-point start-point)))) (defun vm-mark-for-summary-update (m &optional dont-kill-cache) "Mark message M 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. (if (not 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)) (if (vm-su-start-of m) (setq vm-messages-needing-summary-update (cons 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. (let ((m-list (vm-virtual-messages-of m))) (while m-list (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list))) (progn (and (vm-su-start-of (car m-list)) (setq vm-messages-needing-summary-update (cons (car m-list) vm-messages-needing-summary-update))) (intern (buffer-name (vm-buffer-of (car m-list))) vm-buffers-needing-display-update))) (setq m-list (cdr m-list))))) (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) (let ((m-list (vm-virtual-messages-of m))) ;; schedule updates for all the virtual message who share ;; the same cache as this message. (while m-list (if (eq (vm-attributes-of m) (vm-attributes-of (car m-list))) (progn (and (vm-su-start-of (car m-list)) (setq vm-messages-needing-summary-update (cons (car m-list) vm-messages-needing-summary-update))) (intern (buffer-name (vm-buffer-of (car m-list))) vm-buffers-needing-display-update))) (setq m-list (cdr m-list))) ;; now take care of the real message (if (not 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)) (and (vm-su-start-of (vm-real-message-of m)) (setq vm-messages-needing-summary-update (cons (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)) (if (not dont-kill-cache) (vm-set-virtual-summary-of m nil)) (and (vm-su-start-of m) (setq vm-messages-needing-summary-update (cons m vm-messages-needing-summary-update))) (intern (buffer-name (vm-buffer-of m)) vm-buffers-needing-display-update))))) (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) (save-excursion (set-buffer (other-buffer)) (set-buffer-modified-p (buffer-modified-p))))) (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) (set-buffer-modified-p omodified)))) (if vm-presentation-buffer (let ((omodified (buffer-modified-p))) (unwind-protect (save-excursion (set-buffer vm-presentation-buffer) (let ((buffer-read-only nil)) (erase-buffer))) (set-buffer-modified-p omodified))))) ;; 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 vm-summary-buffer (let ((modified (buffer-modified-p))) (save-excursion (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) (set-buffer vm-summary-buffer) (set-buffer-modified-p modified)))) (if vm-presentation-buffer (let ((modified (buffer-modified-p))) (save-excursion (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) (set-buffer vm-presentation-buffer) (set-buffer-modified-p modified)))) (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))) (if b (progn (set-buffer b) (intern (buffer-name) vm-buffers-needing-undo-boundaries) (vm-check-for-killed-summary) (and vm-use-toolbar (vm-toolbar-support-possible-p) (vm-toolbar-update-toolbar)) (vm-do-needed-renumbering) (if 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)) (if vm-messages-needing-summary-update (progn (mapcar (function vm-update-message-summary) vm-messages-needing-summary-update) (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 "")))) (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 ((reg1 "^From .*[0-9]$") (case-fold-search nil)) (catch 'done (while (re-search-forward reg1 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 ((reg1 "^From .*[0-9]$") (case-fold-search nil)) (if (re-search-forward reg1 nil 'no-error) (progn (goto-char (match-beginning 0)) t ) nil ))) ((eq vm-folder-type 'From_-with-Content-Length) (let ((reg1 "\\(^\\|\n+\\)From ") (case-fold-search nil)) (if (re-search-forward reg1 nil 'no-error) (progn (goto-char (match-end 1)) t) nil ))) ((eq vm-folder-type 'mmdf) (let ((reg1 "^\001\001\001\001") (case-fold-search nil)) (if (re-search-forward reg1 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)) (progn (message "Warning: newline found at beginning of folder, %s" (or buffer-file-name (buffer-name))) (sleep-for 2))) (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)) (message "Parsing messages... %d" n))) (if (>= n modulus) (message "Parsing messages... done")) (if (and (not (= last-end (point-max))) (not (eq vm-folder-type 'unknown))) (progn (message "Warning: garbage found at end of folder, %s, starting at %d" (or buffer-file-name (buffer-name)) last-end) (sleep-for 2)))))) (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 keep-list discard-regexp) (interactive (progn (goto-char (point-min)) (list nil vm-mail-header-order "NO_MATCH_ON_HEADERS:"))) (save-excursion (if message (progn (set-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)) (set-buffer-modified-p old-buffer-modified-p)))) (and 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)))) ;; (unless (= 0 (logand status #x0004)) ; flagged ;; nil) (vm-set-deleted-flag-of message (not (= 0 (logand status #x0008)))) ; deleted ;; (unless (= 0 (logand status #x0010)) ; subject with "Re:" prefix ;; nil) ;; (unless (= 0 (logand status #x0020)) ; thread folded ;; nil) ;; (unless (= 0 (logand status #x0080)) ; offline article ;; nil) ;; (unless (= 0 (logand status #x0100)) ; watched ;; nil) ;; (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 bits, ; 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)))) ;; (unless (= 0 (logand status #x0004)) ; ignored thread ;; nil) ;; (unless (= 0 (logand status #x0020)) ; deleted on the server ;; nil) ;; (unless (= 0 (logand status #x0040)) ; read-receipt requested ;; nil) ;; (unless (= 0 (logand status #x0080)) ; read-receipt sent ;; nil) ;; (unless (= 0 (logand status #x0100)) ; template ;; nil) ;; (unless (= 0 (logand status #x1000)) ; has attachments ;; 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)) (if (and (or (not (listp data)) (not (> (length data) 1))) (not (vectorp data))) (progn (error "Bad x-vm-v5-data at %d in buffer %s: %S" oldpoint (buffer-name) data))) data) (error (message "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-cache-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-cache-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-cache-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-cache-vector-length) (or (null (aref cache 7)) (stringp (aref cache 7))) (or (null (aref cache 11)) (stringp (aref cache 11)))) (message "Bad VM cache data: %S" cache) (vm-set-stuff-flag-of (car mp) t) (setcar (cdr data) (setq cache (make-vector vm-cache-vector-length nil)))) (vm-set-labels-of (car mp) (nth 2 data)) (vm-set-cache-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-cache-of (car mp) (make-vector vm-cache-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.*")) t)) (t (vm-set-cache-of (car mp) (make-vector vm-cache-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)) (message "Reading attributes... %d" vm-total-count)) (setq mp (cdr mp))) (if (>= vm-total-count modulus) (message "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-cache-vector-length nil)) (vm-set-cache-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) (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) (if (not (equal (nth 0 vm-totals) vm-modification-counter)) (vm-compute-totals)) (if (equal (nth 1 vm-totals) 0) (message "No messages.") (message "%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-cache-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))) (if (not (consp time)) (error "Bad last-modified header at %d in buffer %s" oldpoint (buffer-name))) time ) (error (message "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]*")) (mapcar (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))) (if (not (listp list)) (error "Bad global label list at %d in buffer %s" oldpoint (buffer-name))) list ) (error (message "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))) (if (not (natnump n)) (error "Bad bookmark at %d in buffer %s" oldpoint (buffer-name))) n ) (error (message "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))) (if (not (listp ob)) (error "Bad pop-retrieved header at %d in buffer %s" oldpoint (buffer-name))) (setq vm-pop-retrieved-messages ob)) (error (message "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))) (if (not (listp ob)) (error "Bad imap-retrieved header at %d in buffer %s" oldpoint (buffer-name))) (setq vm-imap-retrieved-messages ob)) (error (message "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)) (message "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))) (if (not (listp order)) (error "Bad order header at %d in buffer %s" oldpoint (buffer-name))) order ) (error (message "Bad order header at %d in buffer %s, ignoring" oldpoint (buffer-name)) (setq order nil))) (if order (progn (message "Reordering messages...") (vm-startup-apply-message-order order) (message "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 (message "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)))) (defun vm-encode-words-in-cache-vector (list) (vm-mapvector (lambda (e) (if (stringp e) (vm-mime-encode-words-in-string e) e)) list)) ;; Stuff the message attributes back into the message as headers. (defun vm-stuff-attributes (m &optional for-other-folder) (save-excursion (vm-save-restriction (widen) (let ((old-buffer-modified-p (buffer-modified-p)) 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-cache-of m)) (and delflag for-other-folder (vm-set-deleted-flag-in-vector (setq attributes (copy-sequence attributes)) nil)) (if (eq vm-folder-type 'babyl) (vm-stuff-babyl-attributes m for-other-folder)) (if (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-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-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))))) (vm-set-stuff-flag-of m (not for-other-folder))) (set-buffer-modified-p old-buffer-modified-p)))))) (defun vm-stuff-folder-attributes (&optional abort-if-input-pending quiet) (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))) (if (and newlist (not quiet)) (progn (setq len (length newlist)) (message "%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) (message "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-attributes (car mp)) (setq n (1+ n)) (if (not quiet) (message "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-attributes. 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-attributes (message) (let ((virtual (vm-virtual-message-p message))) (if (or (not virtual) (and virtual (vm-virtual-messages-of message))) (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of message))) (vm-stuff-attributes (vm-real-message-of message)))))) (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-mark-of message) (setq status (logior status #x4))) (when (vm-deleted-flag message) (setq status (logior status #x8))) (when (vm-forwarded-flag message) (setq status (logior status #x1000))) (when (vm-new-flag message) (setq status2-hi (logior status2-hi #x1))) (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") (set-buffer-modified-p old-buffer-modified-p)))))) ;; 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") (set-buffer-modified-p old-buffer-modified-p)))))) (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") (set-buffer-modified-p old-buffer-modified-p)))))) (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")) (set-buffer-modified-p old-buffer-modified-p)))))) (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")) (set-buffer-modified-p old-buffer-modified-p)))))) ;; 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") (set-buffer-modified-p old-buffer-modified-p)))))) ;; 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") (set-buffer-modified-p old-buffer-modified-p)))))) ;; 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) (set-buffer-modified-p old-buffer-modified-p)))))) ;; 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) (set-buffer-modified-p old-buffer-modified-p)))))) (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) (message "Reading index file...") (setq work-buffer (vm-make-work-buffer)) (save-excursion (set-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-cache-vector-length) (setq v (vm-extend-vector v vm-cache-vector-length))) (vm-set-cache-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 "thread"))) (vm-startup-apply-summary summary) (vm-startup-apply-labels labels) (vm-startup-apply-header-variables vis invis) (message "Reading index file... done") t ) (and work-buffer (kill-buffer work-buffer)))) (error (message "Index file read of %s signaled: %s" index-file error-data) (sleep-for 2) (message "Ignoring index file...") (sleep-for 2))))) (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) (message "Sorting for index file...") (setq m-list (sort (copy-sequence vm-message-list) (function vm-sort-compare-physical-order))) (message "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-cache-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) (message "Writing index file...") (catch 'done (save-excursion (set-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 (message "Write of %s signaled: %s" index-file data) (sleep-for 2) (throw 'done nil)))) (vm-error-free-call 'set-file-modes index-file (vm-octal 600)) (message "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-unread-message (&optional count) "Set the `unread' attribute for the current message. If the message is already new or unread, 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 unread the current message and the previous N-1 messages. When invoked on marked messages (via vm-next-command-uses-marks), all marked messages are affected, other messages are ignored." (interactive "p") (or count (setq count 1)) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((mlist (vm-select-marked-or-prefixed-messages count))) (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-unread-message) '(vm-unread-message)) (vm-update-summary-and-mode-line)) ;;;###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) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (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) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (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)) (defvar dired-listing-switches) ; defined only in FSF Emacs? ;;;###autoload (defun vm-quit (&optional no-change) "Quit visiting the current folder, saving changes. Deleted messages are not expunged." (interactive) (vm-select-folder-buffer) (if (not (memq major-mode '(vm-mode vm-virtual-mode))) (error "%s must be invoked from a VM buffer." this-command)) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-display nil nil '(vm-quit vm-quit-no-change) (list this-command 'quitting)) (let ((virtual (eq major-mode 'vm-virtual-mode))) (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)) (vm-garbage-collect-message) (vm-garbage-collect-folder) (vm-virtual-quit) (if (and (not no-change) (not virtual)) (progn ;; this could take a while, so give the user some feedback (message "Quitting...") (or vm-folder-read-only (eq major-mode 'vm-virtual-mode) (vm-change-all-new-to-unread)))) (if (and (buffer-modified-p) (or buffer-file-name buffer-offer-save) (not no-change) (not virtual)) (vm-save-folder)) (message "") (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)) ;; The following call is not working correctly. So we do it ;; ourselves. ;; (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)) ;; this is a hack to suppress another confirmation dialogue ;; coming from kill-buffer (set-buffer-modified-p nil) (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)) (and (natnump vm-flush-interval) (not (get-itimer "vm-flush")) (start-itimer "vm-flush" 'vm-flush-itimer-function vm-flush-interval nil)) (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)) (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) (and (natnump vm-flush-interval) (not (vm-timer-using 'vm-flush-itimer-function)) (setq timer (run-at-time vm-flush-interval vm-flush-interval 'vm-flush-itimer-function nil)) (timer-set-function timer 'vm-flush-itimer-function (list timer))) (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))) (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) (while (and (not (input-pending-p)) b-list) (save-excursion (if (not (buffer-live-p (car b-list))) nil (set-buffer (car b-list)) (if (and (eq major-mode 'vm-mode) (setq found-one t) ;; to avoid reentrance into the pop and imap code (not vm-global-block-new-mail)) (progn (setq oldval vm-spooled-mail-waiting) (setq vm-spooled-mail-waiting (vm-check-for-spooled-mail nil t)) (if (not (eq oldval vm-spooled-mail-waiting)) (progn (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. (if (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 (if (not (buffer-live-p (car b-list))) nil (set-buffer (car b-list)) (if (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)) (progn ;; don't move the message pointer unless the folder ;; was empty. (if (and (null vm-message-pointer) (vm-thoughtfully-select-message)) (vm-preview-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. (if (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) (if (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. (if (not (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-attributes 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)) (message "Stuffing attributes...") (vm-stuff-folder-attributes nil) (message "Stuffing attributes... 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-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)))) nil )))) ;;;###autoload (defun vm-save-buffer (prefix) (interactive "P") (vm-select-folder-buffer) (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 () (interactive) (vm-select-folder-buffer) (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 (&optional prefix) "Save current folder to disk. Deleted messages are not expunged. Prefix arg is handled the same as for the command `save-buffer'. 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) (vm-check-for-killed-summary) (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)) (cond ((eq vm-folder-access-method 'pop) (vm-pop-synchronize-folder t t t nil)) ((eq vm-folder-access-method 'imap) (vm-imap-synchronize-folder t t t nil t))) ;; 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. (message "Stuffing attributes...") (vm-stuff-folder-attributes nil) (message "Stuffing attributes... done") ;; stuff bookmark and header variable values (if vm-message-list (progn ;; get summary cache up-to-date (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)))) (message "Saving...") (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-set-buffer-modified-p nil) ;; 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 (vm-buffer-variable-value (car b-list) 'vm-real-buffers))) (vm-set-buffer-modified-p nil (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-set-buffer-modified-p nil (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) (message "%s removed" buffer-file-name)) ;; no can do, oh well. (error nil))) ) (message "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) (vm-check-for-killed-summary) (vm-display nil nil '(vm-save-and-expunge-folder) '(vm-save-and-expunge-folder)) (if (not vm-folder-read-only) (progn (message "Expunging...") (vm-expunge-folder t))) (vm-save-folder prefix)) ;;;###autoload (defun vm-read-folder (folder &optional remote-spec) "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." (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))) (message "Reading %s..." file) (prog1 (find-file-noselect file t) ;; update folder history (let ((item (or remote-spec folder vm-primary-inbox))) (if (not (equal item (car vm-folder-history))) (setq vm-folder-history (cons item vm-folder-history)))) (message "Reading %s... done" file))))))) ;;;###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) nil access-method 'reload))) ;;;###autoload (defun vm-revert-folder () "Revert the current folder to its version on the disk. Same as \\[vm-revert-buffer]." (interactive) (call-interactively '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) nil access-method 'reload))) ;;;###autoload (defun vm-recover-folder () "Recover the autosave file for the current folder. Same as \\[vm-recover-file]." (interactive) (call-interactively '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) nil 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)) (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))) (pop-up-frames (and vm-mutable-frames vm-frame-per-help))) (cond ((eq last-command 'vm-help) (describe-function major-mode)) ((eq vm-system-state 'previewing) (message "Type SPC to read message, n previews next message (? gives more help)")) ((memq vm-system-state '(showing reading)) (message "SPC and b scroll, (d)elete, (s)ave, (n)ext, (r)eply (? gives more help)")) ((eq vm-system-state 'editing) (message (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) (message (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) (condition-case () (find-file-name-handler source 'vm-spool-move-mail) (wrong-number-of-arguments (find-file-name-handler source))))) 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))) (save-excursion (set-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-excursion (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) (message "Warning: unexpected output from %s" vm-movemail-program) (sleep-for 2))) ;; 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)) (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)) (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) (progn (vm-convert-folder-header (or inbox-folder-type vm-default-folder-type) nil) (set-buffer-modified-p nil)))) (goto-char (point-max)) (insert-buffer-substring crash-buf 1 (1+ (save-excursion (set-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) (set-buffer-modified-p old-buffer-modified-p)) (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 (and (fboundp 'find-file-name-handler) (condition-case () (find-file-name-handler source 'vm-spool-check-mail) (wrong-number-of-arguments (find-file-name-handler source)))))) (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 (or quietly (message "Counting messages in %s..." file)) (call-process vm-grep-program nil t nil "-c" regexp (expand-file-name file)) (or quietly (message "Counting messages in %s... done" file))) (error (message "Attempt to run %s on %s signaled: %s" vm-grep-program file data) (sleep-for 2) (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-for-mail interactive)) ((eq vm-folder-access-method 'imap) (vm-imap-folder-check-for-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))) (if (or this-buffer (not this-buffer-only)) (progn (if (file-exists-p crash) (progn (setq mail-waiting t)) (cond ((and vm-recognize-imap-maildrops (string-match vm-recognize-imap-maildrops maildrop)) (setq meth 'vm-imap-check-mail)) ((and vm-recognize-pop-maildrops (string-match vm-recognize-pop-maildrops 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 nil nil t)) ((eq vm-folder-access-method 'imap) (if vm-imap-sync-on-get (progn ;; (vm-imap-synchronize-folder interactive nil nil nil t nil) ; save-attributes (vm-imap-synchronize-folder interactive nil t t t t)) ; do-local-expunges ; do-retrieves ; retrieve-attributes (vm-imap-synchronize-folder interactive nil nil t nil nil))) (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 (message "Folder %s changed on disk, consider M-x revert-buffer" (buffer-name (current-buffer))) (sleep-for 2) 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)) ((and vm-recognize-imap-maildrops (string-match vm-recognize-imap-maildrops maildrop)) (setq non-file-maildrop t) (setq safe-maildrop (vm-safe-imapdrop-string maildrop)) (setq retrieval-function 'vm-imap-move-mail)) ((and vm-recognize-pop-maildrops (string-match vm-recognize-pop-maildrops maildrop)) (setq non-file-maildrop t) (setq safe-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)) (if (eq (current-buffer) (vm-get-file-buffer in)) (progn (if (file-exists-p crash) (progn (message "Recovering messages from %s..." crash) (setq got-mail (or (vm-gobble-crash-box crash) got-mail)) (message "Recovering messages from %s... done" crash))) (if (or non-file-maildrop (and (not (equal 0 (nth 7 (file-attributes maildrop)))) (file-readable-p maildrop))) (progn (if (not non-file-maildrop) (setq maildrop (expand-file-name maildrop vm-folder-directory))) (if (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 (message "%s signaled: %s" retrieval-function error-data) (sleep-for 2) ;; we don't know if mail was ;; put into the crash box or ;; not, so return t just to be ;; safe. t ) (quit (message "quitting from %s..." retrieval-function) (sleep-for 2) ;; 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)) (if (vm-gobble-crash-box crash) (progn (setq got-mail t) (if (not non-file-maildrop) (vm-store-folder-totals maildrop '(0 0 0 0))) (message "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 (message "Ignoring error while running vm-retrieved-spooled-mail-hook. %S" errmsg))) (vm-assimilate-new-messages t)))))) ;;;###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)) (defun vm-safe-popdrop-string (drop) (or (and (string-match "^\\(pop:\\|pop-ssl:\\|pop-ssh:\\)?\\([^:]*\\):[^:]*:[^:]*:\\([^:]*\\):[^:]*" drop) (concat (substring drop (match-beginning 3) (match-end 3)) "@" (substring drop (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-safe-imapdrop-string (drop) (or (and (string-match "^\\(imap\\|imap-ssl\\|imap-ssh\\):\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*:\\([^:]*\\):[^:]*" drop) (concat (substring drop (match-beginning 4) (match-end 4)) "@" (substring drop (match-beginning 2) (match-end 2)) " [" (substring drop (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-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-passord 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)) ;;;###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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (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) (if (not (eq major-mode 'vm-mode)) (vm-mode)) (if (consp (car (vm-spool-files))) (message "Checking for new mail for %s..." (or buffer-file-name (buffer-name))) (message "Checking for new mail...")) (let (totals-blurb) (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-preview-current-message) (vm-update-summary-and-mode-line)) (message totals-blurb)) (if (consp (car (vm-spool-files))) (message "No new mail for %s" (or buffer-file-name (buffer-name))) (message "No new mail.")) (and (interactive-p) (sit-for 4) (message ""))))) (t (let ((buffer-read-only nil) folder mcount totals-blurb) (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-preview-current-message) (vm-update-summary-and-mode-line)) (message 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)))) (message "No messages gathered.")))))) ;; returns list of new messages if there were any new messages, nil otherwise (defun vm-assimilate-new-messages (&optional dont-read-attributes gobble-order labels first-time) (let ((tail-cons (vm-last vm-message-list)) b-list new-messages) (save-excursion (vm-save-restriction (widen) (vm-build-message-list) (if (or (null tail-cons) (cdr tail-cons)) (progn (if (not vm-assimilate-new-messages-sorted) (setq vm-ml-sort-keys nil)) (if dont-read-attributes (vm-set-default-attributes (cdr tail-cons)) (vm-read-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. (if gobble-order (vm-gobble-message-order)) (if (or (vectorp vm-thread-obarray) vm-summary-show-threads) (vm-build-threads (cdr tail-cons)))))) (setq new-messages (if tail-cons (cdr tail-cons) vm-message-list)) (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. (if (and new-messages dont-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 (if (and new-messages labels vm-burst-digest-messages-inherit-labels) (let ((mp new-messages)) (while mp (vm-set-labels-of (car mp) (copy-sequence labels)) (setq mp (cdr mp))))) (if (and new-messages 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 "thread"))) (if (and new-messages (or vm-arrived-message-hook vm-arrived-messages-hook) ;; Run the hooks only if this is not the first ;; time vm-assimilate-new-messages has been called ;; in this folder. (not first-time)) (let ((new-messages new-messages)) ;; 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) (if vm-arrived-message-hook (while new-messages (vm-run-message-hook (car new-messages) 'vm-arrived-message-hook) (setq new-messages (cdr new-messages)))) (run-hooks 'vm-arrived-messages-hook))) (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 (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)) (if (null vm-message-pointer) (progn (setq vm-message-pointer vm-message-list vm-need-summary-pointer-update t) (if vm-message-pointer (vm-preview-current-message)))) (if vm-summary-show-threads (progn (vm-update-summary-and-mode-line) (vm-sort-messages "thread"))))))) (setq b-list (cdr b-list))))) (if (and new-messages vm-ml-sort-keys) (vm-sort-messages vm-ml-sort-keys)) new-messages )) (defun vm-select-marked-or-prefixed-messages (prefix) "Return a list of all marked messages or the messages indicated by a prefix argument. If the prefix argument is supplied *and we are not in a vm-next-command-uses-marks context*, then return a number of messages around vm-message-pointer equal to (abs prefix), either backward (prefix is negative) or forward (positive)." (if (eq last-command 'vm-next-command-uses-marks) (vm-marked-messages) (let (mlist (direction (if (< prefix 0) 'backward 'forward)) (count (vm-abs prefix)) (vm-message-pointer vm-message-pointer)) (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)))) (defun vm-display-startup-message () (if (sit-for 5) (let ((lines vm-startup-message-lines)) (message "VM %s. Type ? for help." (vm-version)) (setq vm-startup-message-displayed t) (while (and (sit-for 4) lines) (message (substitute-command-keys (car lines))) (setq lines (cdr lines))))) (message "")) ;;;###autoload (defun vm-toggle-read-only () (interactive) (vm-select-folder-buffer) (setq vm-folder-read-only (not vm-folder-read-only)) (intern (buffer-name) vm-buffers-needing-display-update) (message "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 vm-folder-access-data (make-vector 2 nil))) ((eq access-method 'imap) (setq vm-folder-access-method 'imap vm-folder-access-data (make-vector 11 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) (and (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 () (let ((b-list (buffer-list)) (vbuffers nil) (folder-buffer (current-buffer)) folders 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 (if (eq folder-buffer (vm-get-file-buffer (expand-file-name (car folders) vm-folder-directory))) (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)) (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) (vm-check-for-killed-summary) (vm-error-if-virtual-folder) (vm-error-if-folder-empty) (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)) (message "Converting... %d" n)))))) (vm-clear-modification-flag-undos) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) (message "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) (while files (setq vm-global-garbage-alist (cons (cons (car files) 'delete-file) vm-global-garbage-alist) files (cdr files)))) (defun vm-register-folder-garbage-files (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) (save-excursion (vm-select-folder-buffer) (setq vm-folder-garbage-alist (cons (cons garbage action) vm-folder-garbage-alist)))) (defun vm-register-message-garbage-files (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) (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-global () (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-garbage-collect-folder () (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-garbage-collect-message () (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))) (provide 'vm-folder) ;;; vm-folder.el ends here vm-8.1.2/lisp/autoloads.py0000755000175000017500000000636411725175471015760 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.1.2/lisp/vm-vcard.el0000644000175000017500000000532311725175471015443 0ustar srivastasrivasta;;; vm-vcard.el --- vcard parsing and formatting routines 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: (require 'vcard) (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) (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")) (provide 'vm-vcard) ;;; vm-vcard.el ends here. vm-8.1.2/lisp/vm-w3m.el0000644000175000017500000001351511725175471015054 0ustar srivastasrivasta;;; vm-w3m.el --- additional functions to make VM use emacs-w3m for HTML mails ;; 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: (eval-when-compile (require 'cl) (require 'advice) (require 'vm-mime) (require 'vm-version) (require 'vm-vars) (require 'executable)) (eval-and-compile (vm-load-features '(w3m))) ;; 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) (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) (vm-buffer-variable-value 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))))) (provide 'vm-w3m) ;;; vm-w3m.el ends here vm-8.1.2/lisp/Makefile.in0000644000175000017500000001774511725175471015462 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-version.el 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-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}\")" | tr -d '\015' >> $@ echo "(setq vm-configure-pixmapdir \"${pixmapdir}\")" | 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.1.2/lisp/tapestry.el0000644000175000017500000005160511725175471015603 0ustar srivastasrivasta;;; tapestry.el --- Tools to configure your GNU Emacs windows ;; ;; 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: (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 )) (provide 'tapestry) ;;; tapestry.el ends here vm-8.1.2/lisp/vm-ps-print.el0000644000175000017500000004077011725175471016125 0ustar srivastasrivasta;;; vm-ps-print.el --- PS-printing functions for 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: (eval-when-compile (require 'vm-version) (require 'vm-message) (require 'vm-macro) (require 'vm-vars)) (require 'vm-save) (require 'ps-print) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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-psprint :type 'function) ;;;###autoload (defcustom vm-ps-print-message-separater "\n" "*The separator between messages when printing multiple messages." :group 'vm-psprint :type 'string) ;;;###autoload (defcustom vm-ps-print-message-font-size 10 "*The font size for the PS-output of the message text." :group 'vm-psprint :type 'integer) ;;---------------------------------------------------------------------------- ;;;###autoload (defcustom vm-ps-print-message-header-lines 2 "*See `ps-header-lines'." :group 'vm-psprint :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-psprint :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-psprint :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-psprint :type 'string) ;;---------------------------------------------------------------------------- ;;;###autoload (defcustom vm-ps-print-each-message-header-lines 2 "*See `ps-header-lines'." :group 'vm-psprint :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-psprint :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-psprint :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-psprint :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-th-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (or count (setq count 1)) (let* ((vm-summary-faces-mode nil) (folder-name (vm-ps-print-message-folder-name)) (mstart nil) (m nil) (mlist (vm-select-marked-or-prefixed-messages count)) (mcount (length mlist)) (tmpbuf (get-buffer-create "*vm-ps-print*"))) (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 vm-visible-headers 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) (end-of-buffer) (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (provide 'vm-ps-print) ;;; vm-ps-print.el ends here vm-8.1.2/lisp/vm-page.el0000644000175000017500000012057511725175471015267 0ustar srivastasrivasta;;; vm-page.el --- Commands to move around within a VM message ; ;; 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: ;;;###autoload (defun vm-scroll-forward (&optional arg) "Scroll 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 (vm-follow-summary-cursor)) needs-decoding (was-invisible nil)) ;; 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)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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))) (and vm-presentation-buffer (set-buffer vm-presentation-buffer)) (let ((point (point)) (w (vm-get-visible-buffer-window (current-buffer)))) (if (or (null w) (not (vm-frame-totally-visible-p (vm-window-frame w)))) (progn (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 (if (not 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) (if (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))))))) (if (not 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 () (interactive) (let ((vm-summary-uninteresting-senders-arrow "") (case-fold-search nil)) (message (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 %s" "End of message %s from %s") (vm-number-of (car vm-message-pointer)) (vm-summary-sprintf "%F" (car vm-message-pointer))))) ;;;###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) (if (extent-property e 'vm-highlight) (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 (make-extent (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (set-extent-property e 'face vm-highlighted-header-face) (set-extent-property e 'vm-highlight t))) (goto-char (vm-matched-header-end))))) ((fboundp 'overlay-put) (let (o-lists p) (setq o-lists (overlay-lists) p (car o-lists)) (while p (and (overlay-get (car p) 'vm-highlight) (delete-overlay (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (and (overlay-get (car p) 'vm-highlight) (delete-overlay (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) (if (extent-property e 'vm-url) (delete-extent e)) nil)) (current-buffer) (point-min) (point-max)) (if clean-only (message "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 (make-extent (match-beginning n) (match-end n))) (set-extent-property e 'vm-url t) (if vm-highlight-url-face (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))))) (set-extent-property e 'vm-button t) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-url-help) (set-extent-property e 'highlight t) ;; for vm-continue-postponed-message ; (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 (and (overlay-get (car p) 'vm-url) (delete-overlay (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (and (overlay-get (car p) 'vm-url) (delete-overlay (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 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) (if (extent-property e 'vm-header) (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 (make-extent (vm-matched-header-contents-start) (vm-matched-header-contents-end))) (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))))) (set-extent-property e 'keymap keymap) (set-extent-property e 'balloon-help 'vm-mouse-3-help) (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 (and (overlay-get (car p) 'vm-header) (delete-overlay (car p))) (setq p (cdr p))) (setq p (cdr o-lists)) (while p (and (overlay-get (car p) 'vm-header) (delete-overlay (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 (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 (make-extent (vm-vheaders-of (car vm-message-pointer)) (vm-vheaders-of (car vm-message-pointer)))) (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 (if (overlay-get (car ooo) 'vm-xface) (delete-overlay (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 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) (widen) ;; hide as much of the message body as vm-preview-lines specifies (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)))))) ;;;###autoload (defun vm-preview-current-message () "Preview 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 type of preview is governed by the variables `vm-preview-lines' and `vm-preview-read-messages'. If no preview is required, then the entire message is shown directly. (USR, 2010-01-14)" ;; Set new-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-load-headers-only ;; (when (not need-preview) ;; (message "Headers-only operation does not allow previews") ;; (setq need-preview nil))) (vm-save-buffer-excursion (setq vm-system-state 'previewing vm-mime-decoded nil) (if vm-real-buffers (vm-make-virtual-copy (car vm-message-pointer))) ;; run the message select hooks. (save-excursion (vm-select-folder-buffer) (and vm-select-new-message-hook (vm-new-flag (car vm-message-pointer)) (vm-run-message-hook (car vm-message-pointer) 'vm-select-new-message-hook)) (and vm-select-unread-message-hook (vm-unread-flag (car vm-message-pointer)) (vm-run-message-hook (car vm-message-pointer) 'vm-select-unread-message-hook))) (vm-narrow-for-preview (not need-preview)) (if (or vm-always-use-presentation-buffer 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)))) (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)) (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))) ;; (message "must fetch the body of %s ..." (vm-imap-uid-of real-m)) ;; (message "must NOT fetch the body of %s ..." (vm-imap-uid-of real-m)) ;; (let ((vm-message-pointer nil)) ;; (vm-discard-cached-data))) ;; )) (if (and vm-display-using-mime vm-auto-decode-mime-messages vm-mime-decode-for-preview need-preview (if vm-mail-buffer (not (vm-buffer-variable-value 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. (let ((vm-auto-displayed-mime-content-type-exceptions (cons "message/external-body" vm-auto-displayed-mime-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. ;; Comment by USR, 2010-10-14: ;; The decoding would have deleted the presentation ;; copy. Where will the next decoding get its ;; presentation copy from? This is a problem for ;; the headers-only mode. (if (and vm-mail-buffer (not (vm-body-to-be-retrieved-of (car vm-message-pointer)))) (vm-set-buffer-variable vm-mail-buffer 'vm-mime-decoded nil)) ) (vm-mime-error (vm-set-mime-layout-of (car vm-message-pointer) (car (cdr data))) (message "%s" (car (cdr data))))) (vm-narrow-for-preview))) (vm-energize-urls-in-message-region) (vm-highlight-headers-maybe) (vm-energize-headers-and-xfaces)) (if (and vm-honor-page-delimiters need-preview) (vm-narrow-to-page)) (goto-char (vm-text-of (car vm-message-pointer))) ;; If we have a window, set window start appropriately. (let ((w (vm-get-visible-buffer-window (current-buffer)))) (if w (progn (set-window-start w (point-min)) (set-window-point w (vm-text-of (car vm-message-pointer)))))) (if need-preview (vm-update-summary-and-mode-line) (vm-show-current-message)))) (vm-run-message-hook (car vm-message-pointer) 'vm-select-message-hook)) (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 it is not clear if it ;; works correctly when invoked in the presentation buffer. ;; (USR, 2010-01-21) (if (and vm-display-using-mime vm-auto-decode-mime-messages (if vm-mail-buffer (not (vm-buffer-variable-value vm-mail-buffer 'vm-mime-decoded)) (not 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-mime-layout-of (car vm-message-pointer) (car (cdr data))) (message "%s" (car (cdr data))))) ;; FIXME at this point, the folder buffer is being used for ;; display nil ) ;; 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 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 nil (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 (vm-set-buffer-variable vm-mail-buffer '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-message-hook (car vm-message-pointer) 'vm-showing-message-hook) (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-toggle-thread-folding (vm-summary-toggle-thread-folding 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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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 (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 (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) (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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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-move-to-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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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)))) ;;;###autoload (defun vm-move-to-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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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)))) (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")))) (provide 'vm-page) ;;; vm-page.el ends here vm-8.1.2/lisp/vcard.el0000644000175000017500000006656211725175471015037 0ustar srivastasrivasta;;; vcard.el --- vcard parsing and display routines ;; 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.1.2/lisp/vm-minibuf.el0000644000175000017500000003425211725175471016000 0ustar srivastasrivasta;;; vm-minibuf.el --- Minibuffer read functions for 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: (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)) (and 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-folder-list (&optional non-virtual) (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))) (defun vm-read-folder-name () (completing-read "VM Folder: " (mapcar (lambda (f) (list f)) (vm-folder-list)) nil t nil nil)) (provide 'vm-minibuf) ;;; vm-minibuf.el ends here vm-8.1.2/lisp/vm-edit.el0000644000175000017500000003070211725175471015270 0ustar srivastasrivasta;;; vm-edit.el --- Editing VM messages ;; ;; 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: ;;;###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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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 (if (vm-edited-flag (car vm-message-pointer)) (progn (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))) ;; FIXME try to load the body before saving (if (vm-body-to-be-retrieved-of (car vm-message-pointer)) (error "Message %s body has not been retrieved" (vm-number-of (car vm-message-pointer)))) (if (not (and edit-buf (buffer-name edit-buf))) (progn (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) (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) (message (substitute-command-keys "Type \\[vm-edit-message-end] to end edit, \\[vm-edit-message-abort] to abort with no change."))) (set-buffer edit-buf)) (if (and vm-mutable-frames 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." (interactive "p") (or count (setq count 1)) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (let ((mlist (vm-select-marked-or-prefixed-messages count))) (vm-discard-cached-data-internal mlist)) (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) (let ((buffers-needing-thread-sort (make-vector 29 0)) m) (while mlist (setq m (vm-real-message-of (car mlist))) (vm-garbage-collect-message) (if (vectorp vm-thread-obarray) (vm-unthread-message m 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))) (fillarray (vm-cache-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 m headers-flag) (vm-set-body-to-be-retrieved m body-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 (and vm-presentation-buffer (eq (car vm-message-pointer) m)) (save-excursion (vm-preview-current-message))) (if (vectorp vm-thread-obarray) (vm-build-threads (list m))) (if vm-summary-show-threads (intern (buffer-name) buffers-needing-thread-sort)) (let ((v-list (vm-virtual-messages-of m))) (save-excursion (while v-list (vm-set-mime-layout-of (car v-list) nil) (vm-set-mime-encoded-header-flag-of (car v-list) nil) (set-buffer (vm-buffer-of (car v-list))) (if (and vm-presentation-buffer (eq (car vm-message-pointer) (car v-list))) (save-excursion (vm-preview-current-message))) (if (vectorp vm-thread-obarray) (vm-build-threads (list (car v-list)))) (if vm-summary-show-threads (intern (buffer-name) buffers-needing-thread-sort)) (setq v-list (cdr v-list))))) (vm-mark-for-summary-update m) (setq mlist (cdr mlist))) (save-excursion (mapatoms (function (lambda (s) (set-buffer (get-buffer (symbol-name s))) (vm-sort-messages "thread"))) 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 (buffer-modified-p) (progn (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)) (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-preview-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)))) (message "No change.")) (vm-display edit-buf nil '(vm-edit-message-end) '(vm-edit-message-end reading-message startup)) (set-buffer-modified-p nil) (kill-buffer edit-buf)))) (defun vm-edit-message-abort () "Abort the edit of a message, forgetting changes to the message." (interactive) (if (null vm-message-pointer) (error "This is not a VM message edit buffer.")) (if (null (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) (kill-buffer (current-buffer)) (message "Aborted, no change.")) (provide 'vm-edit) ;;; vm-edit.el ends here vm-8.1.2/lisp/vm-pgg.el0000644000175000017500000013444311725175471015127 0ustar srivastasrivasta;;; vm-pgg.el --- PGP/MIME support for VM by pgg.el ;; ;; 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-auto-displayed-mime-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-version) (require 'vm-misc) (require 'vm-page) (require 'vm-vars) (require 'vm-mime) (require 'vm-reply) (require 'advice)) (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.") ) (defgroup vm nil "VM" :group 'mail) (defgroup vm-pgg nil "PGP and PGP/MIME support for VM by PGG." :group 'vm) (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:") (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 vm-visible-headers 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 'highlight) (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-preview-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 (interactive-p) (vm-follow-summary-cursor) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (vm-error-if-folder-empty)) ;; 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 (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer-if-possible) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) ;; 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-preview-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 (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) 'vm-pgg-mime-decrypt layout nil))) (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 nil nil 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-auto-displayed-mime-content-types) ;; (add-to-list 'vm-auto-displayed-mime-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 (vm-mime-sprintf (vm-mime-find-format-for-layout layout) layout) 'vm-pgg-mime-snarf-keys layout nil))) t) ;;; ###autoload (defun vm-pgg-snarf-keys () "*Snarf keys from the current message." (interactive) (if (interactive-p) (vm-follow-summary-cursor)) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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-mime-attach-object buffer "application/pgp-keys" (list (concat "name=\"" pgg-default-user-id ".asc\"")) description nil) ;; a crude hack to set the disposition (let ((disposition (list "attachment" (concat "filename=\"" pgg-default-user-id ".asc\""))) (end (point))) (if (featurep 'xemacs) (set-extent-property (extent-at start nil '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:") (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.1.2/lisp/vm-pine.el0000644000175000017500000014061611725175471015304 0ustar srivastasrivasta;;; vm-pine.el --- draft handling and other neat functions 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: ;; Attempt to handle older/other emacs. (eval-and-compile (require 'vm-version) (require 'vm-message) (require 'vm-macro) (require 'vm-vars)) (eval-when-compile (require 'cl)) (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))) (defgroup vm nil "VM" :group 'mail) (defgroup vm-pine nil "Pine inspired extensions to VM." :group 'vm) ;;----------------------------------------------------------------------------- ;;;###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. In `vm-mail-mode' this is bound to [C]. 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) (vm-check-for-killed-summary) (vm-check-for-killed-presentation) (vm-error-if-folder-empty) (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)) (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 vm-postponed-message-headers vm-postponed-message-discard-header-regexp)) (t ; copy undecoded messages with mime headers (vm-reorder-message-headers nil (append '("MIME-Version:" "Content-type:") vm-postponed-message-headers) 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-decode-postponed-mime-message))) (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 (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.")))) ;;----------------------------------------------------------------------------- ;;;###autoload (defun vm-decode-postponed-mime-message () "Replace the mime buttons by attachment buttons." (interactive) (cond (vm-xemacs-p (let ((e-list (extent-list nil (point-min) (point-max)))) ;; First collect the extents (setq e-list (sort (vm-delete (function (lambda (e) (extent-property e 'vm-mime-layout))) e-list t) (function (lambda (e1 e2) (< (extent-end-position e1) (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-decode-postponed-mime-button (car e-list)) (setq e-list (cdr e-list))))) (vm-fsfemacs-p (let ((o-list (vm-pine-fake-attachment-overlays (point-min) (point-max)))) (setq o-list (sort (vm-delete (function (lambda (o) (overlay-get o 'vm-mime-layout))) o-list t) (function (lambda (e1 e2) (< (overlay-end e1) (overlay-end e2)))))) (while o-list (vm-decode-postponed-mime-button (car o-list)) (setq o-list (cdr o-list))))) (t (error "don't know how to MIME dencode composition for %s" (emacs-version))))) (defun vm-pine-fake-attachment-overlays (start end) (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 'vm-mime-layout)) (setq pos (next-single-property-change pos 'vm-mime-layout)) (or pos (setq pos (point-max) done t)) (if object (progn (setq o (make-overlay start pos)) (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 (append (list 'vm-mime-object t) (text-properties-at start))) (while props (overlay-put o (car props) (car (cdr props))) (setq props (cdr (cdr props)))) (setq o-list (cons o o-list)))) (setq start pos)) o-list )))) ;;----------------------------------------------------------------------------- (defun vm-decode-postponed-mime-button (x) "Replace the mime button specified by X." (save-excursion (let (layout xstart xend) (if vm-fsfemacs-p (setq layout (overlay-get x 'vm-mime-layout) xstart (overlay-start x) xend (overlay-end x)) (setq layout (extent-property x 'vm-mime-layout) xstart (extent-start-position x) xend (extent-end-position x))) (let* ((start (vm-mm-layout-header-start layout)) (end (vm-mm-layout-body-end layout)) (b (marker-buffer start)) (desc (or (vm-mm-layout-description layout) "message body text")) (disp (or (vm-mm-layout-disposition layout) '("inline"))) (file (vm-mime-get-disposition-parameter layout "filename")) filename (type (vm-mm-layout-type layout))) (if (and type (string= (car type) "message/external-body") (string= (cadr type) "access-type=local-file")) (save-excursion (setq filename (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)))))))) ;; delete the mime-button (goto-char xstart) (delete-region xstart xend) ;; and insert an attached-object-button (if filename (vm-mime-attach-file filename (car type)) (if file (vm-mime-attach-object (list b start end disp file) (car type) nil desc t) (vm-mime-attach-object (list b start end disp) (car type) nil desc t))))))) ;;----------------------------------------------------------------------------- (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 (let ((vm-do-fcc-before-mime-encode nil)) (condition-case nil (vm-mime-encode-composition) (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 (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 arounf 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 (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 (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) (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-get-header-contents (header-name-regexp &optional clump-sep) "Return the contents of the header(s) matching HEADER-NAME-REGEXP. This function is a slightly changed version of `vm-get-header-contents'. Optional argument CLUMP-SEP usually a \",\"." (let ((contents nil) (text-of-message 0) (regexp (concat "^\\(" header-name-regexp "\\)"))) (save-excursion (goto-char (point-min)) (if (re-search-forward (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))) ;;;###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))))))))) ;;----------------------------------------------------------------------------- (provide 'vm-pine) ;;; vm-pine.el ends here vm-8.1.2/lisp/vm-toolbar.el0000644000175000017500000006163411725175471016015 0ustar srivastasrivasta;;; vm-toolbar.el --- Toolbar related functions and commands ;; ;; 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: (eval-when-compile (require 'vm-vars)) (defvar vm-toolbar-specifier nil) (defvar 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)) (defvar 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)) (defvar 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) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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)) (defvar 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) (defvar 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) (defvar 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)) (defvar 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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (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) (vm-check-for-killed-summary) (vm-error-if-folder-read-only) (vm-error-if-folder-empty) (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) (if file (progn (vm-save-message file 1) (message "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 vm-summary-buffer (vm-copy-local-variables vm-summary-buffer 'vm-toolbar-delete/undelete-icon 'vm-toolbar-helper-command 'vm-toolbar-helper-icon)) (if 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 :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 (message "Bad toolbar pixmap directory, can't setup toolbar.") (sit-for 2)) (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))))) (provide 'vm-toolbar) ;;; vm-toolbar.el ends here vm-8.1.2/lisp/vm-version.el0000644000175000017500000001207111725175471016027 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: (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-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-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)) (provide 'vm-version) ;;; vm-version.el ends here vm-8.1.2/lisp/vm-license.el0000644000175000017500000000361511725175471015770 0ustar srivastasrivasta;;; vm-license.el --- Code to show VM's warranty and copying restrictions ;; ;; 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: ;;;###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-windows t)) (pop-up-frames (and vm-mutable-frames 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)) (provide 'vm-license) ;;; vm-license.el ends here vm-8.1.2/lisp/vm-w3.el0000644000175000017500000000472211725175471014677 0ustar srivastasrivasta;;; vm-w3.el --- additional functions to make VM use w3 for HTML mails ;; 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-version) (require 'vm-mime) (require 'vm-vars)) (eval-and-compile (vm-load-features '(w3))) (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.1.2/lisp/vm-virtual.el0000644000175000017500000007666711725175471016055 0ustar srivastasrivasta;;; vm-virtual.el --- Virtual folders for VM ;; ;; Copyright (C) 1990-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: ;;;###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 mp folders folder selectors sel-list selector arglist i real-buffers-used) (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. (setq mp vm-message-list) (while mp (intern (vm-message-id-number-of (vm-real-message-of (car mp))) message-set) (setq mp (cdr mp)))) ;; now select the messages (save-excursion (while clauses (setq folders (car (car clauses)) selectors (cdr (car clauses))) (while folders (setq folder (car folders)) (cond ((and (stringp folder) (stringp vm-recognize-pop-maildrops) (string-match vm-recognize-pop-maildrops folder)) nil) ((and (stringp folder) (stringp vm-recognize-imap-maildrops) (string-match vm-recognize-imap-maildrops folder)) nil) ((stringp folder) (setq folder (expand-file-name folder vm-folder-directory))) ((listp folder) (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)) (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-visit-folder folder) (vm-select-folder-buffer) (current-buffer))))) (set-buffer (or (and (bufferp folder) folder) (vm-get-file-buffer folder) (let ((inhibit-local-variables t) (coding-system-for-read (vm-binary-coding-system)) (enable-local-eval nil) (enable-local-variables nil)) (vm-visit-folder folder) (vm-select-folder-buffer) (current-buffer)))) (if (eq major-mode 'vm-virtual-mode) (setq virtual t real-buffers-used (append vm-real-buffers real-buffers-used)) (setq virtual nil) (when (not (memq (current-buffer) real-buffers-used)) (setq real-buffers-used (cons (current-buffer) real-buffers-used))) (when (not (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. (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 (setq mp (or new-messages vm-message-list)) (while mp (if (and (or dont-finalize (not (intern-soft (vm-message-id-number-of (vm-real-message-of (car mp))) message-set))) (if virtual (save-excursion (set-buffer (vm-buffer-of (vm-real-message-of (car mp)))) (apply 'vm-vs-or (car mp) selectors)) (apply 'vm-vs-or (car mp) selectors))) (progn (or dont-finalize (intern (vm-message-id-number-of (vm-real-message-of (car mp))) message-set)) (setq message (copy-sequence (vm-real-message-of (car mp)))) (if 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)) (vm-set-real-message-sym-of message (vm-real-message-sym-of (car mp))) (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 mp (cdr mp))))) (setq folders (cdr folders))) (setq clauses (cdr clauses)))) (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)) (if (null vm-real-buffers) (setq vm-real-buffers real-buffers-used)) (save-excursion (while real-buffers-used (set-buffer (car real-buffers-used)) ;; inherit the global label lists of all the associated ;; real folders. (mapatoms (function (lambda (x) (intern (symbol-name x) label-obarray))) vm-label-obarray) (if (not (memq vbuffer vm-virtual-buffers)) (setq vm-virtual-buffers (cons vbuffer vm-virtual-buffers))) (setq real-buffers-used (cdr real-buffers-used)))) (setq mp new-message-list) (while mp (vm-set-virtual-messages-of (vm-real-message-of (car mp)) (cons (car mp) (vm-virtual-messages-of (vm-real-message-of (car mp))))) (setq mp (cdr mp))) (if vm-message-list (progn (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)) (vm-select-folder-buffer) (nconc (vm-read-virtual-selector "Create virtual folder of messages: ") (list prefix)))) (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((use-marks (eq last-command 'vm-next-command-uses-marks)) vm-virtual-folder-alist) (if (null name) (if arg (setq name (format "%s %s %s" (buffer-name) selector arg)) (setq name (format "%s %s" (buffer-name) selector)))) (setq vm-virtual-folder-alist (list (list name (list (list (list 'get-buffer (buffer-name))) (if use-marks (list 'and '(marked) (if arg (list selector arg) (list selector))) (if arg (list selector arg) (list selector))))))) (vm-visit-virtual-folder name read-only bookmark)) ;; 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-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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (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 () (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-error-if-folder-empty) (vm-check-for-killed-summary) (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 () (interactive) (vm-follow-summary-cursor) (vm-select-folder-buffer) (vm-error-if-folder-empty) (vm-check-for-killed-summary) (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))) (defun vm-toggle-virtual-mirror () (interactive) (vm-select-folder-buffer) (vm-check-for-killed-summary) (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) (message "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)) (message "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-any (m) t) (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) (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) (if max (<= score max) t)) (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-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-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))) (put 'sexp 'vm-virtual-selector-clause "matching S-expression selector") (put 'header 'vm-virtual-selector-clause "with header matching") (put 'label 'vm-virtual-selector-clause "with label 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 'header 'vm-virtual-selector-arg-type 'string) (put 'label 'vm-virtual-selector-arg-type 'label) (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-selector (if (eq selector 'sexp) (let ((read-arg (read arg))) (if (listp read-arg) read-arg (list read-arg))) (list selector arg)))) (or (fboundp (intern (concat "vm-vs-" (symbol-name (car real-selector))))) (error "Invalid selector")) real-selector))) ;; clear away links between real and virtual folders when ;; a vm-quit is performed in either type folder. ;;;###autoload (defun vm-virtual-quit () (save-excursion (cond ((eq major-mode 'vm-virtual-mode) ;; don't trust blindly, user might have killed some of ;; these buffers. (setq vm-real-buffers (vm-delete 'buffer-name vm-real-buffers t)) (let ((bp vm-real-buffers) (mp vm-message-list) (b (current-buffer)) ;; lock out interrupts here (inhibit-quit t)) (while bp (set-buffer (car bp)) (setq vm-virtual-buffers (delq b vm-virtual-buffers) bp (cdr bp))) (while mp (vm-set-virtual-messages-of (vm-real-message-of (car mp)) (delq (car mp) (vm-virtual-messages-of (vm-real-message-of (car mp))))) (setq mp (cdr mp))))) ((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 ((bp vm-virtual-buffers) (mp vm-message-list) vmp (b (current-buffer)) ;; lock out interrupts here (inhibit-quit t)) (while mp (setq vmp (vm-virtual-messages-of (car mp))) (while vmp ;; we'll clear these messages from the virtual ;; folder by looking for messages that have a "Q" ;; id number associated with them. (vm-set-message-id-number-of (car vmp) "Q") (setq vmp (cdr vmp))) (vm-set-virtual-messages-of (car mp) nil) (setq mp (cdr mp))) (while bp (set-buffer (car bp)) (setq vm-real-buffers (delq b vm-real-buffers)) ;; set the message pointer to a new value if it is ;; now invalid. (cond ((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. (if (null vm-message-pointer) (progn (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-preview-current-message) (vm-update-summary-and-mode-line)) (setq bp (cdr bp)))))))) ;;;###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)) (let ((bp vm-real-buffers)) (while bp (set-buffer (car bp)) (vm-save-folder prefix) (setq bp (cdr bp))))) (vm-set-buffer-modified-p nil) (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)) (let ((bp vm-real-buffers)) (while bp (set-buffer (car bp)) (condition-case error-data (vm-get-new-mail) (folder-read-only (message "Folder is read only: %s" (or buffer-file-name (buffer-name))) (sit-for 1)) (unrecognized-folder-type (message "Folder type is unrecognized: %s" (or buffer-file-name (buffer-name))) (sit-for 1))) (setq bp (cdr bp))))) (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)))))) (provide 'vm-virtual) ;; ;; now load vm-avirtual to avoid a loading loop ;; (require 'vm-avirtual) ;;; vm-virtual.el ends here vm-8.1.2/lisp/vm-digest.el0000644000175000017500000007300311725175471015623 0ustar srivastasrivasta;;; vm-digest.el --- Message encapsulation ;; ;; 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: ;;;###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)) (goto-char beg) (vm-reorder-message-headers nil nil vm-internal-unforwarded-header-regexp) (vm-reorder-message-headers nil keep-list discard-regexp) (vm-decode-mime-message-headers))))) (goto-char (point-max)) (insert "------- end of forwarded message -------\n")))) ;;;###autoload (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp always-use-digest) "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 vm-mime-header-list 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 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\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) (set-buffer-modified-p old-buffer-modified-p) ;; 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 vm-mime-header-list 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 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 vm-mime-header-list 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 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) (set-buffer-modified-p old-buffer-modified-p) ;; 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-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." (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((start-buffer (current-buffer)) m totals-blurb (mlist (vm-select-marked-or-prefixed-messages 1))) (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.")))) (message "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))) (message "Bursting %s digest... done" digest-type) (vm-clear-modification-flag-undos) (vm-set-buffer-modified-p t) (vm-increment vm-modification-counter) (and 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 t nil (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-preview-current-message) (vm-update-summary-and-mode-line)) (message 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." (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) (vm-check-for-killed-summary) (vm-error-if-folder-empty) (let ((start-buffer (current-buffer)) m totals-blurb (mlist (vm-select-marked-or-prefixed-messages 1)) (work-buffer nil)) (unwind-protect (save-excursion (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.")))) (message "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))) (message "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) (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)) (and 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 ))))) (provide 'vm-digest) ;;; vm-digest.el ends here vm-8.1.2/info/0002755000175000017500000000000011725175471013365 5ustar srivastasrivastavm-8.1.2/info/vm-pcrisis.texinfo0000644000175000017500000014525211725175471017066 0ustar srivastasrivasta\input texinfo @c %**start of header @setfilename vm-pcrisis.info @settitle Personality Crisis for VM @c %**end of header @dircategory Emacs @direntry * VM-pcrisis: (vm-pcrisis). A personality crisis solver for VM @end direntry @paragraphindent asis @ifinfo This is the documentation for Personality Crisis, an add-on for the mail reader VM which allows you to do all sorts of things automatically when you compose new mail messages or replies. Copyright @copyright{} 1999 Rob Hodges, 2006-2008 Robert Widhopf-Fenk @end ifinfo @c *************************************************************************** @node Top, Getting Started, (dir), (dir) @c node-name, next, previous, up @chapter Personality Crisis for VM This is the documentation for Personality Crisis for VM. It was originally written by Rob Hodges. Please read the docs before sending email about problems you are having. Most problems are due to incorrect regexps. That said, if something in the docs is unclear, I'd like to know so that I can improve them. And if you find a bug, I'd definitely like to know. I hope you enjoy this package. @include version.texinfo This manual corresponds to VM version @value{VERSION}. @menu * Getting Started:: * vmpc-conditions:: * vmpc-actions:: * Associating Conditions with Actions:: * Miscellaneous Variables:: * Debugging:: * New In This Version:: @end menu The incompete list of Roberts which have been involved in vm-pcrisis: @itemize @bullet @item Rob Hodges @item Robert Widhopf-Fenk @item Robert P. Goldman @item Robert Marshall @end itemize @c *************************************************************************** @node Getting Started, vmpc-conditions, Top, Top @c node-name, next, previous, up @chapter Getting Started @menu * Installation:: * Quick start:: * Description:: * Specific Abilities:: * Common Uses:: * Overview:: * Calling Automorph:: @end menu @node Installation, Quick start, Getting Started, Getting Started @section Installation @enumerate @item Load VM if you haven't previously done so in your current Emacs session. @item Byte-compile vm-pcrisis.el, using @code{M-x byte-compile-file}. You may get some byte-compiler warnings; ignore them. (For the curious: Personality Crisis uses some functions that have different names in FSF Emacs and XEmacs, automatically detecting which one you are running. The byte-compiler isn't smart enough to know this, so it warns of the functions it doesn't know about, even though they'll never be run.) @item Place the resulting .elc file somewhere in your Emacs load-path. It would probably be a good idea to leave the .el file there with it too, but you don't have to. @item Add the following line to your ~/.vm file: @lisp (require 'vm-pcrisis) @end lisp @item Read the rest of this manual and set up the variables it describes. @end enumerate @c *************************************************************************** @node Quick start, Description, Installation, Getting Started @section Quick start You do not want to read a manual but solve your personal crisis now? Then add the following to your ~/.vm file: @lisp (require 'vm-pcrisis) (vmpc-my-identities "me@@company1.nil" "me@@home.nil" "me@@alterego.nil") @end lisp Where you add you own email addresses to the call of @code{vmpc-my-identities}. This will prompt you for the profile to use when first writing an message to a unknown email address. @c *************************************************************************** @node Description, Specific Abilities, Quick start, Getting Started @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 you can set it up to do just about anything based on those. To get some ideas about how this might be useful, see @ref{Common Uses}. You can also use it to explicitly choose a "personality" when composing new messages. @c *************************************************************************** @node Specific Abilities, Common Uses, Description, Getting Started @section Specific Abilities Based on the headers of a message you are replying to, you can get vm-pcrisis to do any number of these things: @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 any of the headers in the message you are replying to. @item Call some functions before VM creates the reply. @item Call some functions 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 address in the future. @end itemize Similar functionality is available when forwarding messages. Based on the headers of a message you are composing, it can do these things: @itemize @bullet @item Change or insert any headers you like. @item Change or insert a signature. @item Insert some 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 address in the future. @end itemize If you wish, you can also have vm-pcrisis prompt you for a personality when composing a new mail, which is useful if you need to set up VM variables with new mails, or if you prefer to more deliberatly choose who you are for each message. If you write your own functions to do things that vm-pcrisis can't do by itself, ready-made functions are provided to allow you easy access to the contents of headers in both the message you are replying to, and the message you are writing. @c *************************************************************************** @node Common Uses, Overview, Specific Abilities, Getting Started @c node-name, next, previous, up @section Common Uses These are some of the common uses for Personality Crisis. @itemize @bullet @item People with multiple e-mail addresses can automatically set up headers such as From: and Reply-To:, so that eg. 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 I called it Personality Crisis...) As of version 0.7, 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: field in your reply to point to the original sender instead. (You can do the reverse as well... if you can take the flamage.) 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 Overview, Calling Automorph, Common Uses, Getting Started @section Overview 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. As of v0.84, you may also use @code{vmpc-newmail-alist} to associate conditions with actions for new messages, and since v0.85, @code{vmpc-resend-alist} for resending (bouncing) messages. If you want to use the @code{vmpc-automorph} function, which takes actions based on the headers of a message you are composing, you should read @ref{Calling 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. @c *************************************************************************** @node Calling Automorph, , Overview, Getting Started @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 vmpc-conditions, vmpc-actions, Getting Started, Top @c node-name, next, previous, up @chapter vmpc-conditions @menu * The vmpc-conditions variable:: * vmpc-conditions examples:: @end menu @node The vmpc-conditions variable, vmpc-conditions examples, vmpc-conditions, vmpc-conditions @section The vmpc-conditions variable 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 '( ("a descriptive name" (lisp-statement-1) ) ("another descriptive name" (lisp-statement-2) ) ) @end lisp The lisp-statement can be any statement in lisp that will evaluate to nil if the condition is to be considered false, or 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. If you are using @code{vm-avirtual.el} you can also use @code{vmpc-check-virtual-selector} to check a virtual folder selector. @itemize @bullet @item @code{vmpc-header-match} is of course the main one. When making replies or forwards, this matches against the contents of a header in the message you are replying/forwarding; when using the @code{vmpc-automorph} function, it matches against a header in the message you are composing. @item @code{vmpc-only-from-match} When making replies or forwards, this matches against the contents of the given headers in and it is true only when all email adresses match the given regexp. @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. @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. @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} 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 *************************************************************************** @node vmpc-conditions examples, , The vmpc-conditions variable, vmpc-conditions @c node-name, next, previous, up @section 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 vmpc-actions, Associating Conditions with Actions, vmpc-conditions, Top @c node-name, next, previous, up @chapter vmpc-actions @menu * The vmpc-actions variable:: * vmpc-actions examples:: @end menu @node The vmpc-actions variable, vmpc-actions examples, vmpc-actions, vmpc-actions @section The vmpc-actions variable 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 @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. @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. @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. @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.) @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. @item (vmpc-composition-buffer (foo-function args)) does the same, but in the composition buffer. @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 *************************************************************************** @node vmpc-actions examples, , The vmpc-actions variable, vmpc-actions @c node-name, next, previous, up @section 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 Associating Conditions with Actions, Miscellaneous Variables, vmpc-actions, Top @chapter Associating Conditions with Actions @menu * vmpc-action-alist:: * vmpc-reply-alist:: * vmpc-automorph-alist:: * vmpc-forward-alist:: * vmpc-resend-alist:: * vmpc-newmail-alist:: @end menu @c *************************************************************************** @node vmpc-action-alist, vmpc-reply-alist, Associating Conditions with Actions, Associating Conditions with Actions @c node-name, next, previous, up @section 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 *************************************************************************** @node vmpc-reply-alist, vmpc-automorph-alist, vmpc-action-alist, Associating Conditions with Actions @c node-name, next, previous, up @section 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 *************************************************************************** @node vmpc-automorph-alist, vmpc-forward-alist, vmpc-reply-alist, Associating Conditions with Actions @c node-name, next, previous, up @section 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 *************************************************************************** @node vmpc-forward-alist, vmpc-resend-alist, vmpc-automorph-alist, Associating Conditions with Actions @section 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 *************************************************************************** @node vmpc-resend-alist, vmpc-newmail-alist, vmpc-forward-alist, Associating Conditions with Actions @section 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 *************************************************************************** @node vmpc-newmail-alist, , vmpc-resend-alist, Associating Conditions with Actions @section 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 Miscellaneous Variables, Debugging, Associating Conditions with Actions, Top @c node-name, next, previous, up @chapter Miscellaneous Variables @menu * vmpc-auto-profiles-file:: * vmpc-auto-profiles-expunge-days:: * vmpc-sig-face:: * vmpc-pre-sig-face:: * vmpc-intangible-sig:: * vmpc-intangible-pre-sig:: * vmpc-expect-default-signature:: @end menu @c *************************************************************************** @node vmpc-auto-profiles-file, vmpc-auto-profiles-expunge-days, Miscellaneous Variables, Miscellaneous Variables @c node-name, next, previous, up @section 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{The vmpc-actions variable} and @ref{vmpc-actions examples}). By default it is set to "~/.vmpc-auto-profiles". @c *************************************************************************** @node vmpc-auto-profiles-expunge-days, vmpc-sig-face, vmpc-auto-profiles-file, Miscellaneous Variables @c node-name, next, previous, up @section 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 *************************************************************************** @node vmpc-sig-face, vmpc-pre-sig-face, vmpc-auto-profiles-expunge-days, Miscellaneous Variables @section 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 *************************************************************************** @node vmpc-pre-sig-face, vmpc-intangible-sig, vmpc-sig-face, Miscellaneous Variables @section 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 *************************************************************************** @node vmpc-intangible-sig, vmpc-intangible-pre-sig, vmpc-pre-sig-face, Miscellaneous Variables @section 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 *************************************************************************** @node vmpc-intangible-pre-sig, vmpc-expect-default-signature, vmpc-intangible-sig, Miscellaneous Variables @section 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 *************************************************************************** @node vmpc-expect-default-signature, , vmpc-intangible-pre-sig, Miscellaneous Variables @section 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, New In This Version, 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 New In This Version, , Debugging, Top @c node-name, next, previous, up @chapter New In This Version 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 @bye vm-8.1.2/info/Makefile.in0000644000175000017500000000506311725175471015434 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.1.2/info/vm.texinfo0000644000175000017500000071574011725175471015421 0ustar srivastasrivasta\input texinfo @setfilename vm.info @settitle VM User's Manual @dircategory Emacs @direntry * VM: (vm). A mail reader. @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 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 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, Introduction,, (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 * 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. * 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. * Bugs:: How to report VM bugs * History and Administration:: Information about VM 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. Rights: * License:: Copying and distribution terms for VM. @end menu @end ifnottex @node Introduction, Starting Up, Top, Top @unnumbered Introduction 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} @kbd{RET} @code{mail-user-agent} @kbd{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 file known as your @dfn{primary inbox}, and visits that file for reading. @xref{Starting Up}. A file visited for reading by VM is called the @dfn{current folder}. 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 b @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, @kbd{b} or @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{Viewing}. 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. Note 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. @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 You do not have to quit a folder to continue using Emacs for other purposes. (@code{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 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 @kindex L 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. Since VM has well over one hundred configuration variables, use of the @file{~/.vm} can considerably reduce clutter in the @file{.emacs} file. You can reload this file by typing @kbd{L} (@code{vm-load-init-file}) from within VM. @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 POP and IMAP servers. @xref{Server 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 * Server Folders:: Working with folders on mail servers * Thunderbird Folders:: Working with folders managed by Thunderbird * Getting New Mail:: Retrieving mail from spool files. * Crash Recovery:: Recovering changes after Emacs or your system dies. @end menu @node Local Folders, Server 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 in the documentation of the variable @code{vm-default-folder-type}. @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, although agents such as @file{procmail}, @file{filter} and @file{slocal} can be invoked from a user's @file{~/.forward} or @file{~/.qmail} files. On other systems, incoming mail is typically delivered to mailboxes on remote mail servers, from where it can be retrieved through protocols like POP and 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 VM leaves the task of accessing spool files to @file{movemail}, a program distributed with Emacs that is written for this purpose. 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. VM first copies the mail to the crash box, truncates the system mailbox 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 system mailbox 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 * POP Spool Files:: How to use a POP mailbox as a spool file * IMAP Spool Files:: How to use an 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, 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 folder @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 POP and IMAP protocols. @node POP Spool Files,IMAP Spool Files,Spool Files,Local Folders @unnumberedsubsec POP Spool Files @cindex POP spool files VM can access spool files on mail servers via the Post Office Protocol (POP). To use a POP mailbox as a spool file, you need to use a POP maildrop specification (@ref{maildrop specification}, @ref{Server Folders}). Once this is done, VM will retrieve new mail from the POP mailbox in the same way as it retrieves it from system mailbox. The retrieved messages can be automatically removed from the POP mailbox or retained until a later expunge operation. @vindex vm-pop-max-message-size By default VM will retrieve all the messages from a 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 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 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 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 POP mailboxes should have messages automatically removed after retrieving and which ones should leave the messages on the POP server. The value of @code{vm-pop-auto-expunge-alist} should be a list of 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 POP mailbox specification as described in the documentation for the variable @code{vm-spool-files}. If you have the 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 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 IMAP Spool Files, Index Files, POP Spool Files, Local Folders @unnumberedsubsec IMAP Spool Files @cindex IMAP spool files @cindex maildrop specification VM can also use the IMAP protocol to retrieve mail from a mail server. As with POP, instead of specifying a local file name in the @code{vm-spool-files} definition, you would give an IMAP maildrop specification (@ref{maildrop specification}, @ref{Server Folders}). Once this is done, VM will retrieve new mail from the IMAP mailbox in the same way as it retrieves it from system mailbox. The retrieved messages can be automatically removed from the 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 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 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 IMAP mailbox regardless of how many messages there are and how large the mailbox is. @cindex expunging, 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 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 IMAP mailboxes should have messages automatically removed after retrieving and which ones should leave the messages on the IMAP server. The value of @code{vm-imap-auto-expunge-alist} should be a list of 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 IMAP maildrop specification as described in the documentation for the variable @code{vm-spool-files}. If you have the 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 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 IMAP spool files A principal idea behind the 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 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 IMAP mailboxes from multiple locations is to use the facility of IMAP folders. (@xref{Server 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-IMAP-Retrieved header VM remembers the messages you have downloaded from an 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-IMAP-Retrieved} in your mail folder. When you expunge 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 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,IMAP Spool Files, Local Folders @unnumberedsubsec Index Files @cindex index file VM can create an 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 MMDF systems and @code{babyl} used by the Emacs Rmail mode. These formats are recognized automatically when read from the file system. @node Server Folders, Thunderbird Folders, Local Folders, Starting Up @section Server Folders @cindex primary inbox @cindex maildrop specification @vindex vm-primary-inbox VM supports accessing remote mailboxes on mail servers via the Post Office Protocol (POP) and the Internet Message Access Protocol (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{POP folders} or @dfn{IMAP folders}, more specifically). 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. 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 ( @ref{POP Spool Files} and @ref{IMAP Spool Files}), where the permanent folders are on the @emph{local} file system and only 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 POP or 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 POP over an SSL connection. Use @samp{pop-ssh} to use POP over an SSH connection. Similarly, replace @samp{imap} with @samp{imap-ssl} or @samp{imap-ssh}, as needed. For SSL, you must have the stunnel program installed and the variable @code{vm-stunnel-program} must name it in order for POP/IMAP over SSL to work. The default value of this variable, @samp{"stunnel"}, should be sufficient if the program is installed in your normal command search path. For SSH, you must have the ssh program installed and the variable @code{vm-ssh-program} must name it in order for POP/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 POP/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. @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 POP @item 995 @tab for POP over SSL @item 143 @tab for IMAP @item 993 @tab for IMAP over SSL @end multitable @var{MAILBOX} is the name of the mailbox on the IMAP server. This should be @samp{"inbox"}, to access your default IMAP mailbox on the server. No @var{MAILBOX} component is needed for POP maildrops because 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 POP are @samp{pass}, @samp{rpop} and @samp{apop}. For @samp{pass}, the @var{PASSWORD} is sent to the server with the POP PASS command. For @samp{rpop}, the @var{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 @samp{apop}, an MD5 digest of the @var{PASSWORD} appended to the server time-stamp will be sent to the server with the 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. @vindex vm-imap-session-preauth-hook Acceptable values of @var{AUTH} for 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 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 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 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. @menu * POP Folders:: How to use mailboxes on POP servers * IMAP Folders:: How to use mail folders on IMAP servers @end menu @node POP Folders, IMAP Folders, Server Folders, Server Folders @unnumberedsubsec POP Folders @cindex POP @cindex message attributes @findex vm-visit-pop-folder The command @code{vm-visit-pop-folder} allows you to visit a POP mailbox as a folder. When you visit a POP folder, VM will download copies of the messages that it finds there for you to read. These messages are saved locally in the file system, 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 POP server will be removed when you save the changes with @code{vm-save-folder}. Message attributes (new, replied, filed, etc.) and labels cannot be stored on the POP server but they will be maintained in the local copy. This means that if you access the same 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 IMAP folders (@ref{IMAP Folders}) resident on an IMAP server. @vindex vm-pop-folder-alist In order for VM to know about 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 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 POP accounts in this definition. @node IMAP Folders,, POP Folders, Server Folders @unnumberedsubsec IMAP Folders @cindex IMAP @cindex message attributes @cindex message labels @findex vm-visit-imap-folder The command @code{vm-visit-imap-folder} allows you to visit an IMAP mailbox as a folder. The name of the IMAP mailbox should be input via the minibuffer in the format account-name:folder-name. Here, ``account-name'' is the name of an IMAP account declared in @code{vm-imap-account-alist} and ``folder-name'' is the name of an IMAP mailbox in this account. When you visit an IMAP folder, VM will download copies of the messages that it finds there for you to read. These messages are saved locally in a 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 local copy of the folder and the folder on the IMAP server when saved with @code{vm-save-folder}. Message attributes (new, replied, filed, etc.) are stored on the IMAP server and are also cached locally. Message labels are also stored on the IMAP server as user-defined permanent flags. (This assumes that the IMAP server has the ability to store user-defined permanent flags.) @vindex vm-imap-account-alist In order for VM to know about 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 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 IMAP server can be specified. For example, @code{becky:inbox} or @code{crickle:drafts}. @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{IMAP Synchronization} @unnumberedsubsec IMAP Synchronization The local copy and the folder on the 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 local copy based on the server data, (iii) expunging messages in the local copy that have been expunged on the server (through perhaps a concurrent access to the IMAP folder), and finally, (iv) retrieving any new messages on the server. The variable @code{vm-imap-sync-on-get} specifies whether such synchronization should be done as part of @code{vm-get-new-mail}. @vindex vm-imap-sync-on-get If the variable is set to nil then @code{vm-get-new-mail} simply retrieves any new messages. The local copy and the folder on the 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 local copy based on the server data, (iii) expunging messages in the local copy that have been expunged on the server (through perhaps a concurrent access to the IMAP folder), (iv) deleting the locally expunged messages on the server, 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. After fetching messages from the IMAP server into the local copy, it is possible to visit the local copy as if it were a normal folder. VM can operate on the local copy without contacting the server. This allows offline operation on the mail folders. When the IMAP server is connected again, one should do the @code{vm-imap-synchronize} command with a 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. @node Thunderbird Folders, Getting New Mail, Server 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 @code{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}. @node Getting New Mail, Crash Recovery, Thunderbird Folders, Starting Up @section Getting New Mail @findex vm-get-new-mail 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 POP folders, any newly arrived messages at the POP server will be incorporated into the local copy of the POP folder. @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 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. @node Crash Recovery,, Getting New Mail, Starting Up @section Crash Recovery @cindex message attributes @cindex message labels @cindex autosave When Emacs crashes, its last action before dying is to try to write out an autosave file that contains changes to files that you were editing. VM folders are file buffers inside Emacs, so folders are autosaved also. Changes, with regard to VM folders, 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 autosave 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. When you visit a folder, VM checks for the existence of an autosave file that has been modified more recently than the folder file. If such an autosave 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 autosave file and visit the folder in 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 autosave file. VM will not retrieve new mail for a folder that is in read-only mode. VM also skips summary generation and 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 @kbd{RET}. (Emacs's built-in @kbd{recover-file} command is not recommended for this purpose because VM is unable to obtain reliable data regarding the mail folders from Emacs.) Emacs will then display a detailed directory listing showing the folder file and the autosave file and ask if you want to recover from the autosave file. A good rule of thumb is to answer ``yes'' if the autosave file is larger than the folder file. If the autosave file is significantly smaller, Emacs may not have completed writing the autosave file. Or it could be that the smaller autosave 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 autosave file was truncated. Assuming you answered ``yes'', the folder buffer's contents will be replaced by the contents of the autosave 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. @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. 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 @kbd{RET}. VM will select this message. Instead of pressing @kbd{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 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 @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. * Viewing:: Viewing the current message. * MIME Messages:: Using VM's MIME display features. @end menu @node Previewing, Viewing, 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 Typing @kbd{t} (@code{vm-expose-hidden-headers}) makes VM toggle between exposing and hiding headers that would ordinarily be hidden. @node Viewing, MIME Messages, Previewing, Reading Messages @section Viewing @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 @kbd{b} or @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. You can ``unread'' a message (so to speak) by typing @kbd{U} (@code{vm-unread-message}). The current message will be flagged unread. @cindex longlines.el @cindex filling paragraphs @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 @code{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 MIME Messages,, Viewing, Reading Messages @section Reading MIME Messages @cindex MIME @vindex vm-display-using-mime @dfn{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 MIME encoded messages and display them as specified by the various 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 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 MIME is a set of transfer encodings used to ensure error free transport, and a set of content types. VM understands the two standard 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 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 MIME objects. @menu * Viewing MIME:: Decoding MIME for viewing * Attachments:: Operating on MIME attachments * Internal display:: Viewing attachments internally in Emacs * External display:: Viewing attachments with external viewers * Displaying images:: Using Emacs facilities for images * MIME type conversion:: Converting external attachments to internal * Character sets:: MIME character sets * multipart/alternative:: MIME content in alternative formats * Bad MIME:: Dealing with bad MIME @end menu @node Viewing MIME, Attachments,, MIME Messages @unnumberedsubsec Viewing 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 The first step in displaying a 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 MIME decoding. @vindex vm-mime-button-format-alist 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 @code{vm-mime-button-format-alist} determines the format of the text in those buttons. @node Attachments, Internal display, Viewing MIME, MIME Messages @unnumberedsubsec Operating on MIME attachments @cindex attachments @kindex $ | @kindex $ d @kindex $ RET @kindex $ s @kindex $ w @kindex $ p @kindex $ d @kindex $ e @vindex vm-auto-displayed-mime-content-types @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-attach-object-from-message After decoding you will see either the decoded MIME objects or button lines that must be activated to attempt display of the MIME object. The variable @code{vm-auto-displayed-mime-content-types} specifies the types that are displayed immediately. Its value should be a 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. To activate a button, either click the middle mouse button over it, or move the cursor to the line and press RET. If you are running under a window system, you can use the right mouse button over a MIME button to display a menu of actions you can take on the MIME object. If you prefer using keyboard commands, you can save the 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{$ 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 $ 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-attach-object-from-message} @end multitable @vindex vm-mime-delete-after-saving @vindex vm-mime-attachment-save-directory @vindex vm-mime-confirm-delete The 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 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 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-mime-save-all-attachments @findex vm-mime-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-mime-save-all-attachments} and @code{vm-mime-delete-all-attachments} can be used to save or delete @i{all} the attachments in a message. An "attachment" in this context is any MIME part that has "attachment" as its content-disposition or simply has a file name. In addition, all 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, MIME Messages @unnumberedsubsec Internal display of MIME attachments @vindex vm-auto-displayed-mime-content-types A value of t for @code{vm-auto-displayed-mime-content-types} means that all types should be displayed immediately. A nil value means never display MIME objects immediately; only use buttons. If the value of @code{vm-auto-displayed-mime-content-types} is a list, it should be a list of strings, which should all be MIME types or type/subtype pairs. Example: @example (setq vm-auto-displayed-mime-content-types '("text" "image/jpeg")) @end example @noindent If a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. The example above specifies that all text types are displayed immediately, but only JPEG images are displayed this way. @vindex vm-auto-displayed-mime-content-type-exceptions The variable @code{vm-auto-displayed-mime-content-type-exceptions} should be a list of MIME content types that should not be displayed immediately after decoding. This variable acts as an exception list for @code{vm-auto-displayed-mime-content-types}; all types listed there will be auto-displayed except those in the exception list. The value of @code{vm-auto-displayed-mime-content-type-exceptions} should be either nil or a list of strings. The strings should all be types or type/subtype pairs. Example: @example (setq vm-auto-displayed-mime-content-type-exceptions '("text/html")) @end example @noindent Again, if a top-level type is listed without a subtype, all subtypes of that type are assumed to be included. @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-auto-displayed-mime-content-types} its value should be a list of 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 errors if Emacs can't handle them. A @code{nil} value means never display MIME objects internally, which means VM will have to run an external viewer to display all MIME objects. 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 @noindent If a top-level type is listed without a subtype, 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 HTML @vindex vm-mime-text/html-handler The HTML content in text/html MIME parts can be displayed in Emacs using a variety of packages. VM knows about: @multitable @columnfractions .15 .85 @item lynx @tab The lynx browser used externally to convert HTML to plain text @item w3m @tab The w3m browser used externally to convert HTML to plain text @item emacs-w3 @tab The Emacs/W3 browser used internally in Emacs @item emacs-w3m @tab The 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 HTML content internally. @node External display, Displaying images, Internal display, MIME Messages @unnumberedsubsec External display of 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 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{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 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{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 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" "netscape") ("image/gif" "xv") ("image/jpeg" "xv") ("video/mpeg" "mpeg_play") ("video" "xanim") ) ) @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 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 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 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, MIME type conversion, External display, 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-auto-displayed-mime-content-types Assuming that a particular image type, say @samp{tiff} is available, you can include its 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 MIME type to the variable @code{vm-auto-displayed-mime-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 ImageMagick graphics manipulation software. You can install ImageMagick on your system and specify the location of its @code{identify} and @code{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 MIME type conversion, Character sets, Displaying images, MIME Messages @unnumberedsubsec 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 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, MIME type conversion, MIME Messages @unnumberedsubsec MIME character sets For text type messages, 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 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. 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. This variable is useful for making bogus, unregistered character sets that are slight variants of ISO-8859-1 visible. 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 @noindent Messages sent using such character sets would normally be considered undisplayable by VM, and a button would be displayed that offers to save the message body to a file. Please note that for character sets listed in this variable, VM's MIME decoding is bypassed. So don't add charsets like \"utf-8\" that require additional decoding. @vindex vm-mime-charset-converter-alist 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 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 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. Example: @example (setq vm-mime-charset-converter-alist '( ("utf-8" "iso-2022-jp" "iconv -f utf-8 -t iso-2022-jp") ) ) @end example The first matching list element will be used. @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 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, Bad MIME, Character sets, MIME Messages @unnumberedsubsec MIME multipart/alternative 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 multipart/alternative. The idea is that the sender might have different 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 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-select-method To control how VM displays multipart/alternative messages, you must set the variable @code{vm-mime-alternative-select-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. The value can also be a list of the form @example (favorite TYPE ...) @end example with the first element of the list being the symbol @code{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 instead of the symbol @code{favorite}, @code{favorite-internal} is used then the first TYPE that matches an alternative that can be displayed internally will be chosen. @findex vm-mime-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 'vm-mime-nuke-alternative-text/html' command. @node Bad MIME, , multipart/alternative, MIME Messages @unnumberedsubsec Dealing with bad MIME @vindex vm-infer-mime-types Some mailers incorrectly use the generic @samp{application/octet-stream} type when sending files that really have a specific 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. If the variable @code{vm-infer-mime-types} is set non-@code{nil}, VM will attempt to use the filename sent with a MIME attachment to guess an attachment's type if the attachment is of type @samp{application/octet-stream}. @node Sending Messages, Saving Messages, Reading Messages, Top @chapter Sending Messages When sending messages from within VM, you will be using the standard Mail major mode provided with GNU Emacs, plus some extensions added by VM. @xref{Mail Mode,,,emacs, the GNU Emacs Manual}. However, mail composition buffers created by VM 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 to 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 @item C-c C-a (@code{vm-mime-attach-file}) Attaches a file to the composition. When you send the message, VM will insert the file and 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 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-mime-attach-message}) Attaches a mail message to the composition. If invoked with a prefix argument, the name of a folder 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 MIME digest. @kindex C-c C-b @item C-c C-b (@code{vm-mime-attach-buffer}) Attaches an Emacs buffer to the composition. @findex vm-mime-encode-composition @kindex C-c C-e @item C-c C-e (@code{vm-mime-encode-composition}) Encodes the composition using 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 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. @findex vm-postpone-composition @kindex C-c C-d @item C-c C-d (@code{vm-postpone-composition}) Postpones the current composition. The message is stored in the folder specified in @code{vm-postponed-folder}. You can continue composing of messages by visiting @code{vm-postponed-folder}, selecting a massage and @key{m} or by directly calling the function on any message in any folder @kbd{M-x vm-continue-postponed-message}. When called with a prefix argument @code{vm-postpone-composition} will ask you for the folder to save the draft to, i.e. you might also save it to your inbox. @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. * MIME Composition:: Sending a message using MIME attachments. * Replying:: Describes the various ways to reply to a message. * Forwarding Messages:: How to forward a message to a third party. @end menu @node Sending Options, MIME Composition, 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-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.) 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'', ``In-Reply-To'' 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-mesasge-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 MIME Composition, Replying, Sending Options, Sending Messages @section MIME Composition @vindex vm-send-using-mime To use VM's MIME composition features, you must have @code{vm-send-using-mime} set to a non-@code{nil} value. With MIME composition enabled, VM will allow you to add file attachments to your composition and will analyze your message when you send it and MIME encode it as necessary. @menu * MIME attachments:: Sending a message using MIME attachments. * MIME characters:: Sending a message with MIME-encoded characters. * MIME headers:: Sending a message with MIME-encoded headers. * MIME preview:: Previewing a MIME message before sending. @end menu @node MIME attachments, MIME characters, MIME Composition, MIME Composition, @unnumberedsec MIME attachments @kindex C-c C-a To attach a file to your composition, use @kbd{C-c C-a} (@code{vm-mime-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. The attachment will be represented in the composition as a tag line like this [ATTACHMENT ~/sounds/chronophasia_scream.au, audio/basic] You can type text before and after this tag and it will appear before or after the text in the final 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. 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 MIME object gives a mail reader a hint as to whether an 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 display 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 MIME types except @samp{application} and @samp{model} types. @kindex C-c C-b To attach a buffer instead of a file, use @kbd{C-c C-b} (normally bound to @code{vm-mime-attach-buffer}. You must not kill the buffer that you attach until after the message has been sent. @node MIME characters, MIME headers, MIME attachments, MIME Composition @unnumberedsec 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. 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 MIME-capable mail reader. @dfn{BASE64} is unreadable without a 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 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 MIME headers, MIME preview, MIME characters, MIME Composition @unnumberedsec 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 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 (@code{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 MIME preview, , MIME headers, MIME Composition @unnumberedsec MIME preview @kindex C-c C-p To preview what a 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 To encode a 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 MIME bodies back to tags and you can continue entering your composition. @node Replying, Forwarding Messages, MIME Composition, 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.) Citing message text is tricky business because the original message could be a MIME message with encoded text or formatted text along with embedded images and attachments. By default, VM uses its MIME displaying mechanism to extract the included text to be cited in replies. The cited text is then identical to what appears in the message Presentation buffer. @vindex vm-included-mime-types-list If the default MIME display is not enough for your purposes, you can set the variable @code{vm-included-mime-types-list} to selectively include the MIME type/subtype pairs that should be covered in the included text. The list should have @code{text/plain} at a minimum and could include other types such as @code{text/enriched} and @code{message/rfc822}. Setting the variable to nil returns you to the default behaviour. @vindex vm-include-text-from-presentation Another possible way to extract included text is to use the contents of the Presentation buffer. You can ask VM to do so by setting the variable @code{vm-include-text-from-presentation} to t. @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{Viewing}), 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 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,, Replying, Sending Messages @section Forwarding Messages VM has three commands to forward messages: @kbd{z} (@code{vm-forward-message}), @key{@@} (@code{vm-send-digest}) and @kbd{B} (@code{vm-resend-message}). @findex vm-forward-message @kindex z @vindex vm-forwarding-digest-type @vindex vm-forwarding-subject-format Typing @kbd{z} puts you into a VM Mail mode buffer just like @kbd{m}, except the current message appears as the body of the message in the VM Mail mode buffer. The forwarded message encapsulated as specified by the variable @code{vm-forwarding-digest-type}. Recognized values are @samp{"rfc934"}, @samp{"rfc1153"} and @samp{"mime"}. 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. @findex vm-send-digest @vindex vm-digest-send-type @kindex @@ The command @key{@@} (@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. @findex vm-resend-message @kindex B If you wish to forward a message and want to send it without the encapsulation used by @code{vm-forward-message}, use @kbd{B} (@code{vm-resend-message}). Instead of encapsulating the message, VM will use essentially the same message and headers and add a 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''. @vindex vm-forwarded-headers @vindex vm-unforwarded-header-regexp You can control which header lines are included in forwarded messages via the variables @code{vm-forwarded-headers} and @code{vm-unforwarded-header-regexp}. By default, both of these variables are nil, which means that all headers should be included. If @code{vm-unforwarded-header-regexp} is set to a regular expression then all the headers matching the regular expression are omitted in forwarded messages. If this variable is nil but @code{vm-forwarded-headers} is set to a list of headers, then only these headers are included in the forwarded messages. See the documentation of these variables for further information. @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. If @code{vm-save-message} is given a prefix argument @var{n}, the current message plus the next @var{n-1} messages are saved. If @var{n} is negative, the current message and the previous @var{n-1} messages are saved. Messages saved with @code{vm-save-message} are flagged ``filed''. @findex vm-save-message-to-imap-folder One can save messages to remote IMAP folders by @code{vm-save-message-to-imap-folder}; the name of the folder can be entered from the minibuffer. @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-imap-save-to-server @cindex IMAP A non-@code{nil} value of @code{vm-imap-save-to-server} means that messages from IMAP folders should be saved in other IMAP folders on the same server. Otherwise, the messages are saved to local folders. @vindex vm-folder-directory If you have a directory where you keep all your mail folders, you should set the variable @code{vm-folder-directory} to point to it. If this variable 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. The default value of @code{vm-folder-directory} is @code{~/Mail}. @vindex vm-auto-folder-alist Another aid to selecting folders in which to save mail is the variable @code{vm-auto-folder-alist}. The value of this variable should be a list of the form: @display ((@var{header-name} (@var{regexp} . @var{folder-name}) ...) ...) @end display 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. 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. The value of @var{folder-name} can be the absolute path name of a local folder, a relative path name -- relative to @code{vm-folder-directory} or the @code{default-directory} of the currently visited folder -- or the maildrop specification of an IMAP folder. 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. @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} or @kbd{A} commands (see below). The variable @code{vm-delete-after-archiving} works like @code{vm-delete-after-saving} but applies to the @kbd{A} (@code{vm-auto-archive-messages}) command instead. Other commands: @table @kbd @findex vm-save-message-sans-headers @kindex w @item w (@code{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-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. @node Editing Messages, Marking Messages, Deleting Messages, Top @chapter Editing Messages To edit a message, type @kbd{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. 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 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. 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. 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}. 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 @code{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. @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} or @code{vm-send-digest}. @item redistributed The message has been forwarded with the @code{vm-resend-message} command. @item replied The message has been replied to. @end table You can set and unset these attributes directly by using @kbd{a} (@code{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 autosave 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 autosave file will contain no useful data pertaining to message attribute changes. The autosave 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 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 @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. 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 @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 To enable and disable threading, type @kbd{C-t} (@code{vm-toggle-threads-display}. In the summary buffer related messages are grouped together and the subject part of the summary listings of messages are indented to show hierarchical relationships. Parent messages are displayed before their children and children are indented a default two spaces to the right for each level of descendence from their ancestors. The amount of indentation per level is controlled by the variable @code{vm-summary-thread-indent-level}. @vindex vm-thread-using-subject Message relationships are discovered by examining References, In-Reply-To, and Subject headers. The first two headers are more reliable sources of information but not all mailers provide them. If you don't want VM to use Subject headers, set the variable @code{vm-thread-using-subject} to @code{nil}. If you want VM to always display messages 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. Note that threading is really a specialized form of sorting, and so the value of the variable @code{vm-move-messages-physically} applies. @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 @kindex * The command @kbd{*} (@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 vm-summary-arrow to a string depicting the new arrow. You should set this variable before VM creates the summary buffer. @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. @item P indicator for a message with attachments. The variable @vindex vm-summary-attachment-indicator @code{vm-summary-attachment-indicator} is the inserted string, by default a @code{$}. @item p indicator for a postponed message. The variable @vindex vm-summary-postponed-indicator @code{vm-summary-postponed-indicator} is the inserted string, by default a @code{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!!!}. 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. 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. @node Virtual Folders, Frames and Windows, 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. A 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 named virtual folders. In order to visit a virtual folder with the @code{vm-visit-virtual-folder} (@kbd{V V}) command, a virtual folder must have an entry in vm-virtual-folder-alist. 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 POP/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 from one of the folders specified by the @var{FOLDER-NAME}s should be included in the virtual folder. Some @var{SELECTOR}s require an argument @var{ARG}; unless otherwise noted, @var{ARG} may be omitted. @table @code @item any matches any message. @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. @item outgoing matches message if your are the author of it, i.e. if the author matches @code{vm-summary-uninteresting-senders} @item in-bbdb matches if the addresses from the message are in the BBDB. With an option first argument you might select the address class and with an optional second argument if only the first address should be checked. @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 text matches message if @var{ARG} matches any part of the text portion of the message; @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 header matches message if @var{ARG} matches any part of the header 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 spam-score matches message if its spam score is at least @var{ARG}. See @code{vm-vs-spam-score-headers} for configuration. @item spam-word matches message if it contains a word from @code{vm-spam-words-file} @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 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} or @code{vm-send-digest}. @item unforwarded matches message if it has not been forwarded using @code{vm-forward-message} or @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}. @item attachment matches if a message contains an attachment resp. its text matched @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. @item eval matches message if evaluating the sexpr @var{ARG} yields @code{t}. @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 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 in vm-mode and one of its argument selectors match the message. @item mail-mode matches the message if in mail-mode and one of its argument selectors match the message. @end table Here is an example that you may find useful as a template to create 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 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. Again, you visit virtual folders you have defined in @code{vm-virtual-folder-alist} with @kbd{V V}. 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 selector, they will be added to the virtual folder. These commands will signal an error when invoked if the current folder is 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 and from 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 @noindent If you want to change whether the currently visited virtual folder shares attributes with the underlying real folders, use the command @code{vm-toggle-virtual-mirror} (bound to @kbd{V M}). If the virtual folder is currently sharing attributes it will no longer be. If it is not sharing attributes with the underlying folders then it will be. The command @code{vm-create-virtual-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 RET pigs}, VM will create a folder containing only those messages that contain the string @samp{pigs} in the header. The command @code{vm-apply-virtual-folder} (bound to @kbd{V X}) tries the selectors of a named virtual folder against the messages of the current folder and creates a virtual folder containing the matching messages. The keys @kbd{V S} and @kbd{V A} invoke @code{vm-create-virtual-folder-same-subject} and @code{vm-create-virtual-folder-same-author} which create virtual folders containing all the messages in the current folder with the same subject or author as the current message. The keys @kbd{V O} @code{vm-virtual-omit-message} will omit a message from the virtual folder and @kbd{V U} @code{vm-virtual-update-folders} will force an update of the virtual folder. @kbd{M-x vm-virtual-check-selector-interactive} allows to test selectors interactively and will emit debug information when called with a prefix argument. Automatic marking of messages for deletion based on a selector can be achieved with @code{vm-virtual-auto-delete-message} for interactive use and the function and @code{vm-virtual-auto-delete-messages} when added to the VM hook @code{vm-arrived-messages-hook}. This can be quite handy for marking spam for deletion. @kbd{M-x vm-virtual-save-message} can be used to save messages to the folder corresponding to the first matching selector and the function @kbd{vm-virtual-auto-archive-messages} can file messages based on selectors (see also @code{vm-auto-archive-messages}). @node Frames and Windows, Toolbar, Virtual 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-frames To use VM's frame configuration features, the variable @code{vm-mutable-frames} must be set non-@code{nil}. This is the default. If @code{vm-mutable-frames} is set to nil VM will only use the current frame, and VM will not create, delete or resize frames. @vindex vm-mutable-windows To use window configurations, the variable @code{vm-mutable-windows} must be set non-@code{nil}. If @code{vm-mutable-windows} is set to nil, VM will only use the selected window, and will not create, delete or resize windows. @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 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. 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. To see what an existing configuration looks like, type @kbd{W W} which invokes @code{vm-apply-window-configuration}. @vindex vm-window-configuration-file 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 @samp{"~/.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 MIME message that needs decoding, the Helper button becomes the Decode MIME button. If the current folder has an autosave 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 autosave file. @item mime The Decode 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 VM uses Emacs' menu bar and pop-up menus when they are available to give you access to more of 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} entry to the existing menu bar instead of using the whole menu bar for its purposes. That single entry will have all the VM command submenus under it. To make VM use the whole menu bar, you must set variable @code{vm-use-menus} to a list of symbols. The symbols and the order in which they are listed determine which menus will be in the menu bar and how they are ordered. Valid symbol values are: @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 is actually a menu button that causes the menu bar to change to the global Emacs menu bar. On that menu bar you will find a VM button that will 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 is 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. Instead of defining VM specific faces, VM's face usage is controlled by customization variables that can point to faces. This allows you to use standard Emacs faces, or to create your own. So when you want to change which face is used, write code like this: @example (setq vm-summary-highlight-face 'bold-italic) @end example @noindent In the summary buffer, VM displays the summary entry for the current message using the face specified by the @code{vm-summary-highlight-face} variable. The value of this variable should be a symbol that names a face, or nil which means don't display the summary entry of the current message in a special way. @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. @vindex vm-highlighted-header-regexp @vindex vm-highlighted-header-face In the folder 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. @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}. Searching for URLs in a large message can take a long time. Since URLs often occur near the beginning and near the end of messages, VM offers a way to search just those parts of a message for URLs. 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 URLs. @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 MIME objects. @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. @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 URL in the body of a message, that 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 URL, a menu of Web browsers is produced. Otherwise the normal VM mode specific menu is produced. @end table In mail composition buffers only mouse button-3 is affected. Context sensitive menus are produced when that button is clicked. @node Hooks, Bugs, 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-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 @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. MIME decoding. @item vm-quit-hook @vindex vm-quit-hook List of hook functions to run when you quit VM. This applies to any VM quit command. @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 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 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 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 Bugs, History and Administration, Hooks, 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 POP/IMAP spool files or POP/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 History and Administration, Internals, Bugs, 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 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 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 @code{vm@@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} 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 can be found at the Google Groups site @uref{http://groups.google.com/group/gnu.emacs.vm.info/topics}. A second newsgroup @code{gnu.emacs.vm.bug} is dedicated to discussing bugs or potential bugs in VM. However, this is a place for discussion, not reporting bugs or getting them fixed. 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 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 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, planned for release on 10 April, 2010. @end itemize @node Internals, Concept Index, History and Administration, 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 @end menu @node Folder Internals, Message Internals , , Internals @section Folder Internals By default, VM stores mail folders in the Unix @code{mbox} format, described in the RFC 4155 specification of the Internet Engineering Task Force. In this format, 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 by a blank line. To make sure that such a line exists, VM adds its own header line 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. In addition to the Unix mbox format (which is called the @code{From_} format), VM also handles the MMDF format and two versions of the System V Unix format and the Emacs Rmail's Babyl format. The variable @code{vm-folder-type} stores the type of the folder being used. 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. This header line is used merely for speed of processing. If, for any reason, a VM folder is corrupted, it is safe to delete all the X-VM-v5-Data headers, and VM will generate them afresh when the folder is visited. The first message of the VM folder file contains additional headers that VM uses for remembering information between sessions. @itemize @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 X-VM-Last-Modified. @item X-VM-Message-Order. This header lists the order in which the messages should be listed. @item X-VM-Labels. This header lists the message labels that have been used in the folder. @item X-VM-VHeader. This header lists the visible headers that should be displayed in message listings. @item X-VM-Summary-Format. This header stores the format string for the summary lines. @item X-VM-POP-Retrieved. This header lists all the messages that have been retrieved from POP servers together with the identifying information for the POP servers. VM refrains from retrieving these messages again in future in order to avoid duplication. @item X-VM-IMAP-Retrieved. This header lists all the messages that have been retrieved from IMAP servers together with the identifying information for the IMAP servers. VM refrains from retrieving these messages again in future in order to avoid duplication. @end itemize 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 @code{vm-message-list}. A list of message data structures for all the messages in the buffer. @item @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 @code{vm-last-message-pointer}. Whenever the cursor is moved, the previous value of vm-message-pointer is remembered in this variable. @item @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 @code{vm-folder-access-method}. The method for accessing the server message store: 'pop for pop-folders as well as local folders retrieving messages from POP servers, 'imap for imap-folders as well as local folders retrieving messages from IMAP servers, and nil for all other folders. @item @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 IMAP server. @item @code{vm-virtual-folder-definition}. If the current folder is virtual, then this variable holds the data constituting its definition. @item @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 @code{vm-virtual-buffers}. A list of all the virtual folder buffers that the current buffer is involved in. @end itemize @node Message Internals, , Folder Internals, Internals @section Message Internals The message data structure is a vector containing various pieces of data: @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. @itemize @item start. The starting position of the message, at which a leading separator line begins. @item headers. The position in the folder buffer where the headers of the message start. @item vheaders. The position in the folder 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.) @item text. The position in the folder buffer where the text of the message starts. @item text-end. The position in the folder buffer where the text of the message ends @item end. The position in the folder buffer where the message ends. @end itemize @item Soft data. This vector contains other calculated data about the message. @itemize @item number. The message number as an integer. @item padded number. The message number as a padded string. @item mark. Flag that indicates if the message has been marked (via @code{vm-mark-message}). @item su-start. The position in the summary buffer where the summary line of the message starts. @item su-end. The position in the summary buffer where the summary line of the message ends. @item 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 interned in an obarray and represented by ``symbols''. This field stores the symbol representing the real message of the current message. @item reverse-link. Link to the previous message in the message list. @item 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}. @item message-id-number. The unique id of the message. @item buffer. The folder buffer of the message. @item thread-indentation. Indentation level of the message in its message thread. @item babyl-frob-flag. @item saved-virtual-attributes. Saved attributes if the message switched from unmirrored to mirrored. @item saved-virtual-mirror-data. Saved mirror data, if the message was switched from unmirrored to mirrored. @item virtual-summary. Summary for unmirrored virtual message. @item mime-layout. MIME layout information; types, ids, positions, etc of all MIME entities. @item mime-encoded-header-flag. Flag that indicates if the headers of the message are MIME encoded. @item su-summary-mouse-track-overlay. @item message-access-method. The access-method to be used for the message, inherited from its real folder. @end itemize @item Attributes. 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. @itemize @item new-flag. Flag to indicate if the message is ``new''. @item unread-flag. Flag to indicate if the message is unread. @item deleted-flag. Flag to indicate if the message has been deleted. @item filed-flag. Flag to indicate if the message has been filed. @item replied-flag. Flag to indicate if the message has been replied to. @item written-flag. Flag to indicate if the message has been saved. @item forwarded-flag. Flag to indicate if the message has been forwarded. @item edited-flag. Flag to indicate if the message has been edited. @item redistributed-flag. Flag to indicate if the message has been redistributed. @end itemize @item Cached Data. The data that is cached for the message and stored in the folder on disk as 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. @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. @item full-name. The full name of the author of the message. @item from. The email address of the author of the message. @item message-id. The unique id of the message. @item line-count. The number of lines in the message. @item subject. The subject string of the message. @item vheaders-regexp. A regular expression that can be used to find the start of the already ordered headers. @item to. Addresses of the recipients of the message in a comma separated string. @item to-names. The full names of the recipients in a comma separated string. Addresses are used if full names are not available. @item month-number. Numeric month of the sent date. @item sortable-datestring. Date string of the sent date for sorting purposes. @item sortable-subject. The subject string for sorting purposes. (Prefixes such as ``re:'' are removed.) @item summary. The summary string for the message. @item parent. The parent of the message in the message thread, which is another message data structure. @item references. Message IDs listed in the References header of the message. @item headers-to-be-retrieved. Flag that indicates whether the headers of the message have not been retrieved from the mail server (for POP or IMAP folders). @item body-to-be-retrieved. Flag that indicates whether the body of the message has not been retrieved from the mail server. @item pop-uidl. The UIDL id of the message on the POP server. @item imap-uid. The UID of the message on the IMAP server. @item imap-uid-validity. The UID-VALIDITY value of the message on the IMAP server. @item spam-score. The spam score of the message. @end itemize @item Mirror Data. Extra data shared by virtual messages if vm-virtual-mirror is non-nil. @itemize @item edit-buffer. If the message is being edited, this is the buffer being used. @item virtual-messages. List of virtual messages mirroring the current real message. @item stuff-flag. Flag to indicates if the attribute changes have been ``stuffed'' into the folder buffer. @item labels. List of labels attached to the message. @item label-string. The string of labels attached to the message. @item attribute-modflag. Flag to indicate if the attributes of the message have been modified since the last save. @end itemize @end itemize @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, License, Command Index, Top @unnumbered Variable Index @printindex vr @node License,, Variable 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.1.2/pixmaps/0002755000175000017500000000000011725175471014113 5ustar srivastasrivastavm-8.1.2/pixmaps/undelete-dn.xpm0000644000175000017500000000251511725175471017046 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.1.2/pixmaps/next-up.xpm0000644000175000017500000000252311725175471016241 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.1.2/pixmaps/quit-dn.xpm0000644000175000017500000000243411725175471016223 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.1.2/pixmaps/visit-dn.xpm0000644000175000017500000000251211725175471016374 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.1.2/pixmaps/recover-dn.xpm0000644000175000017500000000240111725175471016700 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.1.2/pixmaps/visit-up.xpm0000644000175000017500000000254311725175471016423 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.1.2/pixmaps/make-gtk-pixmaps.py0000755000175000017500000000120211725175471017640 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.1.2/pixmaps/previous-up.xpm0000644000175000017500000000254611725175471017144 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.1.2/pixmaps/mime-up.xpm0000644000175000017500000000246511725175471016217 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.1.2/pixmaps/next-dn.xpm0000644000175000017500000000247211725175471016221 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.1.2/pixmaps/forward-dn.xpm0000644000175000017500000000251411725175471016704 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.1.2/pixmaps/followup-dn.xpm0000644000175000017500000000251511725175471017110 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.1.2/pixmaps/autofile-up.xpm0000644000175000017500000000256511725175471017101 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.1.2/pixmaps/previous-dn.xpm0000644000175000017500000000251511725175471017115 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.1.2/pixmaps/mime-dn.xpm0000644000175000017500000000243411725175471016170 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.1.2/pixmaps/help-up.xpm0000644000175000017500000000246511725175471016220 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.1.2/pixmaps/forward-up.xpm0000644000175000017500000000254511725175471016733 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.1.2/pixmaps/undelete-up.xpm0000644000175000017500000000254611725175471017075 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.1.2/pixmaps/file-up.xpm0000644000175000017500000000256111725175471016204 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.1.2/pixmaps/getmail-dn.xpm0000644000175000017500000000253311725175471016663 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.1.2/pixmaps/mime-xx.xpm0000644000175000017500000000253111725175471016224 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.1.2/pixmaps/Makefile.in0000644000175000017500000000313411725175471016157 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@/vm 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.1.2/pixmaps/reply-dn.xpm0000644000175000017500000000251211725175471016371 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.1.2/pixmaps/print-dn.xpm0000644000175000017500000000251211725175471016372 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.1.2/pixmaps/gtk/0002755000175000017500000000000011725175471014700 5ustar srivastasrivastavm-8.1.2/pixmaps/gtk/undelete-dn.xpm0000644000175000017500000000166111725175471017634 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.1.2/pixmaps/gtk/next-up.xpm0000644000175000017500000000166711725175471017036 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.1.2/pixmaps/gtk/quit-dn.xpm0000644000175000017500000000160011725175471017002 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.1.2/pixmaps/gtk/visit-dn.xpm0000644000175000017500000000165611725175471017171 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.1.2/pixmaps/gtk/recover-dn.xpm0000644000175000017500000000154511725175471017475 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.1.2/pixmaps/gtk/visit-up.xpm0000644000175000017500000000170711725175471017211 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.1.2/pixmaps/gtk/previous-up.xpm0000644000175000017500000000171211725175471017723 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.1.2/pixmaps/gtk/mime-up.xpm0000644000175000017500000000163111725175471016776 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.1.2/pixmaps/gtk/next-dn.xpm0000644000175000017500000000163611725175471017007 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.1.2/pixmaps/gtk/forward-dn.xpm0000644000175000017500000000166011725175471017472 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.1.2/pixmaps/gtk/followup-dn.xpm0000644000175000017500000000166111725175471017676 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.1.2/pixmaps/gtk/autofile-up.xpm0000644000175000017500000000173111725175471017660 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.1.2/pixmaps/gtk/previous-dn.xpm0000644000175000017500000000166111725175471017703 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.1.2/pixmaps/gtk/mime-dn.xpm0000644000175000017500000000160011725175471016747 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.1.2/pixmaps/gtk/help-up.xpm0000644000175000017500000000163111725175471016777 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.1.2/pixmaps/gtk/forward-up.xpm0000644000175000017500000000171111725175471017512 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.1.2/pixmaps/gtk/undelete-up.xpm0000644000175000017500000000171211725175471017654 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.1.2/pixmaps/gtk/file-up.xpm0000644000175000017500000000172511725175471016772 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.1.2/pixmaps/gtk/getmail-dn.xpm0000644000175000017500000000167711725175471017460 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.1.2/pixmaps/gtk/mime-xx.xpm0000644000175000017500000000167511725175471017021 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.1.2/pixmaps/gtk/reply-dn.xpm0000644000175000017500000000165611725175471017166 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.1.2/pixmaps/gtk/print-dn.xpm0000644000175000017500000000165611725175471017167 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.1.2/pixmaps/gtk/help-dn.xpm0000644000175000017500000000160011725175471016750 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.1.2/pixmaps/gtk/followup-up.xpm0000644000175000017500000000171211725175471017716 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.1.2/pixmaps/gtk/quit-up.xpm0000644000175000017500000000163111725175471017031 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.1.2/pixmaps/gtk/autofile-dn.xpm0000644000175000017500000000170011725175471017631 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.1.2/pixmaps/gtk/file-dn.xpm0000644000175000017500000000167411725175471016752 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.1.2/pixmaps/gtk/getmail-up.xpm0000644000175000017500000000173011725175471017471 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.1.2/pixmaps/gtk/delete-up.xpm0000644000175000017500000000171011725175471017307 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.1.2/pixmaps/gtk/reply-up.xpm0000644000175000017500000000170711725175471017206 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.1.2/pixmaps/gtk/print-up.xpm0000644000175000017500000000170711725175471017207 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.1.2/pixmaps/gtk/compose-dn.xpm0000644000175000017500000000166011725175471017473 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.1.2/pixmaps/gtk/recover-up.xpm0000644000175000017500000000157611725175471017524 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.1.2/pixmaps/gtk/delete-dn.xpm0000644000175000017500000000165711725175471017276 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.1.2/pixmaps/gtk/compose-up.xpm0000644000175000017500000000171111725175471017513 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.1.2/pixmaps/help-dn.xpm0000644000175000017500000000243411725175471016171 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.1.2/pixmaps/followup-up.xpm0000644000175000017500000000254611725175471017137 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.1.2/pixmaps/quit-up.xpm0000644000175000017500000000246511725175471016252 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.1.2/pixmaps/autofile-dn.xpm0000644000175000017500000000253411725175471017052 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.1.2/pixmaps/mime/0002755000175000017500000000000011725175471015042 5ustar srivastasrivastavm-8.1.2/pixmaps/mime/application.xpm0000644000175000017500000000132311725175471020070 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.1.2/pixmaps/mime/message.xpm0000644000175000017500000000135111725175471017212 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.1.2/pixmaps/mime/text.xpm0000644000175000017500000000240111725175471016547 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.1.2/pixmaps/mime/image.xpm0000644000175000017500000000127211725175471016652 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.1.2/pixmaps/mime/audio.xpm0000644000175000017500000000132511725175471016670 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.1.2/pixmaps/mime/video.xpm0000644000175000017500000000127211725175471016676 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.1.2/pixmaps/mime/multipart.xpm0000644000175000017500000000240211725175471017605 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.1.2/pixmaps/file-dn.xpm0000644000175000017500000000253011725175471016155 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.1.2/pixmaps/getmail-up.xpm0000644000175000017500000000256411725175471016712 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.1.2/pixmaps/delete-up.xpm0000644000175000017500000000254411725175471016530 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.1.2/pixmaps/reply-up.xpm0000644000175000017500000000254311725175471016420 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.1.2/pixmaps/print-up.xpm0000644000175000017500000000254311725175471016421 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.1.2/pixmaps/compose-dn.xpm0000644000175000017500000000251411725175471016705 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.1.2/pixmaps/recover-up.xpm0000644000175000017500000000243211725175471016727 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.1.2/pixmaps/delete-dn.xpm0000644000175000017500000000251311725175471016501 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.1.2/pixmaps/compose-up.xpm0000644000175000017500000000254511725175471016734 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.1.2/src/0002755000175000017500000000000011725175471013221 5ustar srivastasrivastavm-8.1.2/src/qp-decode.c0000644000175000017500000000427111725175471015230 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.1.2/src/base64-encode.c0000644000175000017500000000244211725175471015704 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.1.2/src/qp-encode.c0000644000175000017500000000257611725175471015250 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.1.2/src/vm-mail0000755000175000017500000000217511725175471014514 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.1.2/src/Makefile.in0000644000175000017500000000231411725175471015264 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.1.2/src/base64-decode.c0000644000175000017500000000256111725175471015674 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.1.2/example.vm0000644000175000017500000002702211725175471014432 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.1.2/configure.ac0000644000175000017500000002165111725175471014723 0ustar srivastasrivasta# configure.ac --- configuration setup for VM # Author: Robert Widhopf-Fenk # Copyright (C) 2006-2007 # 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.1.2/COPYING0000644000175000017500000004310311725175471013464 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.1.2/Makefile.in0000644000175000017500000000365111725175471014502 0ustar srivastasrivasta@SET_MAKE@ # location of required programms BZR = bzr --no-plugins TAR = @TAR@ RM = @RM@ XARGS = @XARGS@ prefix = @prefix@ INSTALL = @INSTALL@ SUBDIRS = lisp info src pixmaps ############################################################################## .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: @for i in $(SUBDIRS) ; do ($(MAKE) -C $$i install) || exit 1; 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 vm-8.1.2/configure0000755000175000017500000025651311725175471014353 0ustar srivastasrivasta#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.59 for VM 8.1.2. # # Report bugs to . # # Copyright (C) 2003 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) 2006-2007 Robert Widhopf-Fenk ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; 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 # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # 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 # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. 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 ;; 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 { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 { (exit 1); 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 sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # 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'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH # Name of the host. # hostname on some systems (SVR3.2, Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` exec 6>&1 # # Initializations. # ac_default_prefix=/usr/local ac_config_libobj_dir=. cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= SHELL=${CONFIG_SHELL-/bin/sh} # Maximum number of lines to put in a shell here document. # This variable seems obsolete. It should probably be removed, and # only ac_max_sed_lines should be used. : ${ac_max_here_lines=38} # Identity of this package. PACKAGE_NAME='VM' PACKAGE_TARNAME='vm' PACKAGE_VERSION='8.1.2' PACKAGE_STRING='VM 8.1.2' PACKAGE_BUGREPORT='vm@lists.launchpad.net' ac_unique_file="configure.ac" ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS SET_MAKE INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA LN_S RM LS MKDIR GREP XARGS TAR MAKEINFO TEXI2DVI EMACS_PROG lispdir pixmapdir EMACS_FLAVOR EMACS_VERSION FLAGS info_dir OTHERDIRS PACKAGEDIR SYMLINKS LINKPATH LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. ac_init_help= ac_init_version=false # 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. bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datadir='${prefix}/share' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' libdir='${exec_prefix}/lib' includedir='${prefix}/include' oldincludedir='/usr/include' infodir='${prefix}/info' mandir='${prefix}/man' ac_prev= 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 ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_option in -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 | --data | --dat | --da) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ | --da=*) datadir=$ac_optarg ;; -disable-* | --disable-*) ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` eval "enable_$ac_feature=no" ;; -enable-* | --enable-*) ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid feature name: $ac_feature" >&2 { (exit 1); exit 1; }; } ac_feature=`echo $ac_feature | sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "enable_$ac_feature='$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 ;; -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 ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst \ | --locals | --local | --loca | --loc | --lo) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* \ | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) 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 ;; -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_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package| sed 's/-/_/g'` case $ac_option in *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; *) ac_optarg=yes ;; esac eval "with_$ac_package='$ac_optarg'" ;; -without-* | --without-*) ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid package name: $ac_package" >&2 { (exit 1); exit 1; }; } ac_package=`echo $ac_package | sed 's/-/_/g'` eval "with_$ac_package=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 ;; -*) { echo "$as_me: error: unrecognized option: $ac_option Try \`$0 --help' for more information." >&2 { (exit 1); exit 1; }; } ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 { (exit 1); exit 1; }; } ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` eval "$ac_envvar='$ac_optarg'" export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && 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'` { echo "$as_me: error: missing argument to $ac_option" >&2 { (exit 1); exit 1; }; } fi # Be sure to have absolute paths. for ac_var in exec_prefix prefix do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* | NONE | '' ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac done # Be sure to have absolute paths. for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ localstatedir libdir includedir oldincludedir infodir mandir do eval ac_val=$`echo $ac_var` case $ac_val in [\\/$]* | ?:[\\/]* ) ;; *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 { (exit 1); exit 1; }; };; esac 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 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 # 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 its parent. ac_confdir=`(dirname "$0") 2>/dev/null || $as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$0" : 'X\(//\)[^/]' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$0" | 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 if test "$ac_srcdir_defaulted" = yes; then { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 { (exit 1); exit 1; }; } else { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 { (exit 1); exit 1; }; } fi fi (cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 { (exit 1); exit 1; }; } srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` ac_env_build_alias_set=${build_alias+set} ac_env_build_alias_value=$build_alias ac_cv_env_build_alias_set=${build_alias+set} ac_cv_env_build_alias_value=$build_alias ac_env_host_alias_set=${host_alias+set} ac_env_host_alias_value=$host_alias ac_cv_env_host_alias_set=${host_alias+set} ac_cv_env_host_alias_value=$host_alias ac_env_target_alias_set=${target_alias+set} ac_env_target_alias_value=$target_alias ac_cv_env_target_alias_set=${target_alias+set} ac_cv_env_target_alias_value=$target_alias # # 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.1.2 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 \`..'] _ACEOF cat <<_ACEOF 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] --datadir=DIR read-only architecture-independent data [PREFIX/share] --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] --infodir=DIR info documentation [PREFIX/info] --mandir=DIR man documentation [PREFIX/man] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of VM 8.1.2:";; 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-pixmapdir=DIR where to install pixmap 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 fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. ac_popdir=`pwd` for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d $ac_dir || continue ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac cd $ac_dir # Check for guested configure; otherwise get Cygnus style 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 elif test -f $ac_srcdir/configure.ac || test -f $ac_srcdir/configure.in; then echo $ac_configure --help else echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi cd $ac_popdir done fi test -n "$ac_init_help" && exit 0 if $ac_init_version; then cat <<\_ACEOF VM configure 8.1.2 generated by GNU Autoconf 2.59 Copyright (C) 2003 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) 2006-2007 Robert Widhopf-Fenk _ACEOF exit 0 fi exec 5>config.log cat >&5 <<_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.1.2, which was generated by GNU Autoconf 2.59. Invocation command line was $ $0 $@ _ACEOF { 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` hostinfo = `(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=. echo "PATH: $as_dir" done } >&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_sep= 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=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; 2) ac_configure_args1="$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 ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" # Get rid of the leading space. ac_sep=" " ;; esac done done $as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } $as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export 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: Be sure not to use single quotes in there, as some shells, # such as our DU 5.0 friend, will then `close' the trap. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo cat <<\_ASBOX ## ---------------- ## ## Cache variables. ## ## ---------------- ## _ASBOX echo # The following way of writing the cache mishandles newlines in values, { (set) 2>&1 | case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in *ac_space=\ *) sed -n \ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" ;; *) sed -n \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } echo cat <<\_ASBOX ## ----------------- ## ## Output variables. ## ## ----------------- ## _ASBOX echo for ac_var in $ac_subst_vars do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo if test -n "$ac_subst_files"; then cat <<\_ASBOX ## ------------- ## ## Output files. ## ## ------------- ## _ASBOX echo for ac_var in $ac_subst_files do eval ac_val=$`echo $ac_var` echo "$ac_var='"'"'$ac_val'"'"'" done | sort echo fi if test -s confdefs.h; then cat <<\_ASBOX ## ----------- ## ## confdefs.h. ## ## ----------- ## _ASBOX echo sed "/^$/d" confdefs.h | sort echo fi test "$ac_signal" != 0 && echo "$as_me: caught signal $ac_signal" echo "$as_me: exit $exit_status" } >&5 rm -f core *.core && rm -rf conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h # AIX cpp loses on an empty file, so make sure it contains at least a newline. echo >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 # Let the site file select an alternate cache file if it wants to. # Prefer explicitly selected file to automatically selected ones. if test -z "$CONFIG_SITE"; then if test "x$prefix" != xNONE; then CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" else CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi fi for ac_site_file in $CONFIG_SITE; do if test -r "$ac_site_file"; then { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" 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. if test -f "$cache_file"; then { echo "$as_me:$LINENO: loading cache $cache_file" >&5 echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . $cache_file;; *) . ./$cache_file;; esac fi else { echo "$as_me:$LINENO: creating cache $cache_file" >&5 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 `(set) 2>&1 | sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; 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,) { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 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 { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 echo "$as_me: former value: $ac_old_val" >&2;} { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 echo "$as_me: current value: $ac_new_val" >&2;} ac_cache_corrupted=: fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) ac_arg=$ac_var=`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. *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 echo "$as_me: error: changes in the environment can compromise the build" >&2;} { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} { (exit 1); exit 1; }; } fi 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: echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF all: @echo 'ac_maketemp="$(MAKE)"' _ACEOF # GNU make sometimes prints "make[1]: Entering...", which would confuse us. eval `${MAKE-make} -f conftest.make 2>/dev/null | grep temp=` if test -n "$ac_maketemp"; then eval ac_cv_prog_make_${ac_make}_set=yes else eval ac_cv_prog_make_${ac_make}_set=no fi rm -f conftest.make fi if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 SET_MAKE= else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}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 { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&5 echo "$as_me: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&2;} { (exit 1); exit 1; }; } fi ac_config_guess="$SHELL $ac_aux_dir/config.guess" ac_config_sub="$SHELL $ac_aux_dir/config.sub" ac_configure="$SHELL $ac_aux_dir/configure" # This should be Cygnus configure. # 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. echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6 if test -z "$INSTALL"; then if test "${ac_cv_path_install+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$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 ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi done done ;; esac done 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. We don't cache a # path for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the path is relative. INSTALL=$ac_install_sh fi fi echo "$as_me:$LINENO: result: $INSTALL" >&5 echo "${ECHO_T}$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' echo "$as_me:$LINENO: checking whether ln -s works" >&5 echo $ECHO_N "checking whether ln -s works... $ECHO_C" >&6 LN_S=$as_ln_s if test "$LN_S" = "ln -s"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 else echo "$as_me:$LINENO: result: no, using $LN_S" >&5 echo "${ECHO_T}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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_path_RM+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_RM="$as_dir/$ac_word$ac_exec_ext" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_path_RM" && ac_cv_path_RM="/bin/rm" ;; esac fi RM=$ac_cv_path_RM if test -n "$RM"; then echo "$as_me:$LINENO: result: $RM" >&5 echo "${ECHO_T}$RM" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # Extract the first word of "ls", so it can be a program name with args. set dummy ls; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_path_LS+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_LS="$as_dir/$ac_word$ac_exec_ext" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_path_LS" && ac_cv_path_LS="/bin/ls" ;; esac fi LS=$ac_cv_path_LS if test -n "$LS"; then echo "$as_me:$LINENO: result: $LS" >&5 echo "${ECHO_T}$LS" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # Extract the first word of "mkdir", so it can be a program name with args. set dummy mkdir; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_path_MKDIR+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_MKDIR="$as_dir/$ac_word$ac_exec_ext" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_path_MKDIR" && ac_cv_path_MKDIR="/bin/mkdir" ;; esac fi MKDIR=$ac_cv_path_MKDIR if test -n "$MKDIR"; then echo "$as_me:$LINENO: result: $MKDIR" >&5 echo "${ECHO_T}$MKDIR" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi # Extract the first word of "grep", so it can be a program name with args. set dummy grep; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_path_GREP+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_path_GREP="$as_dir/$ac_word$ac_exec_ext" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done test -z "$ac_cv_path_GREP" && ac_cv_path_GREP="/bin/grep" ;; esac fi GREP=$ac_cv_path_GREP if test -n "$GREP"; then echo "$as_me:$LINENO: result: $GREP" >&5 echo "${ECHO_T}$GREP" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_XARGS+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_XARGS="xargs" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi XARGS=$ac_cv_prog_XARGS if test -n "$XARGS"; then echo "$as_me:$LINENO: result: $XARGS" >&5 echo "${ECHO_T}$XARGS" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi if test "x${XARGS}" = "x" ; then { echo "$as_me:$LINENO: WARNING: *** No xargs program found." >&5 echo "$as_me: WARNING: *** No xargs program found." >&2;} { echo "$as_me:$LINENO: WARNING: *** make clean/tarball will not work." >&5 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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_TAR+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_TAR="$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi TAR=$ac_cv_prog_TAR if test -n "$TAR"; then echo "$as_me:$LINENO: result: $TAR" >&5 echo "${ECHO_T}$TAR" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$TAR" && break done if test "x${TAR}" = "xtar" ; then echo "$as_me:$LINENO: checking that tar is GNU tar" >&5 echo $ECHO_N "checking that tar is GNU tar... $ECHO_C" >&6 ${TAR} --version > /dev/null 2>&1 || TAR= if test "x${TAR}" = "x" ; then echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 else echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 fi fi if test "x${TAR}" = "x" ; then { echo "$as_me:$LINENO: WARNING: *** No GNU tar program found." >&5 echo "$as_me: WARNING: *** No GNU tar program found." >&2;} { echo "$as_me:$LINENO: WARNING: *** Some targets will be unavailable." >&5 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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_MAKEINFO+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_MAKEINFO="makeinfo" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi MAKEINFO=$ac_cv_prog_MAKEINFO if test -n "$MAKEINFO"; then echo "$as_me:$LINENO: result: $MAKEINFO" >&5 echo "${ECHO_T}$MAKEINFO" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi if test "x${MAKEINFO}" = "x" ; then { echo "$as_me:$LINENO: WARNING: *** No makeinfo program found." >&5 echo "$as_me: WARNING: *** No makeinfo program found." >&2;} { echo "$as_me:$LINENO: WARNING: *** Info files will not be built." >&5 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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_TEXI2DVI+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_TEXI2DVI="texi2dvi" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi TEXI2DVI=$ac_cv_prog_TEXI2DVI if test -n "$TEXI2DVI"; then echo "$as_me:$LINENO: result: $TEXI2DVI" >&5 echo "${ECHO_T}$TEXI2DVI" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi if test "x${TEXI2DVI}" = "x" ; then { echo "$as_me:$LINENO: WARNING: *** No texi2dvi program found." >&5 echo "$as_me: WARNING: *** No texi2dvi program found." >&2;} { echo "$as_me:$LINENO: WARNING: *** DVI and PDF files will not be built." >&5 echo "$as_me: WARNING: *** DVI and PDF files will not be built." >&2;} fi # Check whether --with-emacs or --without-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 echo "$as_me:$LINENO: checking for $ac_word" >&5 echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 if test "${ac_cv_prog_EMACS_PROG+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&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 $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then ac_cv_prog_EMACS_PROG="$ac_prog" echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done fi fi EMACS_PROG=$ac_cv_prog_EMACS_PROG if test -n "$EMACS_PROG"; then echo "$as_me:$LINENO: result: $EMACS_PROG" >&5 echo "${ECHO_T}$EMACS_PROG" >&6 else echo "$as_me:$LINENO: result: no" >&5 echo "${ECHO_T}no" >&6 fi test -n "$EMACS_PROG" && break done fi; if test "x${EMACS_PROG}" = "x" ; then { { echo "$as_me:$LINENO: error: *** No Emacs program found." >&5 echo "$as_me: error: *** No Emacs program found." >&2;} { (exit 1); exit 1; }; } fi # EMACS TYPE ################################################## echo "$as_me:$LINENO: checking checking emacs-type of ${EMACS_PROG}" >&5 echo $ECHO_N "checking checking emacs-type of ${EMACS_PROG}... $ECHO_C" >&6 cat > conftest.el <&5 echo "${ECHO_T}${EMACS_FLAVOR}" >&6 # EMACS VERSION ############################################### echo "$as_me:$LINENO: checking checking emacs-version of ${EMACS_PROG}" >&5 echo $ECHO_N "checking checking emacs-version of ${EMACS_PROG}... $ECHO_C" >&6 cat > conftest.el <&5 echo "$as_me: error: Emacs version ${EMACS_VERSION} is too old, 21 is minimum!" >&2;} { (exit 1); exit 1; }; } fi # EMACS DEPENDENT SETTINGS #################################### # We may add a version check here ... echo "$as_me:$LINENO: result: ${EMACS_VERSION}" >&5 echo "${ECHO_T}${EMACS_VERSION}" >&6 # Copied from gnus aclocal.m4 # Check whether --with-lispdir or --without-lispdir was given. if test "${with_lispdir+set}" = set; then withval="$with_lispdir" lispdir=${withval} fi; echo "$as_me:$LINENO: checking where .elc files should go" >&5 echo $ECHO_N "checking where .elc files should go... $ECHO_C" >&6 if test -z "$lispdir"; then theprefix=$prefix if test "x$theprefix" = "xNONE"; then theprefix=$ac_default_prefix fi datadir="\$(prefix)/share" if test "$EMACS_FLAVOR" = "xemacs"; then datadir="\$(prefix)/lib" lispdir="${datadir}/${EMACS_FLAVOR}/site-packages/lisp/vm" else lispdir="${datadir}/${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="${datadir}/${EMACS_FLAVOR}/site-lisp/vm" fi break fi done fi echo "$as_me:$LINENO: result: $lispdir" >&5 echo "${ECHO_T}$lispdir" >&6 # Check whether --with-pixmapdir or --without-pixmapdir was given. if test "${with_pixmapdir+set}" = set; then withval="$with_pixmapdir" pixmapdir=${withval} fi; echo "$as_me:$LINENO: checking where pixmaps should go" >&5 echo $ECHO_N "checking where pixmaps should go... $ECHO_C" >&6 if test -z "$pixmapdir"; then pixmapdir="${datadir}/vm" fi echo "$as_me:$LINENO: result: $pixmapdir" >&5 echo "${ECHO_T}$pixmapdir" >&6 # if test "x${EMACS_FLAVOR}" = "xemacs" ; then # PACKAGEDIR="${prefix}/share/emacs/site-lisp" # else # PACKAGEDIR="${HOME}/.xemacs/xemacs-packages" # fi echo "$as_me:$LINENO: checking which options to pass on to (X)Emacs" >&5 echo $ECHO_N "checking which options to pass on to (X)Emacs... $ECHO_C" >&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 echo "$as_me:$LINENO: result: $FLAGS" >&5 echo "${ECHO_T}$FLAGS" >&6 echo "$as_me:$LINENO: checking where the TeXinfo docs should go" >&5 echo $ECHO_N "checking where the TeXinfo docs should go... $ECHO_C" >&6 if test "$infodir" = "\${prefix}/info"; then if test "$EMACS_FLAVOR" = "xemacs"; then info_dir="\$(prefix)/${thedir}/${EMACS_FLAVOR}/site-packages/info" else info_dir="\$(prefix)/share/info" fi else info_dir=$infodir fi echo "$as_me:$LINENO: result: $info_dir" >&5 echo "${ECHO_T}$info_dir" >&6 # Check whether --with-other-dirs or --without-other-dirs was given. if test "${with_other_dirs+set}" = set; then withval="$with_other_dirs" OTHERDIRS="${withval}" fi; echo "$as_me:$LINENO: checking otherdirs" >&5 echo $ECHO_N "checking otherdirs... $ECHO_C" >&6 cat > conftest.el <&5 echo "${ECHO_T}$OTHERDIRS" >&6 # is there a sane way to set this to a useful default? # Check whether --with-package-dir or --without-package-dir was given. if test "${with_package_dir+set}" = set; then withval="$with_package_dir" PACKAGEDIR="${withval}" fi; # Check whether --with-symlinks or --without-symlinks was given. if test "${with_symlinks+set}" = set; then withval="$with_symlinks" SYMLINKS="${withval}" else SYMLINKS="no" fi; # Check whether --with-linkpath or --without-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, don't put newlines in cache variables' values. # 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. { (set) 2>&1 | case `(ac_space=' '; set | grep ac_space) 2>&1` in *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 \ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" ;; esac; } | sed ' t clear : clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ : end' >>confcache if diff $cache_file confcache >/dev/null 2>&1; then :; else if test -w $cache_file; then test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" cat confcache >$cache_file else echo "not updating unwritable cache $cache_file" 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}' # VPATH may cause trouble with some makes, so we remove $(srcdir), # ${srcdir} and @srcdir@ 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[ ]*=/{ s/:*\$(srcdir):*/:/; s/:*\${srcdir}:*/:/; s/:*@srcdir@:*/:/; s/^\([^=]*=[ ]*\):*/\1/; s/:*$//; s/^[^=]*=[ ]*$//; }' fi # 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 we branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. cat >confdef2opt.sed <<\_ACEOF t clear : clear s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g t quote s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g t quote d : quote s,[ `~#$^&*(){}\\|;'"<>?],\\&,g s,\[,\\&,g s,\],\\&,g s,\$,$$,g p _ACEOF # We use echo to avoid assuming a particular line-breaking character. # The extra dot is to prevent the shell from consuming trailing # line-breaks from the sub-command output. A line-break within # single-quotes doesn't work because, if this script is created in a # platform that uses two characters for line-breaks (e.g., DOS), tr # would break. ac_LF_and_DOT=`echo; echo .` DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'` rm -f confdef2opt.sed ac_libobjs= ac_ltlibobjs= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_i=`echo "$ac_i" | sed 's/\$U\././;s/\.o$//;s/\.obj$//'` # 2. Add them. ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext" ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : ${CONFIG_STATUS=./config.status} ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 echo "$as_me: creating $CONFIG_STATUS" >&6;} cat >$CONFIG_STATUS <<_ACEOF #! $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} _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF ## --------------------- ## ## M4sh Initialization. ## ## --------------------- ## # Be Bourne compatible if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then emulate sh NULLCMD=: # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then set -o posix fi DUALCASE=1; export DUALCASE # for MKS sh # Support unset when possible. if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then as_unset=unset else as_unset=false fi # Work around bugs in pre-3.0 UWIN ksh. $as_unset ENV MAIL MAILPATH PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. for as_var in \ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ LC_TELEPHONE LC_TIME do if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then eval $as_var=C; export $as_var else $as_unset $as_var fi done # Required to use basename. if expr a : '\(a\)' >/dev/null 2>&1; 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 # Name of the executable. as_me=`$as_basename "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)$' \| \ . : '\(.\)' 2>/dev/null || echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } /^X\/\(\/\/\)$/{ s//\1/; q; } /^X\/\(\/\).*/{ s//\1/; q; } s/.*/./; q'` # PATH needs CR, and LINENO needs CR and PATH. # 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 # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then echo "#! /bin/sh" >conf$$.sh echo "exit 0" >>conf$$.sh chmod +x conf$$.sh if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then PATH_SEPARATOR=';' else PATH_SEPARATOR=: fi rm -f conf$$.sh fi as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" || { # Find who we are. Look in the path if we contain no path at all # relative or not. 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 ;; 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 { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} { (exit 1); exit 1; }; } fi case $CONFIG_SHELL in '') as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for as_base in sh bash ksh sh5; do case $as_dir in /*) if ("$as_dir/$as_base" -c ' as_lineno_1=$LINENO as_lineno_2=$LINENO as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` test "x$as_lineno_1" != "x$as_lineno_2" && test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } CONFIG_SHELL=$as_dir/$as_base export CONFIG_SHELL exec "$CONFIG_SHELL" "$0" ${1+"$@"} fi;; esac done done ;; esac # Create $as_me.lineno as a copy of $as_myself, but with $LINENO # uniformly replaced by the line number. The first 'sed' inserts a # line-number line before each line; the second 'sed' does the real # work. The second script uses 'N' to pair each line-number line # with the numbered line, and appends trailing '-' during # substitution so that $LINENO is not a special case at line end. # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) sed '=' <$as_myself | sed ' N s,$,-, : loop s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, t loop s,-$,, s,^['$as_cr_digits']*\n,, ' >$as_me.lineno && chmod +x $as_me.lineno || { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} { (exit 1); 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 sensible to this). . ./$as_me.lineno # Exit status is that of the last command. exit } case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in *c*,-n*) ECHO_N= ECHO_C=' ' ECHO_T=' ' ;; *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; *) ECHO_N= ECHO_C='\c' ECHO_T= ;; esac if expr a : '\(a\)' >/dev/null 2>&1; then as_expr=expr else as_expr=false fi rm -f conf$$ conf$$.exe conf$$.file echo >conf$$.file if ln -s conf$$.file conf$$ 2>/dev/null; then # We could just check for DJGPP; but this test a) works b) is more generic # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). if test -f conf$$.exe; then # Don't use ln at all; we don't have any links as_ln_s='cp -p' else as_ln_s='ln -s' fi elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.file if mkdir -p . 2>/dev/null; then as_mkdir_p=: else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_executable_p="test -f" # 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'" # IFS # We need space, tab and new line, in precisely that order. as_nl=' ' IFS=" $as_nl" # CDPATH. $as_unset CDPATH exec 6>&1 # Open the log real soon, to keep \$[0] and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. Logging --version etc. is OK. exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX } >&5 cat >&5 <<_CSEOF This file was extended by VM $as_me 8.1.2, which was generated by GNU Autoconf 2.59. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ _CSEOF echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 echo >&5 _ACEOF # Files that config.status was made for. if test -n "$ac_config_files"; then echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS fi if test -n "$ac_config_headers"; then echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS fi if test -n "$ac_config_links"; then echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS fi if test -n "$ac_config_commands"; then echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS fi cat >>$CONFIG_STATUS <<\_ACEOF ac_cs_usage="\ \`$as_me' instantiates files from templates according to the current configuration. Usage: $0 [OPTIONS] [FILE]... -h, --help print this help, then exit -V, --version print version number, then exit -q, --quiet 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_cs_version="\\ VM config.status 8.1.2 configured by $0, generated by GNU Autoconf 2.59, with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" Copyright (C) 2003 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." srcdir=$srcdir INSTALL="$INSTALL" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # If no file are specified by the user, then we need to provide default # value. By we need to know if files were specified by the user. 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=$1 ac_optarg=$2 ac_shift=shift ;; *) # This is not an option, so the user has probably given explicit # arguments. ac_option=$1 ac_need_defaults=false;; esac case $ac_option in # Handling of the options. _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --vers* | -V ) echo "$ac_cs_version"; exit 0 ;; --he | --h) # Conflict between --help and --header { { echo "$as_me:$LINENO: error: ambiguous option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: ambiguous option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; };; --help | --hel | -h ) echo "$ac_cs_usage"; exit 0 ;; --debug | --d* | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift CONFIG_FILES="$CONFIG_FILES $ac_optarg" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" ac_need_defaults=false;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 Try \`$0 --help' for more information." >&5 echo "$as_me: error: unrecognized option: $1 Try \`$0 --help' for more information." >&2;} { (exit 1); exit 1; }; } ;; *) ac_config_targets="$ac_config_targets $1" ;; 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 if \$ac_cs_recheck; then echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_config_target in $ac_config_targets do case "$ac_config_target" in # Handling of arguments. "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" ;; *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 echo "$as_me: error: invalid argument: $ac_config_target" >&2;} { (exit 1); exit 1; }; };; 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 to put it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Create a temporary directory, and hook for its removal unless debugging. $debug || { trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 trap '{ (exit 1); exit 1; }' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" } || { tmp=./confstat$$-$RANDOM (umask 077 && mkdir $tmp) } || { echo "$me: cannot create a temporary directory in ." >&2 { (exit 1); exit 1; } } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF # # CONFIG_FILES section. # # No need to generate the scripts if there are no CONFIG_FILES. # This happens for instance when ./config.status config.h if test -n "\$CONFIG_FILES"; then # Protect against being on the right side of a sed subst in config.status. sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF s,@SHELL@,$SHELL,;t t s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t s,@exec_prefix@,$exec_prefix,;t t s,@prefix@,$prefix,;t t s,@program_transform_name@,$program_transform_name,;t t s,@bindir@,$bindir,;t t s,@sbindir@,$sbindir,;t t s,@libexecdir@,$libexecdir,;t t s,@datadir@,$datadir,;t t s,@sysconfdir@,$sysconfdir,;t t s,@sharedstatedir@,$sharedstatedir,;t t s,@localstatedir@,$localstatedir,;t t s,@libdir@,$libdir,;t t s,@includedir@,$includedir,;t t s,@oldincludedir@,$oldincludedir,;t t s,@infodir@,$infodir,;t t s,@mandir@,$mandir,;t t s,@build_alias@,$build_alias,;t t s,@host_alias@,$host_alias,;t t s,@target_alias@,$target_alias,;t t s,@DEFS@,$DEFS,;t t s,@ECHO_C@,$ECHO_C,;t t s,@ECHO_N@,$ECHO_N,;t t s,@ECHO_T@,$ECHO_T,;t t s,@LIBS@,$LIBS,;t t s,@SET_MAKE@,$SET_MAKE,;t t s,@INSTALL_PROGRAM@,$INSTALL_PROGRAM,;t t s,@INSTALL_SCRIPT@,$INSTALL_SCRIPT,;t t s,@INSTALL_DATA@,$INSTALL_DATA,;t t s,@LN_S@,$LN_S,;t t s,@RM@,$RM,;t t s,@LS@,$LS,;t t s,@MKDIR@,$MKDIR,;t t s,@GREP@,$GREP,;t t s,@XARGS@,$XARGS,;t t s,@TAR@,$TAR,;t t s,@MAKEINFO@,$MAKEINFO,;t t s,@TEXI2DVI@,$TEXI2DVI,;t t s,@EMACS_PROG@,$EMACS_PROG,;t t s,@lispdir@,$lispdir,;t t s,@pixmapdir@,$pixmapdir,;t t s,@EMACS_FLAVOR@,$EMACS_FLAVOR,;t t s,@EMACS_VERSION@,$EMACS_VERSION,;t t s,@FLAGS@,$FLAGS,;t t s,@info_dir@,$info_dir,;t t s,@OTHERDIRS@,$OTHERDIRS,;t t s,@PACKAGEDIR@,$PACKAGEDIR,;t t s,@SYMLINKS@,$SYMLINKS,;t t s,@LINKPATH@,$LINKPATH,;t t s,@LIBOBJS@,$LIBOBJS,;t t s,@LTLIBOBJS@,$LTLIBOBJS,;t t CEOF _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF # Split the substitutions into bite-sized pieces for seds with # small command number limits, like on Digital OSF/1 and HP-UX. ac_max_sed_lines=48 ac_sed_frag=1 # Number of current file. ac_beg=1 # First line for current file. ac_end=$ac_max_sed_lines # Line after last line for current file. ac_more_lines=: ac_sed_cmds= while $ac_more_lines; do if test $ac_beg -gt 1; then sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag else sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag fi if test ! -s $tmp/subs.frag; then ac_more_lines=false else # The purpose of the label and of the branching condition is to # speed up the sed processing (if there are no `@' at all, there # is no need to browse any of the substitutions). # These are the two extra sed commands mentioned above. (echo ':t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed if test -z "$ac_sed_cmds"; then ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" else ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" fi ac_sed_frag=`expr $ac_sed_frag + 1` ac_beg=$ac_end ac_end=`expr $ac_end + $ac_max_sed_lines` fi done if test -z "$ac_sed_cmds"; then ac_sed_cmds=cat fi fi # test -n "$CONFIG_FILES" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". case $ac_file in - | *:- | *:-:* ) # input from stdin cat >$tmp/stdin ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; * ) ac_file_in=$ac_file.in ;; esac # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. ac_dir=`(dirname "$ac_file") 2>/dev/null || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` { if $as_mkdir_p; then mkdir -p "$ac_dir" else as_dir="$ac_dir" as_dirs= while test ! -d "$as_dir"; do as_dirs="$as_dir $as_dirs" as_dir=`(dirname "$as_dir") 2>/dev/null || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| \ . : '\(.\)' 2>/dev/null || echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } /^X\(\/\/\)[^/].*/{ s//\1/; q; } /^X\(\/\/\)$/{ s//\1/; q; } /^X\(\/\).*/{ s//\1/; q; } s/.*/./; q'` done test ! -n "$as_dirs" || mkdir $as_dirs fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} { (exit 1); exit 1; }; }; } ac_builddir=. if test "$ac_dir" != .; then ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` # A "../" for each directory in $ac_dir_suffix. ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` else ac_dir_suffix= ac_top_builddir= fi case $srcdir in .) # No --srcdir option. We are building in place. ac_srcdir=. if test -z "$ac_top_builddir"; then ac_top_srcdir=. else ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` fi ;; [\\/]* | ?:[\\/]* ) # Absolute path. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ;; *) # Relative path. ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_builddir$srcdir ;; esac # Do not use `cd foo && pwd` to compute absolute paths, because # the directories may not exist. case `pwd` in .) ac_abs_builddir="$ac_dir";; *) case "$ac_dir" in .) ac_abs_builddir=`pwd`;; [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; *) ac_abs_builddir=`pwd`/"$ac_dir";; esac;; esac case $ac_abs_builddir in .) ac_abs_top_builddir=${ac_top_builddir}.;; *) case ${ac_top_builddir}. in .) ac_abs_top_builddir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; esac;; esac case $ac_abs_builddir in .) ac_abs_srcdir=$ac_srcdir;; *) case $ac_srcdir in .) ac_abs_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; esac;; esac case $ac_abs_builddir in .) ac_abs_top_srcdir=$ac_top_srcdir;; *) case $ac_top_srcdir in .) ac_abs_top_srcdir=$ac_abs_builddir;; [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; esac;; esac case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_builddir$INSTALL ;; esac if test x"$ac_file" != x-; then { echo "$as_me:$LINENO: creating $ac_file" >&5 echo "$as_me: creating $ac_file" >&6;} rm -f "$ac_file" fi # 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. */ if test x"$ac_file" = x-; then configure_input= else configure_input="$ac_file. " fi configure_input=$configure_input"Generated from `echo $ac_file_in | sed 's,.*/,,'` by configure." # First look for the input files in the build tree, otherwise in the # src tree. ac_file_inputs=`IFS=: for f in $ac_file_in; do case $f in -) echo $tmp/stdin ;; [\\/$]*) # Absolute (can't be DOS-style, as IFS=:) test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } echo "$f";; *) # Relative if test -f "$f"; then # Build tree echo "$f" elif test -f "$srcdir/$f"; then # Source tree echo "$srcdir/$f" else # /dev/null tree { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 echo "$as_me: error: cannot find input file: $f" >&2;} { (exit 1); exit 1; }; } fi;; esac done` || { (exit 1); exit 1; } _ACEOF cat >>$CONFIG_STATUS <<_ACEOF sed "$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s,@configure_input@,$configure_input,;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,@top_builddir@,$ac_top_builddir,;t t s,@abs_top_builddir@,$ac_abs_top_builddir,;t t s,@INSTALL@,$ac_INSTALL,;t t " $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out rm -f $tmp/stdin if test x"$ac_file" != x-; then mv $tmp/out $ac_file else cat $tmp/out rm -f $tmp/out fi done _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF { (exit 0); exit 0; } _ACEOF chmod +x $CONFIG_STATUS ac_clean_files=$ac_clean_files_save # 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 || { (exit 1); exit 1; } fi # configure.ac ends here vm-8.1.2/vm-load.el.in0000644000175000017500000000017011725175471014714 0ustar srivastasrivasta; -*- mode: emacs-lisp -*- ;; Load VM easily (add-to-list 'load-path "@abs_top_builddir@/lisp") (load "vm-autoloads") vm-8.1.2/NEWS0000644000175000017500000007234111725175471013136 0ustar srivastasrivastaStatus VM is currently being maintained by a 'VM development team' consisting of Robert Widhopf-Fenk, Ulrich Müller and Uday S Reddy. We continue to look for more volunteers to help with the maintenance. The version 8.1 released here has been under development for more than 2 years. It was held back by Robert Fenk getting busy towards the end of 2008 and a long period of interregnum. Hopefully, we have that behind us. This version has major improvements on various fronts, especially for imap-folders. Please read the details below. Bug reports should be sent by using M-x vm-submit-bug-report. Enjoy using VM! - Rob, Ulrich and Uday VM 8.1.2 2012-03-04 BUG FIXES * VM versions 8.1.0 and 8.1.1 had a small bug which blocks them from being forward-compatible, i.e., being able to handle VM folders from future versions of VM. (They give error messages of the form "Bad VM cache data" and reinitialize the cached-data vectors.) The bug is fixed in this version of VM. * If you download mail from IMAP spool files, the 8.1.1 and 8.1.2 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 this version. (See info under "IMAP Spool Files".) IMPROVEMENTS * Virtual folder facility extended to work with POP and IMAP folders. * 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 (Not forward-compatible) ** 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 (Not forward-compatible) 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-select-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! Local Variables: mode: text coding: utf-8 End: vm-8.1.2/contrib/0002755000175000017500000000000011725175471014072 5ustar srivastasrivastavm-8.1.2/contrib/vm-blueman.el0000644000175000017500000000765311725175471016470 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..." (call-interactively 'vm-mime-attach-object-from-message) 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) (message "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)) (message "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.1.2/contrib/vm-bogofilter.el0000644000175000017500000003546511725175471017203 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) ) (message "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)))) (message "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)) (message "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) ) (message "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) (message "Message re-classified and tagged as %s." text) (vm-preview-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.1.2/contrib/vm-mime.el-w3m.patch0000644000175000017500000001252611725175471017571 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.1.2/contrib/attempted-locking.diff0000644000175000017500000000703411725175471020341 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.1.2/contrib/vm-mime-display-internal-application.el0000644000175000017500000002242611725175471023545 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-frames) (pop-up-windows vm-mutable-windows) (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.1.2/contrib/org-vm.el0000644000175000017500000001252611725175471015627 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-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-get-header-contents message "To")) (from (vm-get-header-contents message "From")) (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.1.2/CHANGES0000644000175000017500000104043511725175471013432 0ustar srivastasrivasta-*-Text-*- 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 * 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 * `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) ------- 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.1.2/TODO0000644000175000017500000001323711725175471013126 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.1.2/install-sh0000755000175000017500000001273611725175471014445 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.1.2/README0000644000175000017500000001157411725175471013320 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. This VM is based on Robert Widhopf-Fenk's patches against VM 7.19. The current version is maintained by the 'VM development team' (vm@lists.launchpad.net) consisting of Robert, Ulrich Müller and Uday Reddy. The persons who have contributed to this version of VM are: * Aidan Kehoe * Glenn * Jens Gustedt * John J Foerch * Kevin Rogers * Kyle Jones * Rob Hodges * Robert Marshall * Robert P. Goldman * Katsumi Yamaoka * Julian Bradfield * Samuel Bronson * Brent Goodrick * Ulrich Müller * Uday S. Reddy * Robert Widhopf-Fenk Please mail us a note, if I have forgotten someone or accidently put you on the list. 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 (or) bzr get lp:~vm/vm/trunk # 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. ******************************************************************************* 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.1.2/INSTALL0000644000175000017500000001336011725175471013464 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) 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) Select your emacs flavor, this is the option --with-emacs and its default is emacs (GNU Emacs). Choose a prefix for the installation with --prefix, by default /usr/local. The default locations are as follows: a) GNU Emacs: lisp files goto ${prefix}/share/emacs/site-lisp and info files to ${prefix}/info (overridable with --with-lispdir=... and --infodir=...) b) XEmacs: lisp files goto ${prefix}/lib/xemacs/site-packages/lisp/vm and info files to ${prefix}/lib/xemacs/site-packages/info, (overridable with --with-lispdir=... and --infodir=...) ATTENTION: Files byte-compiled with GNU Emacs are NOT COMPATIBLE with the XEmacs and you may experience strange problems during startup when doing so. Even between GNU Emacs versions there might be problems! Thus you must ensure you are configuring with --with-emacs=xemacs when installing VM for XEmacs! Also if you want to use BBDB or Emacs-w3m features please specify the path to their source files with the -with-other-dirs option. 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 It is currently not possible to build VM in a separate directory. 2) Compile everything by running: make You may ignore warnings, however error messages indicate that some modules (partially) will not work, i.e. if other library files are missing or you are running GNU Emacs. 3) Installing the files a) The manual way 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 resp. ~/.xemacs/init.el. (add-to-list 'load-path (expand-file-name "~/vm/lisp")) (add-to-list 'Info-default-directory-list (expand-file-name "~/vm/info")) GNU Emacs users, have to load the autoloads by hand by adding (require 'vm-autoloads) to their ~/.emacs. If there are any old VM-related autoloads in your ~/.emacs file, you should remove them. The vm-autoloads library takes care of all the autoloads for VM. 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") b) make install Which might work, but might not work as most distros have their own directory layout. 4) Add the following line to your info directory (dir): * 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). You are now ready to use VM. C-h i should start up the Emacs Info system and if you have installed the Info documents properly you can use the online documentation to teach yourself how to use VM. COMPANION PACAKAGES =================== 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.