lisp/mail/mh-pick.el

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