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