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