home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 31 / CDASC_31_1996_juillet_aout.iso / vrac_os2 / e31el3.zip / EMACS / 19.31 / LISP / MH-PICK.EL < prev    next >
Lisp/Scheme  |  1996-01-20  |  7KB  |  196 lines
  1. ;;; mh-pick --- make a search pattern and search for a message in mh-e
  2. ;; Time-stamp: <95/08/19 16:45:16 gildea>
  3.  
  4. ;; Copyright (C) 1993, 1995 Free Software Foundation, Inc.
  5.  
  6. ;; This file is part of mh-e, part of GNU Emacs.
  7.  
  8. ;; GNU Emacs 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. ;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
  20. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21. ;; Boston, MA 02111-1307, USA.
  22.  
  23. ;;; Commentary:
  24.  
  25. ;; Internal support for mh-e package.
  26.  
  27. ;;; Change Log:
  28.  
  29. ;; $Id: mh-pick.el,v 1.5 1996/01/14 07:34:30 erik Exp $
  30.  
  31. ;;; Code:
  32.  
  33. (provide 'mh-pick)
  34. (require 'mh-e)
  35.  
  36. (defvar mh-pick-mode-hook nil
  37.   "Invoked in `mh-pick-mode' on a new pattern.")
  38.  
  39. ;;; Internal variables:
  40.  
  41. (defvar mh-pick-mode-map (make-sparse-keymap)
  42.   "Keymap for searching folder.")
  43.  
  44. (defvar mh-searching-folder nil)    ;Folder this pick is searching.
  45.  
  46. (defun mh-search-folder (folder)
  47.   "Search FOLDER for messages matching a pattern.
  48. Add the messages found to the sequence named `search'."
  49.   (interactive (list (mh-prompt-for-folder "Search"
  50.                        mh-current-folder
  51.                        t)))
  52.   (switch-to-buffer-other-window "pick-pattern")
  53.   (if (or (zerop (buffer-size))
  54.       (not (y-or-n-p "Reuse pattern? ")))
  55.       (mh-make-pick-template)
  56.     (message ""))
  57.   (setq mh-searching-folder folder))
  58.  
  59. (defun mh-make-pick-template ()
  60.   ;; Initialize the current buffer with a template for a pick pattern.
  61.   (erase-buffer)
  62.   (insert "From: \n"
  63.       "To: \n"
  64.       "Cc: \n"
  65.       "Date: \n"
  66.       "Subject: \n"
  67.       "---------\n")
  68.   (mh-pick-mode)
  69.   (goto-char (point-min))
  70.   (end-of-line))
  71.  
  72. (put 'mh-pick-mode 'mode-class 'special)
  73.  
  74. (defun mh-pick-mode ()
  75.   "Mode for creating search templates in mh-e.\\<mh-pick-mode-map>
  76. After each field name, enter the pattern to search for.  If a field's
  77. value does not matter for the search, leave it empty.  To search the
  78. entire message, supply the pattern in the \"body\" of the template.
  79. Each non-empty field must be matched for a message to be selected.
  80. To effect a logical \"or\", use \\[mh-search-folder] multiple times.
  81. When you have finished, type  \\[mh-do-pick-search]  to do the search.
  82. \\{mh-pick-mode-map}
  83. Turning on mh-pick-mode calls the value of the variable mh-pick-mode-hook
  84. if that value is non-nil."
  85.   (interactive)
  86.   (kill-all-local-variables)
  87.   (make-local-variable 'mh-searching-folder)
  88.   (use-local-map mh-pick-mode-map)
  89.   (setq major-mode 'mh-pick-mode)
  90.   (mh-set-mode-name "MH-Pick")
  91.   (run-hooks 'mh-pick-mode-hook))
  92.  
  93.  
  94. (defun mh-do-pick-search ()
  95.   "Find messages that match the qualifications in the current pattern buffer.
  96. Messages are searched for in the folder named in mh-searching-folder.
  97. Add the messages found to the sequence named `search'."
  98.   (interactive)
  99.   (let ((pattern-buffer (buffer-name))
  100.     (searching-buffer mh-searching-folder)
  101.     range
  102.     msgs
  103.     (finding-messages t)
  104.     (pattern nil)
  105.     (new-buffer nil))
  106.     (save-excursion
  107.       (cond ((get-buffer searching-buffer)
  108.          (set-buffer searching-buffer)
  109.          (setq range (list (format "%d-%d"
  110.                        mh-first-msg-num mh-last-msg-num))))
  111.         (t
  112.          (mh-make-folder searching-buffer)
  113.          (setq range '("all"))
  114.          (setq new-buffer t))))
  115.     (message "Searching...")
  116.     (goto-char (point-min))
  117.     (while (and range
  118.         (setq pattern (mh-next-pick-field pattern-buffer)))
  119.       (setq msgs (mh-seq-from-command searching-buffer
  120.                       'search
  121.                       (mh-list-to-string
  122.                        (list "pick" pattern searching-buffer
  123.                          "-list"
  124.                          (mh-coalesce-msg-list range)))))
  125.       (setq range msgs))        ;restrict the pick range for next pass
  126.     (message "Searching...done")
  127.     (if new-buffer
  128.     (mh-scan-folder searching-buffer msgs)
  129.     (switch-to-buffer searching-buffer))
  130.     (mh-add-msgs-to-seq msgs 'search)
  131.     (delete-other-windows)))
  132.  
  133.  
  134. (defun mh-seq-from-command (folder seq seq-command)
  135.   ;; In FOLDER, make a sequence named SEQ by executing COMMAND.
  136.   ;; COMMAND is a list.  The first element is a program name
  137.   ;; and the subsequent elements are its arguments, all strings.
  138.   (let ((msg)
  139.     (msgs ())
  140.     (case-fold-search t))
  141.     (save-excursion
  142.       (save-window-excursion
  143.     (if (eq 0 (apply 'mh-exec-cmd-quiet nil seq-command))
  144.         ;; "pick" outputs one number per line
  145.         (while (setq msg (car (mh-read-msg-list)))
  146.           (setq msgs (cons msg msgs))
  147.           (forward-line 1))))
  148.       (set-buffer folder)
  149.       (setq msgs (nreverse msgs))    ;put in ascending order
  150.       msgs)))
  151.  
  152.  
  153. (defun mh-next-pick-field (buffer)
  154.   ;; Return the next piece of a pick argument that can be extracted from the
  155.   ;; BUFFER.
  156.   ;; Return a list like ("--fieldname" "pattern") or ("-search" "bodypat")
  157.   ;; or NIL if no pieces remain.
  158.   (set-buffer buffer)
  159.   (let ((case-fold-search t))
  160.     (cond ((eobp)
  161.        nil)
  162.       ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
  163.        (let* ((component
  164.            (format "--%s"
  165.                (downcase (buffer-substring (match-beginning 1)
  166.                                (match-end 1)))))
  167.           (pat (buffer-substring (match-beginning 2) (match-end 2))))
  168.            (forward-line 1)
  169.            (list component pat)))
  170.       ((re-search-forward "^-*$" nil t)
  171.        (forward-char 1)
  172.        (let ((body (buffer-substring (point) (point-max))))
  173.          (if (and (> (length body) 0) (not (equal body "\n")))
  174.          (list "-search" body)
  175.          nil)))
  176.       (t
  177.        nil))))
  178.  
  179. ;;; Build the pick-mode keymap:
  180.  
  181. (define-key mh-pick-mode-map "\C-c\C-c" 'mh-do-pick-search)
  182. (define-key mh-pick-mode-map "\C-c\C-f\C-b" 'mh-to-field)
  183. (define-key mh-pick-mode-map "\C-c\C-f\C-c" 'mh-to-field)
  184. (define-key mh-pick-mode-map "\C-c\C-f\C-d" 'mh-to-field)
  185. (define-key mh-pick-mode-map "\C-c\C-f\C-f" 'mh-to-field)
  186. (define-key mh-pick-mode-map "\C-c\C-f\C-r" 'mh-to-field)
  187. (define-key mh-pick-mode-map "\C-c\C-f\C-s" 'mh-to-field)
  188. (define-key mh-pick-mode-map "\C-c\C-f\C-t" 'mh-to-field)
  189. (define-key mh-pick-mode-map "\C-c\C-fb" 'mh-to-field)
  190. (define-key mh-pick-mode-map "\C-c\C-fc" 'mh-to-field)
  191. (define-key mh-pick-mode-map "\C-c\C-fd" 'mh-to-field)
  192. (define-key mh-pick-mode-map "\C-c\C-ff" 'mh-to-field)
  193. (define-key mh-pick-mode-map "\C-c\C-fr" 'mh-to-field)
  194. (define-key mh-pick-mode-map "\C-c\C-fs" 'mh-to-field)
  195. (define-key mh-pick-mode-map "\C-c\C-ft" 'mh-to-field)
  196.