home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / patches / auto-filer.patch < prev    next >
Encoding:
Text File  |  1991-12-21  |  11.8 KB  |  324 lines
  1. ; Newsgroups: gnu.emacs.sources
  2. ; Path: dg-rtp!uunet!uunet!cis.ohio-state.edu!uvm-gen.uvm.edu!wollman
  3. ; From: wollman@uvm-gen.uvm.edu
  4. ; Subject: A new, improved mail auto-filer
  5. ; Organization: Source only  Discussion and requests in gnu.emacs.help.
  6. ; Date: Mon, 9 Dec 1991 20:09:12 GMT
  7. ; 
  8. ; This message contains patches which will modify sendmail.el,
  9. ; loaddefs.el (yes, you will have to re-dump your Emacs, although you
  10. ; could get around it by putting these into sendmail instead), and
  11. ; vm-save.el, with path-names like the way I have my GNU sources set up.
  12. ; (You can always leave the -p off and let patch prompt you for the
  13. ; exact file name...)
  14.  
  15. ; These patches, put together, install a more intelligent, more
  16. ; customizable, auto-filer for sendmail mode, and modify VM to use the
  17. ; same (so that you don't have to write everything twice).  Modification
  18. ; of other mail and news systems to use the new saver should be quite
  19. ; straightforward: simply call (mail-find-auto-save HEADER) where HEADER
  20. ; is the (string) value of some appropriate header file---I use To: in
  21. ; sendmail and From: or To: (whichever is present) in VM.  The return
  22. ; value is a list of folders to which the message should be saved, or
  23. ; nil if nothing appropriate was found.
  24. ; 
  25. ; The actual system used to determine where to file what is completely
  26. ; user-customizable (in fact, if the user doesn't customize anything,
  27. ; then the behavior will be just as it was before).  Here are some
  28. ; samples from my .emacs file:
  29.  
  30. ;; LCD Archive Entry:
  31. ;; auto-filer|Garrett Wollman|wollman@uvm-gen.uvm.edu
  32. ;; |Patche to improve mail auto-filing
  33. ;; |91-12-09||~/patches/auto-filer.patch.Z|
  34.  
  35. ;;
  36. ;; This tells VM to use the new auto-filer.  If this is inetgrated
  37. ;; into Emacs (as I would love to see happen), \(.*\)-auto-save should
  38. ;; probably be changed to \1-auto-file, to avoid confusion.  I got a
  39. ;; bit confused myself, at some points.
  40. ;;
  41. (setq vm-use-mail-auto-save t)
  42.  
  43. ;;
  44. ;; set up mail auto-filing
  45. ;;
  46. ;; This works somewhat like, but much better than, the auto-save
  47. ;; feature in the Elm mailer, which is where I'm coming from as a
  48. ;; a new convert to VM and sendmail.
  49. ;;
  50.  
  51. ;; the folders of last resort
  52. (setq mail-auto-save-default (list "~/Mail/misc"))
  53.  
  54. ;;
  55. ;; Note that the keys in this alist are *regexps*.  The function
  56. ;; mail-regex-assq in sendmail.el is a prime target for
  57. ;; optimization.
  58. ;;
  59. (setq mail-auto-save-alist '(("Tom\\.Emerson" "~/Mail/tree")
  60.                  ("Tim\\.Raymond" "~/Mail/raymond")
  61.                  ("Internet\\.Drafts" "~/Mail/ietf")
  62.                  ("Steve\\.Ackerman" "~/Mail/steve")))
  63.  
  64. ;;
  65. ;; Basic logic... if we already have a mailbox for mail from to-name,
  66. ;; then use that.  Otherwise, if the message looks like it is coming
  67. ;; from inside UVM, save it in the mailbox uvm-folk.  Then we punt
  68. ;; back to mail-find-auto-save, which will do the default.
  69. ;;
  70. (defun my-mail-saver (to-name)
  71.   (if (> (length to-name) 0)
  72.       (let* ((off (string-match "@" to-name))
  73.          (prospective (concat (expand-file-name "~/Mail/")
  74.                   (substring to-name 0 off))))
  75.     (if (file-exists-p prospective)
  76.         (list prospective)
  77.       (if (string-match "^[^!@%]+$" to-name)
  78.           (list "~/Mail/uvm-folk")
  79.         (if (string-match "uvm.edu"
  80.                   (substring to-name off nil))
  81.         (list "~/Mail/uvm-folk")))))))
  82.  
  83. (setq mail-auto-save-hook 'my-mail-saver)
  84.  
  85.  
  86. - ----------------------------------------
  87. Some other notes:
  88.  
  89. If you include a line like
  90. [no save]
  91. in your message, it won't be saved by sendmail; this has no effect in
  92. VM, where saving is presumed to be a voluntary action anyway.  This is
  93. also like in Elm.
  94.  
  95. The function mail-first-address, provided by my good friend Tom
  96. Emerson, works for most reasonable addresses, but like anything in
  97. RFC-822 land, it can probably be confused by pathological cases
  98. involving quotation.  Since most people don't do such mean things to
  99. their addresses, I'm not worrying about it.
  100.  
  101. mail-regex-assq should be re-written to operate iteratively, as
  102. suggested in the Lisp Reference Manual.  It should also be re-named
  103. regex-assq and added to the standard lisp routines which are dumped
  104. with Emacs.  (Allow me to take this moment to plug Ange-ftp; it really
  105. is so useful that you should dump it with your Emacs, and don't care
  106. how much pure space it eats up.  I dump both ange-ftp and calc.el (the
  107. "main" module of calc-mode), and it requires about 280k of pure space
  108. on an RS/6000, but I think that it's worth it.)
  109.  
  110. I've been using this system for about two weeks now, and it works
  111. great for me, with the exception that VM loses the "~/" during saves,
  112. which eventually causes it to go into an infinite loop if you don't
  113. add it back, while manually over-riding the suggested location.  I
  114. probably need to put a (save-foo ...) form around the VM code below,
  115. but it's only a minor irritation.  Perhaps someday I'll figure out
  116. what's really going on down there.
  117.  
  118. Questions, comments, suggestions, code, etc. should be sent to
  119. wollman@UVM.EDU.
  120.  
  121. Now for the diffs...
  122. - ------------------------------------------------------------
  123.  
  124. Index: emacs-18.57/lisp/loaddefs.el
  125. - --- loaddefs.el~    Wed Jan  9 17:01:26 1991
  126. +++ loaddefs.el    Thu Nov 28 22:36:24 1991
  127. @@ -1126,6 +1126,24 @@
  128.  Alias of mail address aliases,
  129.  or t meaning should be initialized from .mailrc.")
  130.  
  131. +;;
  132. +;; mail-auto-save variables - GW
  133. +;;
  134. +(defvar mail-auto-save-alist nil "\
  135. +*An associative list of regexps and file names used to automatically
  136. +save outgoing messages into specific folders.  The key is an un-anchored
  137. +regular expression, and the value is a list of folders.")
  138. +
  139. +(defvar mail-auto-save-hook nil "\
  140. +*A function which is called during auto-save after mail-auto-save-alist
  141. +is queried.  It is passed one argument, the value of the From: field.
  142. +Technically, this does not quite count as a hook, so anyone who can think
  143. +of a better name is welcome to change it.")
  144. +
  145. +(defvar mail-auto-save-default nil "\
  146. +*This variable contains a list of folders to which mail is automatically saved
  147. +as a last resort by mail-do-auto-save.")
  148. +
  149.  (autoload 'mail-other-window "sendmail"
  150.    "\
  151.  Like `mail' command, but display mail buffer in another window."
  152.  
  153. Index: emacs-18.57/lisp/sendmail.el
  154. - --- sendmail.el.orig    Wed Jan  9 17:04:09 1991
  155. +++ sendmail.el    Mon Dec  2 13:16:16 1991
  156. @@ -17,8 +17,14 @@
  157.  ;; along with GNU Emacs; see the file COPYING.  If not, write to
  158.  ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  159.  
  160. +;; Modifications by Garrett Wollman to provide Elm-like automatic outbound
  161. +;; mail-filing, based on either mail-auto-save-alist or mail-auto-save-hook,
  162. +;; if the user has defined them.
  163.  
  164. +;; The function "mail-first-address" was written by Tom Emerson <tree@uvm.edu>
  165. +
  166.  (provide 'sendmail)
  167. +(require 'mail-utils)            ; needed for auto-saving
  168.  
  169.  ;(defconst mail-self-blind nil
  170.  ;  "Non-nil means insert BCC to self in messages to be sent.
  171. @@ -209,6 +215,7 @@
  172.          (goto-char (point-min))
  173.          (if (re-search-forward "^FCC:" delimline t)
  174.          (mail-do-fcc delimline))
  175. +        (mail-do-auto-save delimline) ;GW
  176.          ;; If there is a From and no Sender, put it a Sender.
  177.          (goto-char (point-min))
  178.          (and (re-search-forward "^From:"  delimline t)
  179. @@ -302,6 +309,105 @@
  180.      (setq fcc-list (cdr fcc-list))))
  181.      (kill-buffer tembuf)))
  182.  
  183. +;;
  184. +;; This function based on mail-do-fcc, but it grabs the first "To" name
  185. +;; and passes that through mail-find-auto-save to figure out which file
  186. +;; to append to.
  187. +;;
  188. +(defun mail-do-auto-save (header-end)
  189. +  (let (fcc-list
  190. +    (rmailbuf (current-buffer))
  191. +    (tembuf (generate-new-buffer " rmail output"))
  192. +    (case-fold-search t))
  193. +    (save-excursion
  194. +      (goto-char (point-min))
  195. +      (if (re-search-forward "^To:[ \t]*" header-end t)
  196. +      (let ((adr (mail-first-address (mail-strip-quoted-names
  197. +                      (mail-fetch-field "To")))))
  198. +        (setq fcc-list (mail-find-auto-save adr))))
  199. +      (goto-char (marker-position header-end))
  200. +
  201. +      ; if we specified "[no save]" somewhere in the message,
  202. +      ; then don't save it.  This is not quite elm's behavior,
  203. +      ; but it is close enough for most people.
  204. +      (if (re-search-forward "^\\[no save\\]" nil t)
  205. +      (setq fcc-list nil))
  206. +      (set-buffer tembuf)
  207. +      (erase-buffer)
  208. +      (insert "\nFrom " (user-login-name) " "
  209. +          (current-time-string) "\n")
  210. +      (insert-buffer-substring rmailbuf)
  211. +      ;; Make sure messages are separated.
  212. +      (goto-char (point-max))
  213. +      (insert ?\n)
  214. +      (goto-char 2)
  215. +      ;; ``Quote'' "^From " as ">From "
  216. +      ;;  (note that this isn't really quoting, as there is no requirement
  217. +      ;;   that "^[>]+From " be quoted in the same transparent way.)
  218. +      (let ((case-fold-search nil))
  219. +    (while (search-forward "\nFrom " nil t)
  220. +      (forward-char -5)
  221. +      (insert ?>)))
  222. +      (while fcc-list
  223. +    (let ((buffer (get-file-buffer (car fcc-list))))
  224. +      (if buffer
  225. +          ;; File is present in a buffer => append to that buffer.
  226. +          (let ((curbuf (current-buffer))
  227. +            (beg (point-min)) (end (point-max)))
  228. +        (save-excursion
  229. +          (set-buffer buffer)
  230. +          (goto-char (point-max))
  231. +          (insert-buffer-substring curbuf beg end)))
  232. +        ;; Else append to the file directly.
  233. +        (write-region (point-min) (point-max) (car fcc-list) t)))
  234. +    (setq fcc-list (cdr fcc-list))))
  235. +    (kill-buffer tembuf)))
  236. +
  237. +;;
  238. +;; mail-find-auto-save looks at the argument string and tries
  239. +;; to find a way to auto-save it.
  240. +;;
  241. +(defun mail-find-auto-save (to-field)
  242. +  "Try to find a reasonable place to auto-save a message to TO-FIELD.
  243. +This function first checks mail-auto-save-alist, then it tries calling
  244. +mail-auto-save-hook, and then it returns the value of mail-auto-save-default."
  245. +  (if to-field
  246. +      (let ((one-try (mail-regex-assq to-field mail-auto-save-alist)))
  247. +    (if (null one-try)
  248. +        (or (null mail-auto-save-hook)
  249. +        (setq one-try
  250. +              (apply mail-auto-save-hook
  251. +                 (list to-field)))))
  252. +    (if (null one-try)
  253. +        (setq one-try mail-auto-save-default))
  254. +    one-try)
  255. +    nil))
  256. +
  257. +;;
  258. +;; mail-regex-assq is like assq, but uses string-match as the testing
  259. +;; predicate
  260. +;;
  261. +(defun mail-regex-assq (key alist)
  262. +  "Acts like assq, but using string-match as the key-comparison predicate."
  263. +  (if (null alist)
  264. +      nil
  265. +    (if (string-match (car (car alist)) key)
  266. +    (cdr (car alist))
  267. +      (mail-regex-assq key (cdr alist)))))
  268. +
  269. +
  270. +;;; This function written by Tom Emerson...
  271. +;;; Given a string containing a group of comma separated addresses
  272. +;;; (such as that returned by mail-fetch-field) the following
  273. +;;; function returns the first address in the list.
  274. +(defun mail-first-address (addresses)
  275. +  (let* ((clean (substring addresses 
  276. +               (or (string-match "[^ \t]" addresses) 0)))
  277. +     (pos (string-match "[ \t]*,[ \t]*" clean)))
  278. +    (if (not pos) clean
  279. +      (substring clean 0 pos))))
  280. +
  281. +
  282.  (defun mail-to ()
  283.    "Move point to end of To-field."
  284.    (interactive)
  285.  
  286. Index: vm-4.41/vm-save.el
  287. - --- vm-save.el.orig    Fri Nov 29 01:05:56 1991
  288. +++ vm-save.el    Mon Dec  2 12:44:16 1991
  289. @@ -15,8 +15,15 @@
  290.  ;;; along with this program; if not, write to the Free Software
  291.  ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  292.  
  293. +;; changes by Garrett Wollman to use mail-find-auto-save if
  294. +;; vm-use-mail-auto-save is defined
  295. +
  296.  (require 'vm)
  297.  
  298. +(defvar vm-use-mail-auto-save nil "\
  299. +Tells VM to use the auto-save routine built into our version of
  300. +sendmail for selecting which buffer to save messages in.")
  301. +
  302.  ;; (match-data) returns the match data as MARKERS, often corrupting
  303.  ;; it in the process due to buffer narrowing, and the fact that buffers are
  304.  ;; indexed from 1 while strings are indexed from 0. :-(
  305. @@ -28,6 +35,18 @@
  306.                 '(0 1 2 3 4 5 6 7 8 9)))))
  307.  
  308.  (defun vm-auto-select-folder (mp)
  309. +  (if vm-use-mail-auto-save
  310. +      (progn
  311. +    (require 'sendmail)
  312. +    (new-vm-auto-select-folder mp))
  313. +    (old-vm-auto-select-folder mp)))
  314. +
  315. +(defun new-vm-auto-select-folder (mp)
  316. +  (car-safe (mail-find-auto-save
  317. +         (or (vm-get-header-contents (car mp) "From")
  318. +         (vm-get-header-contents (car mp) "To")))))
  319. +
  320. +(defun old-vm-auto-select-folder (mp)
  321.    (condition-case ()
  322.        (catch 'match
  323.      (let (header alist tuple-list)
  324.