lisp/mh-e/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,
   4 ;; 2001, 2003, 2004, 2005 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Wohler <wohler@newt.com>
   7 ;; Maintainer: Bill Wohler <wohler@newt.com>
   8 ;; Keywords: mail
   9 ;; See: mh-e.el
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Internal support for MH-E package.
  31
  32 ;;; Change Log:
  33
  34 ;;; Code:
  35
  36 (eval-when-compile (require 'mh-acros))
  37 (mh-require-cl)
  38 (require 'mh-e)
  39 (require 'easymenu)
  40 (require 'gnus-util)
  41
  42 ;;; Internal variables:
  43
  44 (defvar mh-pick-mode-map (make-sparse-keymap)
  45   "Keymap for searching folder.")
  46
  47 (defvar mh-searching-folder nil)        ;Folder this pick is searching.
  48 (defvar mh-searching-function nil)
  49
  50 (defconst mh-pick-single-dash  '(cc date from subject to)
  51   "Search components that are supported by single-dash option in pick.")
  52
  53 ;;;###mh-autoload
  54 (defun mh-search-folder (folder window-config)
  55   "Search FOLDER for messages matching a pattern.
  56
  57 With this command, you can search a folder for messages to or from a
  58 particular person or about a particular subject. In fact, you can also search
  59 for messages containing selected strings in any arbitrary header field or any
  60 string found within the messages.
  61
  62 You are first prompted for the name of the folder to search and then placed in
  63 the following buffer in MH-Pick mode:
  64
  65      From:
  66      To:
  67      Cc:
  68      Date:
  69      Subject:
  70      --------
  71
  72 Edit this template by entering your search criteria in an appropriate header
  73 field that is already there, or create a new field yourself. If the string
  74 you're looking for could be anywhere in a message, then place the string
  75 underneath the row of dashes. The \\[mh-search-folder] command uses the MH
  76 command \"pick\" to do the real work.
  77
  78 There are no semantics associated with the search criteria--they are simply
  79 treated as strings. Case is ignored when all lowercase is used, and regular
  80 expressions (a la \"ed\") are available. It is all right to specify several
  81 search criteria. What happens then is that a logical _and_ of the various
  82 fields is performed. If you prefer a logical _or_ operation, run
  83 \\[mh-search-folder] multiple times.
  84
  85 As an example, let's say that we want to find messages from Ginnean about
  86 horseback riding in the Kosciusko National Park (Australia) during January,
  87 1994. Normally we would start with a broad search and narrow it down if
  88 necessary to produce a manageable amount of data, but we'll cut to the chase
  89 and create a fairly restrictive set of criteria as follows:
  90
  91      From: ginnean
  92      To:
  93      Cc:
  94      Date: Jan 1994
  95      Subject: horse.*kosciusko
  96      --------
  97
  98 As with MH-Letter mode, MH-Pick provides commands like
  99 \\<mh-pick-mode-map>\\[mh-to-field] to help you fill in the blanks.
 100
 101 To perform the search, type \\[mh-do-search]. The selected messages are placed
 102 in the \"search\" sequence, which you can use later in forwarding, printing,
 103 or narrowing your field of view. Subsequent searches are appended to the
 104 \"search\" sequence. If, however, you wish to start with a clean slate, first
 105 delete the \"search\" sequence.
 106
 107 If you're searching in a folder that is already displayed in an MH-Folder
 108 buffer, only those messages contained in the buffer are used for the search.
 109 Therefore, if you want to search in all messages, first kill the folder's
 110 buffer with \\<mh-folder-mode-map>\\[kill-buffer] or scan the entire folder
 111 with \\[mh-rescan-folder].
 112
 113 If you find that you do the same thing over and over when editing the search
 114 template, you may wish to bind some shortcuts to keys. This can be done with
 115 the variable `mh-pick-mode-hook', which is called when \\[mh-search-folder] is
 116 run on a new pattern.
 117
 118 If you have run the \\[mh-index-search] command, but change your mind while
 119 entering the search criteria and actually want to run a regular search, then
 120 you can use the \\<mh-pick-mode-map>\\[mh-pick-do-search] command.
 121
 122 In a program, argument WINDOW-CONFIG is the current window configuration and
 123 is used when the search folder is dismissed."
 124   (interactive (list (mh-prompt-for-folder "Search" mh-current-folder nil nil t)
 125                      (current-window-configuration)))
 126   (let ((pick-folder (if (equal folder "+") mh-current-folder folder)))
 127     (switch-to-buffer-other-window "search-pattern")
 128     (if (or (zerop (buffer-size))
 129             (not (y-or-n-p "Reuse pattern? ")))
 130         (mh-make-pick-template)
 131       (message ""))
 132     (setq mh-searching-function 'mh-pick-do-search
 133           mh-searching-folder pick-folder)
 134     (mh-make-local-vars 'mh-current-folder folder
 135                         'mh-previous-window-config window-config)
 136     (message "%s" (substitute-command-keys
 137                    (concat "Type \\[mh-do-search] to search messages, "
 138                            "\\[mh-help] for help.")))))
 139
 140 (defun mh-make-pick-template ()
 141   "Initialize the current buffer with a template for a pick pattern."
 142   (let ((inhibit-read-only t)) (erase-buffer))
 143   (insert "From: \n"
 144           "To: \n"
 145           "Cc: \n"
 146           "Date: \n"
 147           "Subject: \n"
 148           "---------\n")
 149   (mh-pick-mode)
 150   (goto-char (point-min))
 151   (dotimes (i 5)
 152     (add-text-properties (point) (1+ (point)) '(front-sticky t))
 153     (add-text-properties (- (line-end-position) 2) (1- (line-end-position))
 154                          '(rear-nonsticky t))
 155     (add-text-properties (point) (1- (line-end-position)) '(read-only t))
 156     (forward-line))
 157   (add-text-properties (point) (1+ (point)) '(front-sticky t))
 158   (add-text-properties (point) (1- (line-end-position)) '(read-only t))
 159   (goto-char (point-max)))
 160
 161 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
 162 (easy-menu-define
 163   mh-pick-menu mh-pick-mode-map "Menu for MH-E pick-mode"
 164   '("Pick"
 165     ["Execute the Search"       mh-pick-do-search t]))
 166
 167
 168 ;;; Help Messages
 169 ;;; Group messages logically, more or less.
 170 (defvar mh-pick-mode-help-messages
 171   '((nil
 172      "Search messages using pick:  \\[mh-pick-do-search]\n"
 173      "Search messages using index:  \\[mh-index-do-search]\n"
 174      "Move to a field by typing C-c C-f C-<field>\n"
 175      "where <field> is the first letter of the desired field."))
 176   "Key binding cheat sheet.
 177
 178 This is an associative array which is used to show the most common commands.
 179 The key is a prefix char. The value is one or more strings which are
 180 concatenated together and displayed in the minibuffer if ? is pressed after
 181 the prefix character. The special key nil is used to display the
 182 non-prefixed commands.
 183
 184 The substitutions described in `substitute-command-keys' are performed as
 185 well.")
 186
 187 (put 'mh-pick-mode 'mode-class 'special)
 188
 189 (define-derived-mode mh-pick-mode fundamental-mode "MH-Pick"
 190   "Mode for creating search templates in MH-E.\\<mh-pick-mode-map>
 191
 192 After each field name, enter the pattern to search for.  If a field's
 193 value does not matter for the search, leave it empty.  To search the
 194 entire message, supply the pattern in the \"body\" of the template.
 195 Each non-empty field must be matched for a message to be selected.
 196 To effect a logical \"or\", use \\[mh-search-folder] multiple times.
 197 When you have finished, type  \\[mh-pick-do-search]  to do the search.
 198
 199 The value of `mh-pick-mode-hook' is a list of functions to be called,
 200 with no arguments, upon entry to this mode.
 201
 202 \\{mh-pick-mode-map}"
 203
 204   (make-local-variable 'mh-searching-folder)
 205   (make-local-variable 'mh-searching-function)
 206   (make-local-variable 'mh-help-messages)
 207   (easy-menu-add mh-pick-menu)
 208   (setq mh-help-messages mh-pick-mode-help-messages))
 209
 210 ;;;###mh-autoload
 211 (defun mh-pick-do-search ()
 212   "Find messages that match the qualifications in the current pattern buffer.
 213 Messages are searched for in the folder named in `mh-searching-folder'.
 214 Add the messages found to the sequence named `search'."
 215   (interactive)
 216   (let ((pattern-list (mh-pick-parse-search-buffer))
 217         (folder mh-searching-folder)
 218         (new-buffer-flag nil)
 219         (window-config mh-previous-window-config)
 220         range pick-args msgs)
 221     (unless pattern-list
 222       (error "No search pattern specified"))
 223     (save-excursion
 224       (cond ((get-buffer folder)
 225              (set-buffer folder)
 226              (setq range (if (and mh-first-msg-num mh-last-msg-num)
 227                              (format "%d-%d" mh-first-msg-num mh-last-msg-num)
 228                            "all")))
 229             (t
 230              (mh-make-folder folder)
 231              (setq range "all")
 232              (setq new-buffer-flag t))))
 233     (setq pick-args (mh-pick-regexp-builder pattern-list))
 234     (when pick-args
 235       (setq msgs (mh-seq-from-command folder 'search
 236                                       `("pick" ,folder ,range ,@pick-args))))
 237     (message "Searching...done")
 238     (if (not new-buffer-flag)
 239         (switch-to-buffer folder)
 240       (mh-scan-folder folder msgs)
 241       (setq mh-previous-window-config window-config))
 242     (mh-add-msgs-to-seq msgs 'search)
 243     (delete-other-windows)))
 244
 245 ;;;###mh-autoload
 246 (defun mh-do-search ()
 247   "Use the default searching function.
 248 If \\[mh-search-folder] was used to create the search pattern then pick is used
 249 to search the folder. Otherwise if \\[mh-index-search] was used then the
 250 indexing program specified in `mh-index-program' is used."
 251   (interactive)
 252   (if (symbolp mh-searching-function)
 253       (funcall mh-searching-function)
 254     (error "No searching function defined")))
 255
 256 (defun mh-seq-from-command (folder seq command)
 257   "In FOLDER, make a sequence named SEQ by executing COMMAND.
 258 COMMAND is a list.  The first element is a program name
 259 and the subsequent elements are its arguments, all strings."
 260   (let ((msg)
 261         (msgs ())
 262         (case-fold-search t))
 263     (save-excursion
 264       (save-window-excursion
 265         (if (eq 0 (apply 'mh-exec-cmd-quiet nil command))
 266             ;; "pick" outputs one number per line
 267             (while (setq msg (car (mh-read-msg-list)))
 268               (setq msgs (cons msg msgs))
 269               (forward-line 1))))
 270       (set-buffer folder)
 271       (setq msgs (nreverse msgs))       ;put in ascending order
 272       msgs)))
 273
 274 (defun mh-pick-parse-search-buffer ()
 275   "Parse the search buffer contents.
 276 The function returns a alist. The car of each element is either the header name
 277 to search in or nil to search the whole message. The cdr of the element is the
 278 pattern to search."
 279   (save-excursion
 280     (let ((pattern-list ())
 281           (in-body-flag nil)
 282           start begin)
 283       (goto-char (point-min))
 284       (while (not (eobp))
 285         (if (search-forward "--------" (line-end-position) t)
 286             (setq in-body-flag t)
 287           (beginning-of-line)
 288           (setq begin (point))
 289           (setq start (if in-body-flag
 290                           (point)
 291                         (search-forward ":" (line-end-position) t)
 292                         (point)))
 293           (push (cons (and (not in-body-flag)
 294                            (intern (downcase
 295                                     (buffer-substring-no-properties
 296                                      begin (1- start)))))
 297                       (mh-index-parse-search-regexp
 298                        (buffer-substring-no-properties
 299                         start (line-end-position))))
 300                 pattern-list))
 301         (forward-line))
 302       pattern-list)))
 303
 304 \f
 305
 306 ;; Functions specific to how pick works...
 307 (defun mh-pick-construct-regexp (expr component)
 308   "Construct pick compatible expression corresponding to EXPR.
 309 COMPONENT is the component to search."
 310   (cond ((atom expr) (list component expr))
 311         ((eq (car expr) 'and)
 312          `("-lbrace" ,@(mh-pick-construct-regexp (cadr expr) component) "-and"
 313            ,@(mh-pick-construct-regexp (caddr expr) component) "-rbrace"))
 314         ((eq (car expr) 'or)
 315          `("-lbrace" ,@(mh-pick-construct-regexp (cadr expr) component) "-or"
 316            ,@(mh-pick-construct-regexp (caddr expr) component) "-rbrace"))
 317         ((eq (car expr) 'not)
 318          `("-lbrace" "-not" ,@(mh-pick-construct-regexp (cadr expr) component)
 319            "-rbrace"))
 320         (t (error "Unknown operator '%s' seen" (car expr)))))
 321
 322 ;; All implementations of pick have special options -cc, -date, -from and
 323 ;; -subject that allow to search for corresponding components. Any other
 324 ;; component is searched using option --COMPNAME, for example: `pick
 325 ;; --x-mailer mh-e'. Mailutils `pick' supports this option using a certain
 326 ;; kludge, but it prefers the following syntax for this purpose:
 327 ;; `--component=COMPNAME --pattern=PATTERN'.
 328 ;;                                           -- Sergey Poznyakoff, Aug 2003
 329 (defun mh-pick-regexp-builder (pattern-list)
 330   "Generate pick search expression from PATTERN-LIST."
 331   (let ((result ()))
 332     (dolist (pattern pattern-list)
 333       (when (cdr pattern)
 334         (setq result `(,@result "-and" "-lbrace"
 335                        ,@(mh-pick-construct-regexp
 336                           (if (and (mh-variant-p 'mu-mh) (car pattern))
 337                               (format "--pattern=%s" (cdr pattern))
 338                             (cdr pattern))
 339                           (if (car pattern)
 340                               (cond
 341                                ((mh-variant-p 'mu-mh)
 342                                 (format "--component=%s" (car pattern)))
 343                                ((member (car pattern) mh-pick-single-dash)
 344                                 (format "-%s" (car pattern)))
 345                                (t
 346                                 (format "--%s" (car pattern))))
 347                             "-search"))
 348                        "-rbrace"))))
 349     (cdr result)))
 350
 351 \f
 352
 353 ;;; Build the pick-mode keymap:
 354 ;;; If this changes, modify mh-pick-mode-help-messages accordingly, above.
 355 (gnus-define-keys  mh-pick-mode-map
 356   "\C-c?"               mh-help
 357   "\C-c\C-i"            mh-index-do-search
 358   "\C-c\C-p"            mh-pick-do-search
 359   "\C-c\C-c"            mh-do-search
 360   "\C-c\C-f\C-b"        mh-to-field
 361   "\C-c\C-f\C-c"        mh-to-field
 362   "\C-c\C-f\C-d"        mh-to-field
 363   "\C-c\C-f\C-f"        mh-to-field
 364   "\C-c\C-f\C-r"        mh-to-field
 365   "\C-c\C-f\C-s"        mh-to-field
 366   "\C-c\C-f\C-t"        mh-to-field
 367   "\C-c\C-fb"           mh-to-field
 368   "\C-c\C-fc"           mh-to-field
 369   "\C-c\C-fd"           mh-to-field
 370   "\C-c\C-ff"           mh-to-field
 371   "\C-c\C-fr"           mh-to-field
 372   "\C-c\C-fs"           mh-to-field
 373   "\C-c\C-ft"           mh-to-field)
 374
 375 (provide 'mh-pick)
 376
 377 ;;; Local Variables:
 378 ;;; indent-tabs-mode: nil
 379 ;;; sentence-end-double-space: nil
 380 ;;; End:
 381
 382 ;;; arch-tag: aef2b271-7768-42bd-a782-9a14ba9f83f7
 383 ;;; mh-pick.el ends here