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