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, 2005 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 ;;; Code:
  34
  35 (eval-when-compile (require 'mh-acros))
  36 (mh-require-cl)
  37 (require 'mh-e)
  38 (require 'easymenu)
  39 (require 'gnus-util)
  40
  41 ;;; Internal variables:
  42
  43 (defvar mh-pick-mode-map (make-sparse-keymap)
  44   "Keymap for searching folder.")
  45
  46 (defvar mh-searching-folder nil)        ;Folder this pick is searching.
  47 (defvar mh-searching-function nil)
  48
  49 (defconst mh-pick-single-dash  '(cc date from subject to)
  50   "Search components that are supported by single-dash option in pick.")
  51
  52 ;;;###mh-autoload
  53 (defun mh-search-folder (folder window-config)
  54   "Search FOLDER for messages matching a pattern.
  55 This function uses the MH command `pick' to do the work.
  56 Add the messages found to the sequence named `search'.
  57 Argument WINDOW-CONFIG is the current window configuration and is used when
  58 the search folder is dismissed."
  59   (interactive (list (mh-prompt-for-folder "Search" mh-current-folder nil nil t)
  60                      (current-window-configuration)))
  61   (let ((pick-folder (if (equal folder "+") mh-current-folder folder)))
  62     (switch-to-buffer-other-window "search-pattern")
  63     (if (or (zerop (buffer-size))
  64             (not (y-or-n-p "Reuse pattern? ")))
  65         (mh-make-pick-template)
  66       (message ""))
  67     (setq mh-searching-function 'mh-pick-do-search
  68           mh-searching-folder pick-folder)
  69     (mh-make-local-vars 'mh-current-folder folder
  70                         'mh-previous-window-config window-config)
  71     (message "%s" (substitute-command-keys
  72                    (concat "Type \\[mh-do-search] to search messages, "
  73                            "\\[mh-help] for help.")))))
  74
  75 (defun mh-make-pick-template ()
  76   "Initialize the current buffer with a template for a pick pattern."
  77   (let ((inhibit-read-only t)) (erase-buffer))
  78   (insert "From: \n"
  79           "To: \n"
  80           "Cc: \n"
  81           "Date: \n"
  82           "Subject: \n"
  83           "---------\n")
  84   (mh-pick-mode)
  85   (goto-char (point-min))
  86   (dotimes (i 5)
  87     (add-text-properties (point) (1+ (point)) '(front-sticky t))
  88     (add-text-properties (- (line-end-position) 2) (1- (line-end-position))
  89                          '(rear-nonsticky t))
  90     (add-text-properties (point) (1- (line-end-position)) '(read-only t))
  91     (forward-line))
  92   (add-text-properties (point) (1+ (point)) '(front-sticky t))
  93   (add-text-properties (point) (1- (line-end-position)) '(read-only t))
  94   (goto-char (point-max)))
  95
  96 ;;; Menu extracted from mh-menubar.el V1.1 (31 July 2001)
  97 (easy-menu-define
  98   mh-pick-menu mh-pick-mode-map "Menu for MH-E pick-mode"
  99   '("Pick"
 100     ["Execute the Search"       mh-pick-do-search t]))
 101
 102
 103 ;;; Help Messages
 104 ;;; Group messages logically, more or less.
 105 (defvar mh-pick-mode-help-messages
 106   '((nil
 107      "Search messages using pick:  \\[mh-pick-do-search]\n"
 108      "Search messages using index:  \\[mh-index-do-search]\n"
 109      "Move to a field by typing C-c C-f C-<field>\n"
 110      "where <field> is the first letter of the desired field."))
 111   "Key binding cheat sheet.
 112
 113 This is an associative array which is used to show the most common commands.
 114 The key is a prefix char. The value is one or more strings which are
 115 concatenated together and displayed in the minibuffer if ? is pressed after
 116 the prefix character. The special key nil is used to display the
 117 non-prefixed commands.
 118
 119 The substitutions described in `substitute-command-keys' are performed as
 120 well.")
 121
 122 (put 'mh-pick-mode 'mode-class 'special)
 123
 124 (define-derived-mode mh-pick-mode fundamental-mode "MH-Pick"
 125   "Mode for creating search templates in MH-E.\\<mh-pick-mode-map>
 126
 127 After each field name, enter the pattern to search for.  If a field's
 128 value does not matter for the search, leave it empty.  To search the
 129 entire message, supply the pattern in the \"body\" of the template.
 130 Each non-empty field must be matched for a message to be selected.
 131 To effect a logical \"or\", use \\[mh-search-folder] multiple times.
 132 When you have finished, type  \\[mh-pick-do-search]  to do the search.
 133
 134 The value of `mh-pick-mode-hook' is a list of functions to be called,
 135 with no arguments, upon entry to this mode.
 136
 137 \\{mh-pick-mode-map}"
 138
 139   (make-local-variable 'mh-searching-folder)
 140   (make-local-variable 'mh-searching-function)
 141   (make-local-variable 'mh-help-messages)
 142   (easy-menu-add mh-pick-menu)
 143   (setq mh-help-messages mh-pick-mode-help-messages))
 144
 145 ;;;###mh-autoload
 146 (defun mh-pick-do-search ()
 147   "Find messages that match the qualifications in the current pattern buffer.
 148 Messages are searched for in the folder named in `mh-searching-folder'.
 149 Add the messages found to the sequence named `search'."
 150   (interactive)
 151   (let ((pattern-list (mh-pick-parse-search-buffer))
 152         (folder mh-searching-folder)
 153         (new-buffer-flag nil)
 154         (window-config mh-previous-window-config)
 155         range pick-args msgs)
 156     (unless pattern-list
 157       (error "No search pattern specified"))
 158     (save-excursion
 159       (cond ((get-buffer folder)
 160              (set-buffer folder)
 161              (setq range (if (and mh-first-msg-num mh-last-msg-num)
 162                              (format "%d-%d" mh-first-msg-num mh-last-msg-num)
 163                            "all")))
 164             (t
 165              (mh-make-folder folder)
 166              (setq range "all")
 167              (setq new-buffer-flag t))))
 168     (setq pick-args (mh-pick-regexp-builder pattern-list))
 169     (when pick-args
 170       (setq msgs (mh-seq-from-command folder 'search
 171                                       `("pick" ,folder ,range ,@pick-args))))
 172     (message "Searching...done")
 173     (if (not new-buffer-flag)
 174         (switch-to-buffer folder)
 175       (mh-scan-folder folder msgs)
 176       (setq mh-previous-window-config window-config))
 177     (mh-add-msgs-to-seq msgs 'search)
 178     (delete-other-windows)))
 179
 180 ;;;###mh-autoload
 181 (defun mh-do-search ()
 182   "Use the default searching function.
 183 If \\[mh-search-folder] was used to create the search pattern then pick is used
 184 to search the folder. Otherwise if \\[mh-index-search] was used then the
 185 indexing program specified in `mh-index-program' is used."
 186   (interactive)
 187   (if (symbolp mh-searching-function)
 188       (funcall mh-searching-function)
 189     (error "No searching function defined")))
 190
 191 (defun mh-seq-from-command (folder seq command)
 192   "In FOLDER, make a sequence named SEQ by executing COMMAND.
 193 COMMAND is a list.  The first element is a program name
 194 and the subsequent elements are its arguments, all strings."
 195   (let ((msg)
 196         (msgs ())
 197         (case-fold-search t))
 198     (save-excursion
 199       (save-window-excursion
 200         (if (eq 0 (apply 'mh-exec-cmd-quiet nil command))
 201             ;; "pick" outputs one number per line
 202             (while (setq msg (car (mh-read-msg-list)))
 203               (setq msgs (cons msg msgs))
 204               (forward-line 1))))
 205       (set-buffer folder)
 206       (setq msgs (nreverse msgs))       ;put in ascending order
 207       msgs)))
 208
 209 (defun mh-pick-parse-search-buffer ()
 210   "Parse the search buffer contents.
 211 The function returns a alist. The car of each element is either the header name
 212 to search in or nil to search the whole message. The cdr of the element is the
 213 pattern to search."
 214   (save-excursion
 215     (let ((pattern-list ())
 216           (in-body-flag nil)
 217           start begin)
 218       (goto-char (point-min))
 219       (while (not (eobp))
 220         (if (search-forward "--------" (line-end-position) t)
 221             (setq in-body-flag t)
 222           (beginning-of-line)
 223           (setq begin (point))
 224           (setq start (if in-body-flag
 225                           (point)
 226                         (search-forward ":" (line-end-position) t)
 227                         (point)))
 228           (push (cons (and (not in-body-flag)
 229                            (intern (downcase
 230                                     (buffer-substring-no-properties
 231                                      begin (1- start)))))
 232                       (mh-index-parse-search-regexp
 233                        (buffer-substring-no-properties
 234                         start (line-end-position))))
 235                 pattern-list))
 236         (forward-line))
 237       pattern-list)))
 238
 239 \f
 240
 241 ;; Functions specific to how pick works...
 242 (defun mh-pick-construct-regexp (expr component)
 243   "Construct pick compatible expression corresponding to EXPR.
 244 COMPONENT is the component to search."
 245   (cond ((atom expr) (list component expr))
 246         ((eq (car expr) 'and)
 247          `("-lbrace" ,@(mh-pick-construct-regexp (cadr expr) component) "-and"
 248            ,@(mh-pick-construct-regexp (caddr expr) component) "-rbrace"))
 249         ((eq (car expr) 'or)
 250          `("-lbrace" ,@(mh-pick-construct-regexp (cadr expr) component) "-or"
 251            ,@(mh-pick-construct-regexp (caddr expr) component) "-rbrace"))
 252         ((eq (car expr) 'not)
 253          `("-lbrace" "-not" ,@(mh-pick-construct-regexp (cadr expr) component)
 254            "-rbrace"))
 255         (t (error "Unknown operator '%s' seen" (car expr)))))
 256
 257 ;; All implementations of pick have special options -cc, -date, -from and
 258 ;; -subject that allow to search for corresponding components. Any other
 259 ;; component is searched using option --COMPNAME, for example: `pick
 260 ;; --x-mailer mh-e'. Mailutils `pick' supports this option using a certain
 261 ;; kludge, but it prefers the following syntax for this purpose:
 262 ;; `--component=COMPNAME --pattern=PATTERN'.
 263 ;;                                           -- Sergey Poznyakoff, Aug 2003
 264 (defun mh-pick-regexp-builder (pattern-list)
 265   "Generate pick search expression from PATTERN-LIST."
 266   (let ((result ()))
 267     (dolist (pattern pattern-list)
 268       (when (cdr pattern)
 269         (setq result `(,@result "-and" "-lbrace"
 270                        ,@(mh-pick-construct-regexp
 271                           (if (and (mh-variant-p 'mu-mh) (car pattern))
 272                               (format "--pattern=%s" (cdr pattern))
 273                             (cdr pattern))
 274                           (if (car pattern)
 275                               (cond
 276                                ((mh-variant-p 'mu-mh)
 277                                 (format "--component=%s" (car pattern)))
 278                                ((member (car pattern) mh-pick-single-dash)
 279                                 (format "-%s" (car pattern)))
 280                                (t
 281                                 (format "--%s" (car pattern))))
 282                             "-search"))
 283                        "-rbrace"))))
 284     (cdr result)))
 285
 286 \f
 287
 288 ;;; Build the pick-mode keymap:
 289 ;;; If this changes, modify mh-pick-mode-help-messages accordingly, above.
 290 (gnus-define-keys  mh-pick-mode-map
 291   "\C-c?"               mh-help
 292   "\C-c\C-i"            mh-index-do-search
 293   "\C-c\C-p"            mh-pick-do-search
 294   "\C-c\C-c"            mh-do-search
 295   "\C-c\C-f\C-b"        mh-to-field
 296   "\C-c\C-f\C-c"        mh-to-field
 297   "\C-c\C-f\C-d"        mh-to-field
 298   "\C-c\C-f\C-f"        mh-to-field
 299   "\C-c\C-f\C-r"        mh-to-field
 300   "\C-c\C-f\C-s"        mh-to-field
 301   "\C-c\C-f\C-t"        mh-to-field
 302   "\C-c\C-fb"           mh-to-field
 303   "\C-c\C-fc"           mh-to-field
 304   "\C-c\C-fd"           mh-to-field
 305   "\C-c\C-ff"           mh-to-field
 306   "\C-c\C-fr"           mh-to-field
 307   "\C-c\C-fs"           mh-to-field
 308   "\C-c\C-ft"           mh-to-field)
 309
 310 (provide 'mh-pick)
 311
 312 ;;; Local Variables:
 313 ;;; indent-tabs-mode: nil
 314 ;;; sentence-end-double-space: nil
 315 ;;; End:
 316
 317 ;;; arch-tag: aef2b271-7768-42bd-a782-9a14ba9f83f7
 318 ;;; mh-pick.el ends here