lisp/mail/mh-pick.el

   1 ;;; mh-pick.el --- make a search pattern and search for a message in mh-e
   2
   3 ;; Copyright (C) 1993, 1995, 2001 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Internal support for mh-e package.
  30
  31 ;;; Change Log:
  32
  33 ;; $Id: mh-pick.el,v 1.11 2001/12/29 00:10:41 wohler Exp $
  34
  35 ;;; Code:
  36
  37 (provide 'mh-pick)
  38 (require 'mh-e)
  39 (require 'easymenu)
  40 (require 'gnus-util)
  41
  42 (defvar mh-pick-mode-hook nil
  43   "Invoked in `mh-pick-mode' on a new pattern.")
  44
  45 ;;; Internal variables:
  46
  47 (defvar mh-pick-mode-map (make-sparse-keymap)
  48   "Keymap for searching folder.")
  49
  50 (defvar mh-searching-folder nil)        ;Folder this pick is searching.
  51
  52 (defun mh-search-folder (folder)
  53   "Search FOLDER for messages matching a pattern.
  54 Add the messages found to the sequence named `search'."
  55   (interactive (list (mh-prompt-for-folder "Search"
  56                                            mh-current-folder
  57                                            t)))
  58   (switch-to-buffer-other-window "pick-pattern")
  59   (if (or (zerop (buffer-size))
  60           (not (y-or-n-p "Reuse pattern? ")))
  61       (mh-make-pick-template)
  62     (message ""))
  63   (setq mh-searching-folder folder))
  64
  65 (defun mh-make-pick-template ()
  66   ;; Initialize the current buffer with a template for a pick pattern.
  67   (erase-buffer)
  68   (insert "From: \n"
  69           "To: \n"
  70           "Cc: \n"
  71           "Date: \n"
  72           "Subject: \n"
  73           "---------\n")
  74   (mh-pick-mode)
  75   (goto-char (point-min))
  76   (end-of-line))
  77
  78 (put 'mh-pick-mode 'mode-class 'special)
  79
  80 (define-derived-mode mh-pick-mode fundamental-mode "MH-Pick"
  81   "Mode for creating search templates in mh-e.\\<mh-pick-mode-map>
  82
  83 After each field name, enter the pattern to search for.  If a field's
  84 value does not matter for the search, leave it empty.  To search the
  85 entire message, supply the pattern in the \"body\" of the template.
  86 Each non-empty field must be matched for a message to be selected.
  87 To effect a logical \"or\", use \\[mh-search-folder] multiple times.
  88 When you have finished, type  \\[mh-do-pick-search]  to do the search.
  89
  90 This mode runs the hook `mh-pick-mode-hook'.
  91
  92 \\{mh-pick-mode-map}"
  93
  94   (make-local-variable 'mh-searching-folder)
  95   (easy-menu-add mh-pick-menu))
  96
  97
  98 (defun mh-do-pick-search ()
  99   "Find messages that match the qualifications in the current pattern buffer.
 100 Messages are searched for in the folder named in `mh-searching-folder'.
 101 Add the messages found to the sequence named `search'."
 102   (interactive)
 103   (let ((pattern-buffer (buffer-name))
 104         (searching-buffer mh-searching-folder)
 105         range
 106         msgs
 107         (finding-messages t)
 108         (pattern nil)
 109         (new-buffer nil))
 110     (save-excursion
 111       (cond ((get-buffer searching-buffer)
 112              (set-buffer searching-buffer)
 113              (setq range (list (format "%d-%d"
 114                                        mh-first-msg-num mh-last-msg-num))))
 115             (t
 116              (mh-make-folder searching-buffer)
 117              (setq range '("all"))
 118              (setq new-buffer t))))
 119     (message "Searching...")
 120     (goto-char (point-min))
 121     (while (and range
 122                 (setq pattern (mh-next-pick-field pattern-buffer)))
 123       (setq msgs (mh-seq-from-command searching-buffer
 124                                       'search
 125                                       (mh-list-to-string
 126                                        (list "pick" pattern searching-buffer
 127                                              "-list"
 128                                              (mh-coalesce-msg-list range)))))
 129       (setq range msgs))                ;restrict the pick range for next pass
 130     (message "Searching...done")
 131     (if new-buffer
 132         (mh-scan-folder searching-buffer msgs)
 133         (switch-to-buffer searching-buffer))
 134     (mh-add-msgs-to-seq msgs 'search)
 135     (delete-other-windows)))
 136
 137
 138 (defun mh-seq-from-command (folder seq seq-command)
 139   ;; In FOLDER, make a sequence named SEQ by executing COMMAND.
 140   ;; COMMAND is a list.  The first element is a program name
 141   ;; and the subsequent elements are its arguments, all strings.
 142   (let ((msg)
 143         (msgs ())
 144         (case-fold-search t))
 145     (save-excursion
 146       (save-window-excursion
 147         (if (eq 0 (apply 'mh-exec-cmd-quiet nil seq-command))
 148             ;; "pick" outputs one number per line
 149             (while (setq msg (car (mh-read-msg-list)))
 150               (setq msgs (cons msg msgs))
 151               (forward-line 1))))
 152       (set-buffer folder)
 153       (setq msgs (nreverse msgs))       ;put in ascending order
 154       msgs)))
 155
 156
 157 (defun mh-next-pick-field (buffer)
 158   ;; Return the next piece of a pick argument that can be extracted from the
 159   ;; BUFFER.
 160   ;; Return a list like ("--fieldname" "pattern") or ("-search" "bodypat")
 161   ;; or NIL if no pieces remain.
 162   (set-buffer buffer)
 163   (let ((case-fold-search t))
 164     (cond ((eobp)
 165            nil)
 166           ((re-search-forward "^\\([a-z][^: \t\n]*\\):[ \t]*\\([a-z0-9].*\\)$" nil t)
 167            (let* ((component
 168                    (format "--%s"
 169                            (downcase (buffer-substring (match-beginning 1)
 170                                                        (match-end 1)))))
 171                   (pat (buffer-substring (match-beginning 2) (match-end 2))))
 172                (forward-line 1)
 173                (list component pat)))
 174           ((re-search-forward "^-*$" nil t)
 175            (forward-char 1)
 176            (let ((body (buffer-substring (point) (point-max))))
 177              (if (and (> (length body) 0) (not (equal body "\n")))
 178                  (list "-search" body)
 179                  nil)))
 180           (t
 181            nil))))
 182
 183 ;;; Build the pick-mode keymap:
 184 (gnus-define-keys  mh-pick-mode-map
 185   "\C-c\C-c"            mh-do-pick-search
 186   "\C-c\C-f\C-b"        mh-to-field
 187   "\C-c\C-f\C-c"        mh-to-field
 188   "\C-c\C-f\C-d"        mh-to-field
 189   "\C-c\C-f\C-f"        mh-to-field
 190   "\C-c\C-f\C-r"        mh-to-field
 191   "\C-c\C-f\C-s"        mh-to-field
 192   "\C-c\C-f\C-t"        mh-to-field
 193   "\C-c\C-fb"           mh-to-field
 194   "\C-c\C-fc"           mh-to-field
 195   "\C-c\C-fd"           mh-to-field
 196   "\C-c\C-ff"           mh-to-field
 197   "\C-c\C-fr"           mh-to-field
 198   "\C-c\C-fs"           mh-to-field
 199   "\C-c\C-ft"           mh-to-field)
 200
 201 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
 202 (easy-menu-define
 203   mh-pick-menu mh-pick-mode-map "Menu for mh-e pick-mode"
 204   '("Pick"
 205     ["Execute the Search"       mh-do-pick-search t]))
 206
 207 ;;; mh-pick.el ends here