home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / emacs-19.28-src.tgz / tar.out / fsf / emacs / lisp / mh-pick.el < prev    next >
Lisp/Scheme  |  1996-09-28  |  6KB  |  178 lines
  1. ;;; mh-pick --- make a search pattern and search for a message in mh-e
  2. ;; Time-stamp: <93/08/22 22:56:53 gildea>
  3.  
  4. ;; Copyright 1993 Free Software Foundation, Inc.
  5.  
  6. ;; This file is part of mh-e.
  7.  
  8. ;; mh-e is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; mh-e is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with mh-e; see the file COPYING.  If not, write to
  20. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;;; Commentary:
  23.  
  24. ;; Internal support for mh-e package.
  25.  
  26. ;;; Code:
  27.  
  28. (provide 'mh-pick)
  29. (require 'mh-e)
  30.  
  31. (defvar mh-pick-mode-map (make-sparse-keymap)
  32.   "Keymap for searching folder.")
  33.  
  34. (defvar mh-pick-mode-hook nil
  35.   "Invoked in `mh-pick-mode' on a new pattern.")
  36.  
  37. (defvar mh-searching-folder nil
  38.   "Folder this pick is searching.")
  39.  
  40. (defun mh-search-folder (folder)
  41.   "Search FOLDER for messages matching a pattern."
  42.   (interactive (list (mh-prompt-for-folder "Search"
  43.                        mh-current-folder
  44.                        t)))
  45.   (switch-to-buffer-other-window "pick-pattern")
  46.   (if (or (zerop (buffer-size))
  47.       (not (y-or-n-p "Reuse pattern? ")))
  48.       (mh-make-pick-template)
  49.     (message ""))
  50.   (setq mh-searching-folder folder))
  51.  
  52. (defun mh-make-pick-template ()
  53.   ;; Initialize the current buffer with a template for a pick pattern.
  54.   (erase-buffer)
  55.   (insert "From: \n"
  56.       "To: \n"
  57.       "Cc: \n"
  58.       "Date: \n"
  59.       "Subject: \n"
  60.       "---------\n")
  61.   (mh-pick-mode)
  62.   (goto-char (point-min))
  63.   (end-of-line))
  64.  
  65. (put 'mh-pick-mode 'mode-class 'special)
  66.  
  67. (defun mh-pick-mode ()
  68.   "Mode for creating search templates in mh-e.\\<mh-pick-mode-map>
  69. After each field name, enter the pattern to search for.  To search
  70. the entire message, supply the pattern in the \"body\" of the template.
  71. When you have finished, type  \\[mh-do-pick-search]  to do the search.
  72. \\{mh-pick-mode-map}
  73. Turning on mh-pick-mode calls the value of the variable mh-pick-mode-hook
  74. if that value is non-nil."
  75.   (interactive)
  76.   (kill-all-local-variables)
  77.   (make-local-variable 'mh-searching-folder)
  78.   (use-local-map mh-pick-mode-map)
  79.   (setq major-mode 'mh-pick-mode)
  80.   (mh-set-mode-name "MH-Pick")
  81.   (run-hooks 'mh-pick-mode-hook))
  82.  
  83.  
  84. (defun mh-do-pick-search ()
  85.   "Find messages that match the qualifications in the current pattern buffer.
  86. Messages are searched for in the folder named in mh-searching-folder.
  87. Add messages found to the sequence named `search'."
  88.   (interactive)
  89.   (let ((pattern-buffer (buffer-name))
  90.     (searching-buffer mh-searching-folder)
  91.     range msgs
  92.     (pattern nil)
  93.     (new-buffer nil))
  94.     (save-excursion
  95.       (cond ((get-buffer searching-buffer)
  96.          (set-buffer searching-buffer)
  97.          (setq range (format "%d-%d" mh-first-msg-num mh-last-msg-num)))
  98.         (t
  99.          (mh-make-folder searching-buffer)
  100.          (setq range "all")
  101.          (setq new-buffer t))))
  102.     (message "Searching...")
  103.     (goto-char (point-min))
  104.     (while (setq pattern (mh-next-pick-field pattern-buffer))
  105.       (setq msgs (mh-seq-from-command searching-buffer
  106.                       'search
  107.                       (nconc (cons "pick" pattern)
  108.                          (list searching-buffer
  109.                            range
  110.                            "-sequence" "search"
  111.                            "-list"))))
  112.       (setq range "search"))
  113.     (message "Searching...done")
  114.     (if new-buffer
  115.     (mh-scan-folder searching-buffer msgs)
  116.     (switch-to-buffer searching-buffer))
  117.     (delete-other-windows)
  118.     (mh-notate-seq 'search ?% (1+ mh-cmd-note))))
  119.  
  120.  
  121. (defun mh-seq-from-command (folder seq seq-command)
  122.   ;; In FOLDER, make a sequence named SEQ by executing COMMAND.
  123.   ;; COMMAND is a list.  The first element is a program name
  124.   ;; and the subsequent elements are its arguments, all strings.
  125.   (let ((msg)
  126.     (msgs ())
  127.     (case-fold-search t))
  128.     (save-excursion
  129.       (save-window-excursion
  130.     (if (eq 0 (apply 'mh-exec-cmd-quiet nil seq-command))
  131.         (while (setq msg (car (mh-read-msg-list)))
  132.           (setq msgs (cons msg msgs))
  133.           (forward-line 1))))
  134.       (set-buffer folder)
  135.       (setq msgs (nreverse msgs))    ; Put in ascending order
  136.       (setq mh-seq-list (cons (mh-make-seq seq msgs) mh-seq-list))
  137.       msgs)))
  138.  
  139.  
  140. (defun mh-next-pick-field (buffer)
  141.   ;; Return the next piece of a pick argument that can be extracted from the
  142.   ;; BUFFER.  Returns nil if no pieces remain.
  143.   (set-buffer buffer)
  144.   (let ((case-fold-search t))
  145.     (cond ((eobp)
  146.        nil)
  147.       ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
  148.        (let* ((component
  149.            (format "--%s"
  150.                (downcase (buffer-substring (match-beginning 1)
  151.                                (match-end 1)))))
  152.           (pat (buffer-substring (match-beginning 2) (match-end 2))))
  153.            (forward-line 1)
  154.            (list component pat)))
  155.       ((re-search-forward "^-*$" nil t)
  156.        (forward-char 1)
  157.        (let ((body (buffer-substring (point) (point-max))))
  158.          (if (and (> (length body) 0) (not (equal body "\n")))
  159.          (list "-search" body)
  160.          nil)))
  161.       (t
  162.        nil))))
  163.  
  164. ;;; Build the pick-mode keymap:
  165.  
  166. (define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search)
  167. (define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field)
  168. (define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field)
  169. (define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field)
  170. (define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field)
  171. (define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field)
  172. (define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field)
  173. (define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field)
  174. (define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field)
  175. (define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field)
  176. (define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field)
  177. (define-key mh-pick-mode-map "\C-c\C-w" 'mh-check-whom)
  178.