lisp/mail/mh-pick.el

   1 ;;; mh-pick.el --- make a search pattern and search for a message in mh-e
   2 ;; Time-stamp: <2001-07-14 13:09:34 pavel>
   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 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
 197 ;;; mh-pick.el ends here