home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / mh-scraps < prev    next >
Encoding:
Text File  |  1990-07-22  |  8.8 KB  |  257 lines
  1. ;From utkcs2!emory!swrinde!zaphod.mps.ohio-state.edu!uwm.edu!bbn.com Tue Jun  5 13:04:42 EDT 1990
  2. ;Article 4363 of comp.emacs:
  3. ;Path: utkcs2!emory!swrinde!zaphod.mps.ohio-state.edu!uwm.edu!bbn.com
  4. ;>From: jr@bbn.com (John Robinson)
  5. ;Newsgroups: comp.emacs
  6. ;Subject: Re: Some nice utilities for mh-e.el
  7. ;Summary: my own private stock
  8. ;Message-ID: <56974@bbn.BBN.COM>
  9. ;Date: 5 Jun 90 13:45:34 GMT
  10. ;References: <9006050614.AA05560@somewhere>
  11. ;Sender: news@bbn.com
  12. ;Reply-To: jr@bbn.com (John Robinson)
  13. ;Organization: BBN Systems and Technologies Corporation, Cambridge MA
  14. ;Lines: 238
  15. ;In-reply-to: aks@SOMEWHERE.BERKELEY.EDU (Alan Stebbens)
  16. ;
  17. ;In article <9006050614.AA05560@somewhere>, aks@SOMEWHERE (Alan Stebbens) writes:
  18. ;>Again, trying to make mh-e and Emacs Do The Right Thing, I've developed
  19. ;>the following code which you may also find useful.
  20. ;
  21. ;This prompted me to post the following code scraps.  I use them a lot
  22. ;to cope with the comp.emacs mail repeater on a VM (groan) system,
  23. ;which insists on munging the headers most (but not all!) of the time.
  24. ;I have enhanced the mh-reply command to accept three more reply types,
  25. ;and added reply templates to my ~/Mail that make the new response
  26. ;styles.
  27. ;
  28. ;Also, I have written a function that tries to pick up the sender's
  29. ;address from the .signature of the replied-to message.  It could be
  30. ;more clever than it is.  It doesn't grok multi-line to: fields, and it
  31. ;should look further back in the message for the better address.  I
  32. ;optimistically called it smart-address.el.  It needs additional hook
  33. ;functions for rmail and vm.el (and rnews and gnus and jnews and ...).
  34. ;
  35. ;Still wanted: little functions to "unwrap" net addresses.  I have in
  36. ;mind the transformation: a%b.c.d@e.f.g => a@b.c.d.  Maybe also
  37. ;a!b!c!d!u => u@d.uucp.  Or by steps: b!c!d!u@a.uucp => c!d!u@b.uucp,
  38. ;etc.  Anyone done this (it isn't hard, just haven't gotten around to
  39. ;it)?
  40. ;
  41. ;Enjoy.
  42. ;--
  43. ;/jr, nee John Robinson     Life did not take over the globe by combat,
  44. ;jr@bbn.com or bbn!jr          but by networking -- Lynn Margulis
  45. ;--------
  46. ;;; add u option: generate usenet follow-up style with format file
  47. ;;; followcomps, which must be in user's ~/Mail directory, and o
  48. ;;; option: reply only to from: field, ignoring reply-to:, using
  49. ;;; onlycomps.
  50.  
  51. (defun mh-reply (prefix-provided msg)
  52.   "Reply to a MESSAGE (default: displayed message).
  53. If (optional) prefix argument provided, then include the message in the reply."
  54.   (interactive (list current-prefix-arg (mh-get-msg-num t)))
  55.   (let ((minibuffer-help-form
  56.      "from => Sender only\nto => Sender and primary recipients\ncc or all => Sender and all recipients\nusenet => Usenet-style followup to to: address\nonly from => Use From: field, ignoring reply-to"))
  57.     (let ((reply-to (or mh-reply-default-reply-to
  58.             (completing-read "Reply to whom: "
  59.                      '(("from") ("to") ("cc") ("all") ("usenet") ("only from"))
  60.                      nil
  61.                      t)))
  62.       (folder mh-current-folder)
  63.       (show-buffer mh-show-buffer)
  64.       (config (current-window-configuration)))
  65.       (message "Composing a reply...")
  66.       (cond ((or (equal reply-to "from") (equal reply-to ""))
  67.          (apply 'mh-exec-cmd "repl"
  68.             "-build"
  69.             "-nodraftfolder" mh-current-folder
  70.             msg
  71.             "-nocc" "all"
  72.             (if prefix-provided
  73.             (list "-filter" "mhl.reply"))))
  74.         ((equal reply-to "to")
  75.          (apply 'mh-exec-cmd "repl"
  76.             "-build"
  77.             "-nodraftfolder" mh-current-folder
  78.             msg
  79.             "-cc" "to"
  80.             (if prefix-provided
  81.             (list "-filter" "mhl.reply"))))
  82.         ((equal reply-to "usenet")
  83.          (apply 'mh-exec-cmd "repl"
  84.             "-build"
  85.             "-form" "followcomps"
  86.             "-nodraftfolder" mh-current-folder
  87.             msg
  88.             "-cc" "to"
  89.             (if prefix-provided
  90.             (list "-filter" "mhl.reply"))))
  91.         ((equal reply-to "only from")
  92.          (apply 'mh-exec-cmd "repl"
  93.             "-build"
  94.             "-form" "onlycomps"
  95.             "-nodraftfolder" mh-current-folder
  96.             msg
  97.             "-nocc" "all"
  98.             (if prefix-provided
  99.             (list "-filter" "mhl.reply"))))
  100.         ((or (equal reply-to "cc") (equal reply-to "all"))
  101.          (apply 'mh-exec-cmd "repl"
  102.             "-build"
  103.             "-nodraftfolder" mh-current-folder
  104.             msg
  105.             "-cc" "all" "-nocc" "me"
  106.             (if prefix-provided
  107.             (list "-filter" "mhl.reply")))))
  108.  
  109.       (let ((draft (mh-read-draft "reply"
  110.                   (mh-expand-file-name "reply" mh-user-path)
  111.                   t)))
  112.     (delete-other-windows)
  113.     (set-buffer-modified-p nil)
  114.  
  115.     (let ((to (mh-get-field "To:"))
  116.           (subject (mh-get-field "Subject:"))
  117.           (cc (mh-get-field "Cc:")))
  118.       (goto-char (point-min))
  119.       (mh-goto-header-end 1)
  120.       (if (not prefix-provided)
  121.           (mh-display-msg msg folder))
  122.       (mh-add-msgs-to-seq msg 'answered t)
  123.       (message "Composing a reply...done")
  124.       (mh-compose-and-send-mail draft "" folder msg to subject cc
  125.                     "-" "Replied:" config))))))
  126.  
  127. ;; smart-address.el
  128. ;; Command for picking up an address from a signature of a replied-to
  129. ;; message and replave the address in the To: field therewith.
  130.  
  131. ;; List of search patterns for extracting addresses from the
  132. ;; replied-to message.  Used in order until one hits.  Use grouping
  133. ;; operators to delimit what is actually the address.
  134.  
  135. (defvar smart-address-search-list
  136.   (list 
  137.    "domain\\W*\\([^     ([{<]+@[^]     \n)}>]+\\)"
  138.    "internet\\W*\\([^     ([{<]+@[^]     \n)}>]+\\)"
  139.    "arpanet\\W*\\([^     ([{<]+@[^]     \n)}>]+\\)"
  140.    "bitnet\\W*\\([^     ([{<]+@[^]     \n)}>]+\\)"
  141.    "\\([^     \n([{<]+@[^]     \n)}>]+\\)"
  142.    "\\([^     \n([{<]+![^]     \n)}>]+\\)")
  143.   "List of search patterns for extracting an address from a signature.
  144. Lists are used in order until one matches.  The  \\\\( and \\\\) in
  145. the first match surround the address to pick up.")
  146.  
  147. ;; Per-buffer variable for getting to buffer for replied-to message
  148.  
  149. (defvar smart-address-other-buffer nil
  150.   "Function which returns the buffer holding the message this is a reply to")
  151.  
  152. (make-variable-buffer-local 'smart-address-other-buffer)
  153.  
  154. ;; Set things up for gnews replies
  155.  
  156. (defun gnews-msg-buffer ()
  157.   mail-reply-buffer)
  158.  
  159. (setq group-reply-hook '(lambda nil
  160.               (fset 'smart-address-other-buffer 
  161.                 'gnews-msg-buffer)))
  162.  
  163. ;; Set things up for mh-e replies
  164.  
  165. (defun mh-msg-buffer ()
  166.   (and mh-sent-from-msg mh-sent-from-folder
  167.        (progn
  168.      (set-buffer mh-sent-from-folder)
  169.      mh-show-buffer)))
  170.  
  171. (setq mh-letter-mode-hook '(lambda nil 
  172.                  (fset 'smart-address-other-buffer
  173.                    'mh-msg-buffer)))
  174.  
  175. (defun smart-address-yank ()
  176.   "Replace addressee with address from from signature of replied-to message.
  177. Replace entire To: field.
  178. Buffer local variable smart-address-other-buffer holds function to return
  179. the name of the other buffer."
  180.   (interactive)
  181.   (let ((old-buffer (current-buffer))
  182.     (search-list smart-address-search-list)
  183.     (search-result nil)
  184.     (case-fold-search t)
  185.     beg end)
  186.     (set-buffer (funcall 'smart-address-other-buffer))
  187.     (save-excursion
  188.       (goto-char (point-max))
  189.       (re-search-backward "[^     \n]")
  190.       (end-of-line)
  191.       (setq end (point))
  192.       (re-search-backward "^[     \n]*$\\|^--$")
  193.       (forward-line 1)
  194.       (setq beg (point))
  195.       (and (> end beg)
  196.        (while search-list
  197.          (goto-char beg)
  198.          (if (re-search-forward (car search-list) end t)
  199.          (setq search-result (buffer-substring (match-beginning 1) (match-end 1))
  200.                search-list nil)
  201.            (setq search-list (cdr search-list))))))
  202.     (set-buffer old-buffer)
  203.     (if search-result
  204.     (save-excursion
  205.       (goto-char (point-min))
  206.       (re-search-forward "^To:[     ]*")
  207.       (end-of-line)
  208.       (setq end (point))
  209.       (beginning-of-line)
  210.       (re-search-forward "^To:[     ]*")
  211.       (or
  212.        (save-excursion
  213.          (re-search-forward "\\(\\).*\\([     ](.*)\\)" end t))
  214.        (save-excursion
  215.          (re-search-forward "\\(.*<\\).*\\(>\\)" end t))
  216.        (re-search-forward "\\(\\).*\\(\\)$"))
  217.       (replace-match (concat "\\1" search-result "\\2")))
  218.       (error "No better address found"))))
  219. --------
  220. ::::::::::::::
  221. followcomps
  222. ::::::::::::::
  223. %(lit)%(formataddr{to})\
  224. %<(nonnull)%(void(width))%(putaddr To: )\n%>\
  225. %<{fcc}Fcc: %{fcc}\n%>\
  226. %<{subject}Subject: Re: %{subject}\n%>\
  227. %<{date}\
  228. %(lit)%(formataddr %<{reply-to}%|%<{from}%|%{sender}%>%>)\
  229. %<(nonnull)%(void(width))\
  230. In-reply-to: %<{reply-to}%(putstr(friendly{reply-to}))\
  231. %|%<{from}%(putstr(friendly{from}))\
  232. %|{sender}%(putstr(friendly{sender}))%>%>'s\
  233. %|In-reply-to: The%>\
  234.  message of \
  235. %<(nodate{date})%{date}%|%(tws{date})%>.%<{message-id}
  236.              %{message-id}%>\n%>\
  237. Organization: BBN Systems and Technologies Corporation, Cambridge MA
  238. --------
  239. ::::::::::::::
  240. onlycomps
  241. ::::::::::::::
  242. %(lit)%(formataddr{from})\
  243. %<(nonnull)%(void(width))%(putaddr To: )\n%>\
  244. %(lit)%(formataddr{to})%(formataddr{cc})%(formataddr(me))\
  245. %<(nonnull)%(void(width))%(putaddr cc: )\n%>\
  246. %<{fcc}Fcc: %{fcc}\n%>\
  247. %<{subject}Subject: Re: %{subject}\n%>\
  248. %<{date}In-reply-to: Your message of \
  249. %<(nodate{date})%{date}%|%(tws{date})%>.%<{message-id}
  250.              %{message-id}%>\n%>\
  251. Organization: BBN Systems and Technologies Corporation, Cambridge MA
  252. --------
  253. /jr, nee John Robinson     Life did not take over the globe by combat,
  254. jr@bbn.com or bbn!jr          but by networking -- Lynn Margulis
  255.  
  256.  
  257.