kayvan@mrspoc.transact.com (Kayvan Sylvan) (09/15/89)
In using VM, I find it easy to save mail in appropriate folders using the
vm-auto-folder-alist variable. I also found the default outgoing mail
archiving of Emacs inadequate. I wanted Emacs to file my outgoing mail in the
same folders I filed my incoming mail, but by *recipient*. This would allow me
to save both sides of a mail conversation.
I coded the following to do this. It seems to work. If you like it, tell me.
If you make additions/changes, pass them along to me. I named the file
vm-archive.el because the outgoing mail filing seems to be an easy extension
of the already existing VM functionality.
In my .emacs function, as part of my mail-mode-hook, I have:
(require 'vm-archive)
to supplant the standard mail-send with this extension.
-------------------- cut here for vm-archive.el --------------------
;;
;; vm-archive.el - Additions to archive outgoing mail by recipient
;;
;; Author: Kayvan Sylvan <kayvan@mrspoc.Transact.COM>
;;
;; The terms of the GNU Emacs copying conditions apply.
;;
;; This redefines mail-send so as to file outgoing mail
;; by recipient in a corresponding mail folder. This is useful
;; for saving both sides of a conversation using VM.
;;
;; This behavior is only used if mail-archive-alist is not nil.
;;
;; The mail-archive-alist can be used to selectively file outgoing mail.
;; If no default regexp exists at the end of the alist, mail will not be
;; filed (unless mail-archive-file-name is set).
;;
;; You can get the existing behavior of outgoing mail by *only* defining
;; a default regexp, thus:
;; (setq mail-archive-alist '((".*"."~/mail/out.going")))
(provide 'vm-archive)
(fset 'original-mail-send (symbol-function 'mail-send))
(defvar mail-archive-alist nil
"*List of regexps for matching againts the outbound mail recipients
to figure out which folder to file the mail in. Its form is:
'((\"REGEXP1\".\"FOLDER1\") (\"REGEXP1\".\"FOLDER2\") ...)
The first match dictates the folder. The FOLDER values will
be prepended by the value of mail-archive-directory if not nil.")
(defvar mail-archive-directory nil
"*Directory where archive folders can be found. Must end in /")
(defun mail-send ()
"Set FCC: field to proper archive name and invoke original-mail-send"
(interactive)
(let (fcc )
(save-excursion
(setq fcc (match-recipients)) ; set fcc to outgoing folder
(if fcc
(progn
(if mail-archive-directory
(setq fcc (concat mail-archive-directory fcc)))
(setq fcc (expand-file-name fcc))
(create-mail-header "FCC" fcc))) ; change or insert FCC header
(original-mail-send)))) ; Do original mail-send
(defun match-recipients ()
(let (to-list folders folder try-match)
(setq to-list (concat (get-field "To") " " (get-field "CC")))
(setq folders mail-archive-alist)
(while (and folders (null folder))
(setq try-match (car (car folders)))
(if (string-match try-match to-list)
(setq folder (cdr (car folders))))
(setq folders (cdr folders)))
folder)) ; return matched folder
;; Simple function to get a header value. Leaves after the 'header: '
(defun get-field (fname)
(goto-char (point-min)) ; beginning of buffer
(let ((case-fold-search t)) ; make sure we don't care about case
(if (re-search-forward (concat "^" fname ": ") nil t)
(save-excursion
(buffer-substring (point) (progn (end-of-line) (point)))))))
;; Simple function to create/change a header to a given value.
(defun create-mail-header (fname value)
(cond
((get-field fname) (delete-region (point) (progn (end-of-line) (point)))
(insert value))
(t (search-forward mail-header-separator) (beginning-of-line nil)
(insert fname ": " value "\n"))))
-------------------- end of vm-archive.el --------------------
Kthulu is my savior.
---Kayvan
Kayvan Sylvan @ Transact Software, Inc. -*- Los Altos, CA (415) 961-6112
Internet: kayvan@Transact.COM -*- UUCP: ...!{apple,pyramid,mips}!mrspoc!kayvan