home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / mh-util.el < prev    next >
Encoding:
Text File  |  1990-07-22  |  15.9 KB  |  445 lines
  1. ;From utkcs2!emory!swrinde!ucsd!ucbvax!SOMEWHERE.BERKELEY.EDU!aks Tue Jun  5 08:30:50 EDT 1990
  2. ;Article 4362 of comp.emacs:
  3. ;Path: utkcs2!emory!swrinde!ucsd!ucbvax!SOMEWHERE.BERKELEY.EDU!aks
  4. ;>From: aks@SOMEWHERE.BERKELEY.EDU (Alan Stebbens)
  5. ;Newsgroups: comp.emacs
  6. ;Subject: Some nice utilities for mh-e.el
  7. ;Message-ID: <9006050614.AA05560@somewhere>
  8. ;Date: 5 Jun 90 06:14:02 GMT
  9. ;Sender: daemon@ucbvax.BERKELEY.EDU
  10. ;Lines: 431
  11. ;
  12. ;One of the most frequent things I do when reading mail via mh-e in Emacs
  13. ;is to delete a bunch of mail concerning the _same_ subject.  The next
  14. ;frequent thing is to view a piece of mail, and then wonder if someone
  15. ;else in my organization has answered it; that is, I want to know if
  16. ;there is a piece of mail with the same subject, or, thirdly, another
  17. ;reply by the same sender.  I often resort to using one of the builtin
  18. ;search commands, all of which, however require either proper prior
  19. ;postioning (how's _that_ for assonance) or manual input.
  20. ;
  21. ;Again, trying to make mh-e and Emacs Do The Right Thing, I've developed
  22. ;the following code which you may also find useful.  Included with it are
  23. ;some other mh-e utilities I've acquired from the net; if you recognize a
  24. ;function as being originally your own, please speak up, and I'll be glad
  25. ;to place your name in its proper place of honor.
  26. ;
  27. ;"mh-util.el" consists of the following goodies (currently :^):
  28. ;
  29. ;mh-next-msg-same-kind    N    [mh-folder-map]
  30. ;mh-prev-msg-same-kind    P    [mh-folder-map]
  31. ;    Functions to move to the next message of the same kind, either
  32. ;    by subject or by sender, depending upon either the variable
  33. ;    mh-search-kind-default, or the prefix argument.
  34. ;
  35. ;mh-toggle-kind-search    T    [mh-folder-map]
  36. ;    Allows you to easily switch between subject searching and sender
  37. ;    searching.
  38. ;
  39. ;mh-delete-by-subject    D    [mh-folder-map]
  40. ;    A function to delete messages in the current folder by subject
  41. ;
  42. ;mh-delete-by-body    M-d    [mh-folder-map]
  43. ;    A function to delete message by a body text pattern.
  44. ;
  45. ;mh-do-pick-delete    C-c C-d    [mh-pick-map]
  46. ;    An enhancement to M-x mh-pick-search, so that after invoking
  47. ;    mh-pick-search to construct a pick pattern, you can do C-c C-d
  48. ;    to cause the pattern to be used as a search-and-delete, instead
  49. ;    of just putting it into a sequence list.
  50. ;
  51. ;mh-toggle-headers    M-t     [mh-folder-map]
  52. ;    A function to toggle MH headers
  53. ;
  54. ;and
  55. ;
  56. ;mh-next-pick-field
  57. ;    A "replacement" for the original mh-e function, which did not
  58. ;    like header values with embedded colons, like:
  59. ;
  60. ;    "Subject: Re: blah blah"
  61. ;
  62. ;    The new function has a modified regexp which doesn't mind the
  63. ;    embedded colons.
  64. ;
  65. ;To use this, place the following code in a file in your "load-path",
  66. ;called "mh-utils.el", (you may byte-compile it if you wish), and put 
  67. ;
  68. ;  (require 'mh-utils)
  69. ;
  70. ;in your ~/.emacs file.
  71. ;
  72. ;One thing you may notice: the next-msg-by-kind functions use only the
  73. ;folder scan listing to discover the message, while the delete-by-KIND
  74. ;functions use a pick-search.  There is no strong philosophical reason
  75. ;for this, except that the tools to do the multiple sequences, which is
  76. ;what you need for the multiple deletion task, were already set up to use
  77. ;pick sequences, while the searching by KIND was easier to write using
  78. ;the folder scan listing.  Feel free to comment.
  79. ;
  80. ;Enjoy
  81. ;
  82. ;Alan Stebbens        <aks@hub.ucsb.edu>             (805) 961-3221
  83. ;     Center for Computational Sciences and Engineering (CCSE)
  84. ;          University of California, Santa Barbara (UCSB)
  85. ;           3111 Engineering I, Santa Barbara, CA 93106
  86. ;
  87. ;============================= cut here ===================================
  88. ;; mh-util.el
  89. ;; $Header$
  90. ;;
  91. ;;  Copyright (C) 1990 Free Software Foundation, Inc.
  92. ;;
  93. ;;     Author:  Alan Stebbens <aks@hub.ucsb.edu>
  94. ;;    Please send suggestions and corrections to the above address.
  95. ;;
  96. ;;; GNU Emacs is distributed in the hope that it will be useful, but
  97. ;;; without any warranty.  No author or distributor accepts
  98. ;;; responsibility to anyone for the consequences of using it or for
  99. ;;; whether it serves any particular purpose or works at all, unless he
  100. ;;; says so in writing.
  101.  
  102. ;;; Everyone is granted permission to copy, modify and redistribute GNU
  103. ;;; Emacs, but only under the conditions described in the document "GNU
  104. ;;; Emacs copying permission notice".  An exact copy of the document is
  105. ;;; supposed to have been given to you along with GNU Emacs so that you
  106. ;;; can know how you may redistribute it all.  It should be in a file
  107. ;;; named COPYING.  Among other things, the copyright notice and this
  108. ;;; notice must be preserved on all copies.
  109. ;;
  110. ;; This file contains enhancements to the mh-e package, a GNU Emacs 
  111. ;; front end to the MH mail system, providing:
  112. ;;
  113. ;;    o  mh-toggle-headers     - show all/default headers
  114. ;;    o  mh-next-msg-same-kind - next message with the same {sender,subject}
  115. ;;    o  mh-prev-msg-same-kind - prev message with the same {sender,subject}
  116. ;;    o  mh-delete-by-subject  - delete messages with given subject
  117. ;;    o  mh-delete-by-body     - delete messages with given body text
  118. ;;    o  mh-do-pick-delete     - delete messages matching pick pattern
  119. ;;
  120. ;; See the end of this file for the new key bindings.
  121. ;;
  122. ;; This file also fixes a bug in mh-next-pick-field, which refuses to allow
  123. ;; colons in the value of any component.
  124. ;;
  125. ;; Last Edited:
  126. ;; 
  127. ;; Mon Jun  4 21:16:26 1990 by Alan Stebbens (aks at somewhere.ucsb.edu)
  128. ;;      Added mh-{next,prev,find}-same-{kind,sender,subject},
  129. ;;     and mh-match-msg.
  130. ;;     Made mh-do-pick-delete call mh-next-msg at end.
  131. ;; 
  132. ;; Fri May 25 11:19:06 1990 by Alan Stebbens (aks at somewhere.ucsb.edu)
  133. ;;      Included mh-next-pick-field to fix bug (until fixed in
  134. ;;      mh-e.el).
  135. ;; 
  136. ;; Fri May 25 10:22:39 1990 by Alan Stebbens (aks at somewhere.ucsb.edu)
  137. ;;      Initial version.
  138. ;;
  139.  
  140. (require 'mh-e)                ; be sure mh-e is loaded first
  141.  
  142.  
  143. ;; mh-toggle-headers
  144. ;;
  145. ;; Display or not, all visible headers
  146.  
  147. (defun mh-toggle-headers (arg) "\
  148. Set display of all message headers according to ARG: if nil, toggle the
  149. current value; if 0, reset to default value (nil); if 1, show all
  150. message headers."
  151.   (interactive "p")
  152.   (setq mh-visible-headers (cond ((or (eq 4 arg) 
  153.                       (and (eq 1 arg)
  154.                        (not mh-visible-headers)))
  155.                   ".*")))
  156.   (save-excursion
  157.     (if (get-buffer mh-show-buffer)
  158.     (kill-buffer mh-show-buffer)))
  159.   (mh-show (mh-get-msg-num t)))
  160.  
  161.  
  162.  
  163. (defvar mh-kind-search-default 'subject "\
  164. *This variable should be set to either 'subject or 'sender, indicating the
  165. default kind of search when used with \\[mh-next-msg-same-kind] or
  166. \\[mh-prev-msg-same-kind].")
  167.  
  168. ;; The following constants tailor the location in the folder scan listing of
  169. ;; the subject and body.  If you ever change the format of the scan listing
  170. ;; produced by mh-scan-folder, then you may have to alter these constants also.
  171.  
  172. (defconst mh-cur-sender-offset 12
  173.   "Offset in the current folder scan where the sender name begins.")
  174.  
  175. (defconst mh-cur-subject-offset 31
  176.   "Offset in the current folder scan where the subject begins.")
  177.  
  178. (defconst mh-cur-scan-sender-regexp
  179.   (concat "^"   (make-string mh-cur-sender-offset ?\. )
  180.       "\\(" (make-string (- mh-cur-subject-offset mh-cur-sender-offset) ?\. )
  181.       "\\)")
  182.   "Regexp to match the sender portion of the current message.")
  183.  
  184. (defconst mh-cur-scan-subject-regexp 
  185.   (concat "^" (make-string mh-cur-subject-offset ?\. )
  186.       "\\(\\([^<\n]\\|<[^<\n]\\)+\\)\\(<<\\|$\\)")
  187.   "Regexp which matches the subject of the current scan line.")
  188.  
  189. (defconst mh-good-sender-regexp 
  190.   (concat mh-good-msg-regexp
  191.       (make-string (- mh-cur-sender-offset (1+ mh-cmd-note)) ?\. ))
  192.   "Regexp used to match good message up to the sender portion.")
  193.  
  194. (defconst mh-good-subject-regexp
  195.   (concat mh-good-msg-regexp
  196.       (make-string (- mh-cur-subject-offset (1+ mh-cmd-note)) ?\. ))
  197.   "Regexp matching a good message up to the subject portion.")
  198.  
  199. (defconst mh-cur-scan-body-regexp "<<[ \t]*\\(.*\\)"
  200.   "Regexp which matches the body included as part of the current scan line.")
  201.  
  202. (defconst mh-delete-body-prompt-length 50
  203.   "Default length of the initial substring prompt for \\[mh-delete-by-body]")
  204.  
  205. ;; mh-next-msg-same
  206.  
  207. (defun mh-next-msg-same-kind (arg) "\
  208. Search forward in the current folder for another message with the same
  209. subject, as the current message.  If prefix ARG is given, search by sender
  210. name rather than subject."
  211.   (interactive "P")
  212.   (funcall (mh-same-kind-func arg) 'forward))
  213.  
  214. ;; mh-prev-same-subject
  215.  
  216. (defun mh-prev-msg-same-kind (arg) "\
  217. Search backward in the current folder for another message with the same
  218. subject as the current message.  If prefix ARG is given, search by sender
  219. name rather than subject."
  220.   (interactive "P")
  221.   (funcall (mh-same-kind-func arg) 'backward))
  222.  
  223. ;; mh-same-kind-func
  224.  
  225. (defun mh-same-kind-func (arg) 
  226.   (symbol-function 
  227.    (intern (concat "mh-find-msg-same-" 
  228.            (if arg 
  229.                (if (eq mh-kind-search-default 'sender) "subject" "sender")
  230.              (if (eq mh-kind-search-default 'sender) "sender" "subject"))))))
  231.  
  232. (defun mh-toggle-kind-search () "\
  233. Toggle the kind of message search between 'subject and 'sender."
  234.   (interactive)
  235.   (setq mh-kind-search-default 
  236.     (if (eq mh-kind-search-default 'sender) 'subject 'sender))
  237.   (message "Next default searches will be %s kind" (symbol-name mh-kind-search-default)))
  238.  
  239. ;; mh-find-same-subject
  240.  
  241. (defun mh-find-msg-same-subject (direction) "\
  242. Search according to DIRECTION ('forward or 'backward) for another message
  243. with the same subject as the current message."
  244.   (let* ((subject (save-excursion
  245.             (beginning-of-line)
  246.             (looking-at mh-cur-scan-subject-regexp)
  247.             (buffer-substring (match-beginning 1) (match-end 1))))
  248.      (regexp (concat mh-good-subject-regexp
  249.              (regexp-quote subject))))
  250.     (mh-match-msg direction regexp "subject" subject)))
  251.  
  252. ;; mh-find-msg-same-sender
  253.  
  254. (defun mh-find-msg-same-sender (direction) "\
  255. Search the current folder given DIRECTION for another message with the
  256. same sender."
  257.   (let ((sender (save-excursion
  258.           (beginning-of-line)
  259.           (looking-at mh-cur-scan-sender-regexp)
  260.           (buffer-substring (match-beginning 1) (match-end 1)))))
  261.     (if (string-match "\\`\\(.+[^ \t]\\)[ \t]+\\'" sender)
  262.     (setq sender (substring sender 0 (match-end 1))))
  263.     (setq regexp (concat mh-good-sender-regexp (regexp-quote sender)))
  264.     (mh-match-msg direction regexp "sender" sender)))
  265.  
  266. ;; mh-match-msg
  267.  
  268. (defun mh-match-msg (direction regexp component value) "\
  269. Find the next message given DIRECTION matching the given REGEXP.
  270. Third and fourth args are COMPONENT and VALUE, for error messages
  271. on search failure."
  272.   (let* ((dir (symbol-name direction))
  273.      (search (intern (concat "re-search-" dir)))
  274.      (adjust-line (intern (concat dir "-line")))
  275.      (msg (save-excursion
  276.         (beginning-of-line (if (eq direction 'forward) 2 0))
  277.         (if (funcall search regexp nil t)
  278.             (mh-get-msg-num nil)))))
  279.     (if (and msg (mh-goto-msg msg))
  280.     (setq mh-next-direction direction)
  281.       (message "No more messages %s with %s: \"%s\"" dir component value)
  282.       (ding))))
  283.  
  284. ;; mh-delete-by-subject
  285. ;; Delete the current msg and any others with the same subject.
  286.  
  287. (defun mh-delete-by-subject (subject) "\
  288. Search the current folder for messages with the given SUBJECT and delete
  289. them."
  290.   (interactive (list (read-string "Delete by subject: " (mh-current-subject))))
  291.   (let ((folder mh-current-folder))
  292.     (set-buffer (get-buffer-create " delete-pattern"))
  293.     (mh-make-pick-template)
  294.     (mh-insert-fields "Subject:" subject)
  295.     (setq mh-searching-folder folder)
  296.     (mh-do-pick-delete)))
  297.  
  298. ;; mh-delete-by-body
  299. ;; Delete any messages with the same body text as the current message.
  300.  
  301. (defun mh-delete-by-body (body) "\
  302. Search the current folder for messages with the given BODY and delete them.
  303. Prompt for BODY if not supplied."
  304.   (interactive (list (read-string "Delete by text: " (mh-current-body))))
  305.   (let ((folder mh-current-folder))
  306.     (set-buffer (get-buffer-create " delete-pattern"))
  307.     (mh-make-pick-template)
  308.     (mh-goto-header-end 1)
  309.     (insert body)
  310.     (setq mh-searching-folder folder)
  311.     (mh-do-pick-delete)))
  312.  
  313. ;; mh-current-subject
  314.  
  315. (defun mh-current-subject ()
  316.   "Get the current subject, either from the folder scan listing, or from
  317. the current message, if it is being shown."
  318.   (if mh-showing
  319.       (save-window-excursion
  320.     (set-buffer mh-show-buffer)
  321.     (save-excursion
  322.       (mh-get-field "Subject:")))
  323.     (save-excursion
  324.       (beginning-of-line)
  325.       (if (looking-at mh-cur-scan-subject-regexp)
  326.       (buffer-substring (match-beginning 1) (match-end 1))))))
  327.  
  328. ;; mh-current-body
  329.  
  330. (defun mh-current-body ()
  331.   "Get the current message body, either from the folder scan listing, or
  332. from the current message, if it is being shown."
  333.   (let ((str (if mh-showing 
  334.          (save-window-excursion
  335.            (set-buffer mh-show-buffer)
  336.            (save-excursion
  337.              (if (and (mh-goto-header-end 1)
  338.                   (re-search-forward "[^ \t\n]" nil t))
  339.              (let (beg end)
  340.                (setq beg (1- (point)))
  341.                (end-of-line)
  342.                (buffer-substring beg (point))))))
  343.            (save-excursion 
  344.          (let (end)
  345.            (end-of-line)
  346.            (setq end (point))
  347.            (beginning-of-line)
  348.            (if (re-search-forward mh-cur-scan-body-regexp end t)
  349.                (buffer-substring (match-beginning 1) (match-end 1))))))))
  350.     (if (and str (> (length str) mh-delete-body-prompt-length))
  351.     (substring str 0 mh-delete-body-prompt-length)
  352.       str)))
  353.     
  354. ;; mh-do-pick-delete
  355. ;;
  356. ;; Take the current pick-pattern buffer and use it to search and match messages
  357. ;; to delete.
  358. ;; (copied from mh-do-pick-search, but we use a different sequence name: 'delete)
  359.  
  360. (defun mh-do-pick-delete ()
  361.   "Find messages that match the qualifications in the current pattern buffer.
  362. Messages are searched for in the folder named in mh-searching-folder.
  363. Delete messages found."
  364.   (interactive)
  365.   (let ((pattern-buffer (buffer-name))
  366.     (searching-buffer mh-searching-folder)
  367.     (range)
  368.     (pattern nil)
  369.     (new-buffer nil))
  370.     (save-excursion
  371.       (cond ((get-buffer searching-buffer)
  372.          (set-buffer searching-buffer)
  373.          (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num)))
  374.         (t
  375.          (mh-make-folder searching-buffer)
  376.          (setq range "all")
  377.          (setq new-buffer t))))
  378.     (message "Searching %s..." searching-buffer)
  379.     (goto-char (point-min))
  380.     (while (setq pattern (mh-next-pick-field pattern-buffer))
  381.       (setq msgs (mh-seq-from-command searching-buffer
  382.                       'delete
  383.                       (nconc (cons "pick" pattern)
  384.                          (list searching-buffer
  385.                            range
  386.                            "-sequence" "delete"
  387.                            "-list"))))
  388.       (setq range "delete"))
  389.     (message "Searching %s...done" searching-buffer)
  390.     (if new-buffer
  391.     (mh-scan-folder searching-buffer msgs)
  392.     (switch-to-buffer searching-buffer))
  393.     (delete-other-windows)
  394.     (message "Deleting %d messages..." (length msgs))
  395.     (mh-delete-msg-no-motion 'delete)
  396.     (message "Deleted %d messages." (length msgs))
  397.     (mh-next-msg)))
  398.  
  399. ;; Make new commands available by keystroke
  400.  
  401. (define-key mh-folder-mode-map "D"         'mh-delete-by-subject)
  402. (define-key mh-folder-mode-map "\M-d"      'mh-delete-by-body)
  403. (define-key mh-folder-mode-map "\M-t"       'mh-toggle-headers)
  404. (define-key mh-folder-mode-map "N"       'mh-next-msg-same-kind)
  405. (define-key mh-folder-mode-map "P"       'mh-prev-msg-same-kind)
  406. (define-key mh-folder-mode-map "T"       'mh-toggle-kind-search)
  407.  
  408. (define-key mh-pick-mode-map   "\C-c\C-d"  'mh-do-pick-delete)
  409.  
  410.  
  411. ;;
  412. ;; Fixes the bug in the standard mh-e.el (modified the regexp).
  413. ;;
  414.  
  415. (defun mh-next-pick-field (buffer)
  416.   ;; Return the next piece of a pick argument that can be extracted from the
  417.   ;; BUFFER.  Returns nil if no pieces remain.
  418.   (set-buffer buffer)
  419.   (let ((case-fold-search t))
  420.     (cond ((eobp)
  421.        nil)
  422.       ((re-search-forward "^\\([a-z][^:\n \t]*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
  423.        (let* ((component
  424.            (format "-%s"
  425.                (downcase (buffer-substring (match-beginning 1)
  426.                                (match-end 1)))))
  427.           (pat (buffer-substring (match-beginning 2) (match-end 2))))
  428.            (forward-line 1)
  429.            (list component pat)))
  430.       ((re-search-forward "^-*$" nil t)
  431.        (forward-char 1)
  432.        (let ((body (buffer-substring (point) (point-max))))
  433.          (if (and (> (length body) 0) (not (equal body "\n")))
  434.          (list "-search" body)
  435.          nil)))
  436.       (t
  437.        nil))))
  438.  
  439.  
  440. ;; Announce that we're loaded
  441.  
  442. (provide 'mh-util)
  443.  
  444.  
  445.