home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / gnu / src / amiga / emacs-19.28-src.lha / emacs-19.28 / site-lisp / vm-auto-archive.el < prev    next >
Encoding:
Text File  |  1994-12-22  |  14.2 KB  |  373 lines
  1. ;;
  2. ;; LCD Archive Entry:
  3. ;; vm-auto-archive|Neal Young|ney@research.att.com|
  4. ;; Two ways to automatically archive outgoing mail into appropriate VM folders.  Supersedes vm-auto-fcc.el|
  5. ;; 20-Oct-1994|version 5.72a|~/misc/vm-auto-archive.el|
  6. ;;
  7. ;; PURPOSE: Automatically archive outgoing mail into appropriate VM folders.
  8. ;;
  9. ;;   This works with vm 5.72.
  10. ;;
  11. ;; USAGE: 
  12. ;;   This package provides two methods for automatically archiving outgoing
  13. ;;   mail messages using the VM mailer.  [Also it provides a utility function
  14. ;;   "return-match" which is useful in vm-auto-folder-alist -- e.g.,
  15. ;;   after matching the regexp "a\(.*\)b" to "axb", (return-match "\\1 \\1") 
  16. ;;   will return "x x".]
  17. ;;
  18. ;;   The first method is implemented by an interactive function vm-auto-fcc.
  19. ;;   This function, invoked by "" when composing a message, prompts for a
  20. ;;   folder name and inserts an "FCC: <folder-name>" field into the msg.  When
  21. ;;   prompting for the folder name, the function provides a default determined
  22. ;;   by pattern-matching the contents of the current message, similarly to VM's
  23. ;;   use of vm-auto-folder-alist, as described below.  When the message is
  24. ;;   sent, the "FCC:" field causes a copy to be appended to the chosen folder.
  25. ;;
  26. ;;   The second method is implemented by a function vm-auto-archive.  This
  27. ;;   function, invoked by "" when composing a message, prompts for a
  28. ;;   folder name and inserts two fields into the message.  When prompting for
  29. ;;   the folder name, the function provides a default determined as in the
  30. ;;   first method.  The first field is a "BCC: " field with your
  31. ;;   user-login-name.  The second field is a "X-VM-folder: " field with the
  32. ;;   chosen folder name.  When the message is sent, the "BCC:" field causes a
  33. ;;   copy to be mailed to you.  This file modifies VM (using "advice") so that
  34. ;;   when you save a message that appears to be from you and has an
  35. ;;   "X-VM-folder:" field, that folder will be offered as the default folder
  36. ;;   for saving.
  37. ;;
  38. ;;   The second method has the advantage that all of the fields added to the
  39. ;;   message by send-mail are present in the archived message too.  It has
  40. ;;   the disadvantages that the mail is not immediately archived and a
  41. ;;   malicious mail sender could screw it up.
  42. ;;
  43. ;;   In each case, the default folder is determined by pattern-matching the
  44. ;;   contents of the message being composed to the variable
  45. ;;   vm-auto-archive-alist.  This variable has the same format and semantics
  46. ;;   as vm-auto-folder-alist, except that it is used to classify a message
  47. ;;   that is being composed for sending, rather than one in a VM folder.
  48. ;;
  49. ;;   (VM is an alternative to rmail.  It has some nice features like using the
  50. ;;    standard mailbox format, automatically filing mail messages by pattern
  51. ;;    matching, easily customized summary buffer display, threads...
  52. ;;    If you don't have VM, try /ftp.uu.net:networking/mail/vm.
  53. ;;
  54. ;; INSTALLATION:
  55. ;;    Probably best not to compile this file, but if you do, recompile it
  56. ;;    whenever you install a new version of vm.
  57. ;;
  58. ;;    PUT this file in a directory on your e-lisp search path
  59. ;;    under the name "vm-auto-archive.el".
  60. ;;
  61. ;;    ADD these lines to your .vm (or .emacs) file:
  62.  
  63. (defvar vm-auto-archive-alist nil "\
  64. Like vm-auto-folder-alist, but used by vm-auto-fcc and vm-auto-archive
  65. to categorize a message being composed for sending.")
  66.  
  67. (defvar vm-auto-archive-sender-regexp nil "\
  68. Regexp.  If the sender of a mail message matches this, and the message
  69.  has an X-VM-folder field, then vm-auto-select-folder will return the folder
  70.  named in the field.  Defaults to vm-reply-ignored-addresses.")
  71.  
  72. (autoload (quote vm-auto-fcc) "vm-auto-archive" "\
  73. Add a new FCC field, with file name guessed by vm-auto-archive-alist.
  74. Return file name." t nil)
  75.  
  76. (autoload (quote vm-auto-archive) "vm-auto-archive" "\
  77. Add BCC and X-VM-folder fields to message being composed,
  78.  guessing folder name based on vm-auto-archive-alist.  Return file name." t nil)
  79.  
  80. (autoload (quote vm-auto-archive-enable) "vm-auto-archive" "\
  81. Enable vm-auto-archive." t nil)
  82.  
  83. (autoload (quote vm-auto-archive-disable) "vm-auto-archive" "\
  84. Disable vm-auto-archive." t nil)
  85.  
  86. (autoload (quote return-match) "vm-auto-archive" "\
  87. Like replace-match except return the string that would be
  88. substituted for the match, instead of replacing the match with it." nil nil)
  89.  
  90. (add-hook 'mail-setup-hook 
  91.          '(lambda () 
  92.         (local-set-key "" 'vm-auto-fcc)
  93.         (local-set-key "" 'vm-auto-archive)
  94.         ))
  95.  
  96. (vm-auto-archive-enable)
  97.  
  98. ;;    (continued...)
  99. ;;
  100. ;;    SET variable vm-auto-archive-alist (in your .vm (or .emacs) file)
  101. ;;     as you would set vm-auto-folder-alist, 
  102. ;;     except set it to recognize fields of outgoing messages.
  103. ;;      You probably want to reverse the sense of "from" and "to" headers,
  104. ;;    but you could just (setq vm-auto-archive-alist vm-auto-folder-alist).
  105. ;;      
  106. ;; BUGS:
  107. ;;    The method is a hack.  It advises vm-get-header-contents to work in
  108. ;;    arbitrary buffers, so that vm-auto-select-folder can too.  It also
  109. ;;    advises vm-auto-select-folder to catch the "X-VM-folder:" field if
  110. ;;    appropriate.  If vm-auto-select-folder or vm-get-header-contents is
  111. ;;    changed, it might cease to work.
  112. ;;
  113. ;;    For these reasons, I added commands to disable/enable vm-auto-archive
  114. ;;    at will.
  115. ;;
  116. ;; Copyright (C) 1993,1994  Neal Young
  117. ;;
  118. ;;    "X-VM-folder:" field functionality based on code
  119. ;;    provided by gec@Mti.Sgi.Com (Gardner Cohen).
  120. ;; 
  121. ;;    This program is free software; you can redistribute it and/or modify
  122. ;;    it under the terms of the GNU General Public License as published by
  123. ;;    the Free Software Foundation; either version 2 of the License, or
  124. ;;    (at your option) any later version.
  125. ;; 
  126. ;;    This program is distributed in the hope that it will be useful,
  127. ;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
  128. ;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  129. ;;    GNU General Public License for more details.
  130. ;; 
  131.  
  132. (require 'advice)
  133.  
  134. (defvar vm-auto-archive-enabled nil "vm-auto-archive private variable")
  135.  
  136. ;;;###autoload
  137. (defvar vm-auto-archive-alist nil 
  138.   "Like vm-auto-folder-alist, but used by vm-auto-fcc and vm-auto-archive
  139. to categorize a message being composed for sending.")
  140.  
  141. (defvar vm-auto-archive-alist nil "\
  142. Like vm-auto-folder-alist, but used by vm-auto-fcc and vm-auto-archive
  143. to categorize a message being composed for sending.")
  144.  
  145. (defvar vm-auto-archive-alist nil "\
  146. Like vm-auto-folder-alist, but used by vm-auto-fcc and vm-auto-archive
  147. to categorize a message being composed for sending.")
  148.  
  149. ;;;###autoload
  150. (defvar vm-auto-archive-sender-regexp nil
  151.   "Regexp.  If the sender of a mail message matches this, and the message
  152.  has an X-VM-folder field, then vm-auto-select-folder will return the folder
  153.  named in the field.  Defaults to vm-reply-ignored-addresses.")
  154.  
  155. (defvar vm-auto-archive-sender-regexp nil "\
  156. Regexp.  If the sender of a mail message matches this, and the message
  157.  has an X-VM-folder field, then vm-auto-select-folder will return the folder
  158.  named in the field.  Defaults to vm-reply-ignored-addresses.")
  159.  
  160. (defvar vm-auto-archive-sender-regexp nil "\
  161. Regexp.  If the sender of a mail message matches this, and the message
  162.  has an X-VM-folder field, then vm-auto-select-folder will return the folder
  163.  named in the field.  Defaults to vm-reply-ignored-addresses.")
  164.  
  165. ;;;###autoload
  166. (defun vm-auto-fcc (&optional dont-ask-if-default-available)
  167.   "Add a new FCC field, with file name guessed by vm-auto-archive-alist.
  168. Return file name."
  169.   (interactive)
  170.   (if (not vm-auto-archive-enabled)
  171.       (message "execute vm-auto-archive-enable first!")
  172.     (let (file-name)
  173.       (save-excursion
  174.     (expand-abbrev)
  175.     (or (mail-position-on-field "fcc" t) ;Put new field after existing FCC.
  176.         (mail-position-on-field "to"))
  177.     (let ((default (vm-auto-select-folder-for-buffer 
  178.             vm-auto-archive-alist)))
  179.       (if (or (not (stringp default)) (equal default ""))
  180.           (setq default vm-last-save-folder))
  181.       (setq file-name
  182.         (if (or (not (stringp default)) (equal default ""))
  183.             (read-file-name "FCC: " vm-folder-directory)
  184.           (if (not (file-name-absolute-p default))
  185.               (setq default (concat vm-folder-directory default)))
  186.           (if dont-ask-if-default-available
  187.               default
  188.             (read-file-name (concat "FCC: (default " default ") ")
  189.                     vm-folder-directory
  190.                     default)))))
  191.     (insert "\nFCC: " file-name))
  192.       file-name)))
  193.  
  194. ;;;###autoload
  195. (defun vm-auto-archive (&optional dont-ask-if-default-available)
  196.   "Add BCC and X-VM-folder fields to message being composed,
  197.  guessing folder name based on vm-auto-archive-alist.  Return file name."
  198.   (interactive)
  199.   (if (not vm-auto-archive-enabled)
  200.       (message "execute vm-auto-archive-enable first!")
  201.     (save-excursion
  202.       (expand-abbrev)
  203.       (or (mail-position-on-field "bcc" t) ;Put new field after existing BCC.
  204.       (mail-position-on-field "to"))
  205.       (insert "\nbcc: " (user-login-name))
  206.       (let ((default (vm-auto-select-folder-for-buffer vm-auto-archive-alist)))
  207.     (if (or (not (stringp default)) (equal default ""))
  208.         (setq default vm-last-save-folder))
  209.     (let ((file-name
  210.            (if (or (not (stringp default)) (equal default ""))
  211.            (read-file-name "folder: " vm-folder-directory)
  212.          (if (not (file-name-absolute-p default))
  213.              (setq default (concat vm-folder-directory default)))
  214.          (if dont-ask-if-default-available
  215.              default
  216.            (read-file-name (concat "folder: (default " default ") ")
  217.                    vm-folder-directory
  218.                    default)))))
  219.       (insert "\nX-VM-folder: " file-name)
  220.       file-name)))))
  221.  
  222. (defun vm-auto-select-folder-for-buffer (auto-folder-alist)
  223.   (vm-auto-select-folder '(CURRENT-BUFFER) auto-folder-alist))
  224.  
  225. ;;
  226. (defadvice vm-get-header-contents;; args: message header-name-regexp
  227.   (around vm-auto-archive-get-header-contents disable)
  228.   "Advised so as to work in current buffer (instead of vm msg)
  229.    when (eq MESSAGE 'CURRENT-BUFFER).  For vm-5.65."
  230.   (if (not (eq message 'CURRENT-BUFFER))
  231.       ad-do-it
  232.     (vm-get-header-contents-current-buffer header-name-regexp)))
  233.  
  234. ;; logic to use X-VM-folder field to set the default when saving message.
  235. (defadvice vm-auto-select-folder
  236.   (around vm-auto-archive-auto-select (MP AUTO-FOLDER-ALIST) disable)
  237.   "If you sent the message, use the `X-VM-folder' field, if any."
  238.   (let ((header-folder (vm-get-header-contents (car MP) "x-vm-folder"))
  239.     (sender-regexp (or vm-auto-archive-sender-regexp
  240.                (if vm-reply-ignored-addresses
  241.                    (mapconcat 'identity
  242.                       vm-reply-ignored-addresses
  243.                       "\\|"))
  244.                (user-login-name)))
  245.     (sender (vm-get-header-contents (car MP) "from:")))
  246.     (or
  247.      (and sender 
  248.       (string-match sender-regexp sender)
  249.       (setq ad-return-value header-folder))
  250.      ad-do-it)))
  251.  
  252. (defun vm-get-header-contents-current-buffer (header-name-regexp)
  253.   "like vm-get-header-contents but within a buffer holding text of message"
  254.   (condition-case nil
  255.       (let ((contents nil) 
  256.         (regexp (concat "^\\(" header-name-regexp "\\)")))
  257.     (save-excursion
  258.       (save-restriction
  259.         (let ((end
  260.            (progn (goto-char (point-min))
  261.               (re-search-forward "\n\n\\|\\'")
  262.               (point))))
  263.           (goto-char (point-min))
  264.           (let ((case-fold-search t))
  265.         (while (and (re-search-forward regexp end t)
  266.                 (save-excursion (goto-char (match-beginning 0))
  267.                         (vm-match-header)))
  268.           (if contents
  269.               (setq contents
  270.                 (concat contents ", " (vm-matched-header-contents)))
  271.             (setq contents (vm-matched-header-contents)))))))
  272.       (setq ad-return-value contents)))
  273.     (error
  274.      (error 
  275.       "vm-auto-archive incompatible with vm version or needs recompilation"
  276.       ))))
  277.  
  278. ;;; use the next two functions to enable/disable vm-auto-archive once loaded
  279.  
  280. ;;;###autoload
  281. (defun vm-auto-archive-enable ()
  282.   "Enable vm-auto-archive."
  283.   (interactive)
  284.   (if vm-auto-archive-enabled
  285.       nil
  286.     (setq ad-activate-on-definition t)
  287.     (ad-start-advice)
  288.     (ad-enable-advice 'vm-get-header-contents 'around
  289.              'vm-auto-archive-get-header-contents)
  290.     (ad-activate 'vm-get-header-contents)
  291.     (ad-enable-advice 'vm-auto-select-folder 'around 
  292.               'vm-auto-archive-auto-select)
  293.     (ad-activate 'vm-auto-select-folder)
  294.     (setq vm-auto-archive-enabled t)
  295.     ))
  296.  
  297. ;;;###autoload
  298. (defun vm-auto-archive-disable ()
  299.   "Disable vm-auto-archive."
  300.   (interactive)
  301.   (if (not vm-auto-archive-enabled)
  302.       nil
  303.     (ad-disable-advice 'vm-get-header-contents 'around
  304.                'vm-auto-archive-get-header-contents)
  305.     (ad-activate 'vm-get-header-contents)
  306.     (ad-disable-advice 'vm-auto-select-folder 'around 
  307.                'vm-auto-archive-auto-select)
  308.     (ad-activate 'vm-auto-select-folder)
  309.     (setq vm-auto-archive-enabled nil)
  310.     ))
  311.  
  312. ;; the following function is useful in vm-auto-folder-alist,
  313. ;; e.g. after matching the regular expression "\(.*\)aa" to "bbaa"
  314. ;; (return-match "\\1 x \\1") yields "bb x bb".  So, for instance, 
  315. ;; the following would return the username of the first person in the
  316. ;; from, to, sender, or cc fields, whichever comes first.
  317. ;; (setq 
  318. ;;      vm-auto-folder-alist
  319. ;;      '(
  320. ;;    ("From\\|To\\|Sender\\|CC"
  321. ;;      ("^\\(.*<\\)?\\([^@%>     
  322. ;; ]+\\)" . (return-match "\\2"))
  323. ;;      )
  324. ;;     )
  325.  
  326. ;;;###autoload
  327. (defun return-match (new-text &optional fixed-case &optional literal)
  328.   "Like replace-match except return the string that would be
  329. substituted for the match, instead of replacing the match with it."
  330.   (let* ((maxi (- (length new-text) 1))
  331.      (submatches (make-vector 10 ""))
  332.      (substrings nil)
  333.      (this (substring new-text 0 1))
  334.      (next (if (<= 1 maxi)
  335.            (substring new-text 1 2)
  336.          (char-to-string 0)))
  337.      (i 0))
  338.  
  339.     (while (< i 10)
  340.       (if (match-beginning i)
  341.       (aset submatches i
  342.         (buffer-substring (match-beginning i) (match-end i))))
  343.       (setq i (+ 1 i)))
  344.  
  345.     (setq i 0)
  346.     (while (<= i maxi)
  347.       (setq substrings 
  348.         (cons 
  349.          (if (string= this "\\")
  350.          (progn 
  351.            (setq i (+ 1 i))
  352.            (setq this next)
  353.            (setq next (if (< i maxi)
  354.                   (substring new-text (+ 1 i) (+ 2 i))
  355.                 (char-to-string 0)))
  356.            (cond
  357.             ((string= this "&") (aref submatches 0))
  358.             ((and (string< "0" this)
  359.               (or (string= this "9")
  360.                   (string< this "9")))
  361.              (aref submatches (string-to-int this)))
  362.             (t this)))
  363.            this)
  364.          substrings))
  365.       (setq i (+ 1 i))
  366.       (setq this next)
  367.       (setq next (if (< i maxi)
  368.              (substring new-text (+ 1 i) (+ 2 i))
  369.            (char-to-string 0))))
  370.     (apply 'concat (nreverse substrings))))
  371.  
  372. (provide 'vm-auto-archive)
  373.