code.delx.au - gnu-emacs/blob - lisp/mail/mh-pick.el

   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)