cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-search.el

   1 ;;; vm-search.el --- Incremental search through a mail folder
   2 ;;
   3 ;; Copyright (C) 1994 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-isearch-forward (&optional arg)
  24   "Incrementally search forward through the current folder's messages.
  25 Usage is identical to the standard Emacs incremental search.
  26 When the search terminates the message containing point will be selected.
  27
  28 If the variable vm-search-using-regexps is non-nil, regular expressions
  29 are understood; nil means the search will be for the input string taken
  30 literally.  Specifying a prefix ARG interactively toggles the value of
  31 vm-search-using-regexps for this search."
  32   (interactive "P")
  33   (let ((vm-search-using-regexps
  34          (if arg (not vm-search-using-regexps) vm-search-using-regexps)))
  35     (vm-isearch t)))
  36
  37 ;;;###autoload
  38 (defun vm-isearch-backward (&optional arg)
  39   "Incrementally search backward through the current folder's messages.
  40 Usage is identical to the standard Emacs incremental search.
  41 When the search terminates the message containing point will be selected.
  42
  43 If the variable vm-search-using-regexps is non-nil, regular expressions
  44 are understood; nil means the search will be for the input string taken
  45 literally.  Specifying a prefix ARG interactively toggles the value of
  46 vm-search-using-regexps for this search."
  47   (interactive "P")
  48   (let ((vm-search-using-regexps
  49          (if arg (not vm-search-using-regexps) vm-search-using-regexps)))
  50     (vm-isearch nil)))
  51
  52 (defun vm-isearch (forward)
  53   (vm-follow-summary-cursor)
  54   (vm-select-folder-buffer)
  55   (vm-check-for-killed-summary)
  56   (vm-error-if-folder-empty)
  57   (vm-error-if-virtual-folder)
  58   (vm-display (current-buffer) t '(vm-isearch-forward vm-isearch-backward)
  59               (list this-command 'searching-message))
  60   (let ((clip-head (point-min))
  61         (clip-tail (point-max))
  62         (old-vm-message-pointer vm-message-pointer))
  63     (unwind-protect
  64         (progn (select-window (vm-get-visible-buffer-window (current-buffer)))
  65                (widen)
  66                (add-hook 'pre-command-hook 'vm-isearch-widen)
  67                ;; order is significant, we want to narrow after
  68                ;; the update
  69                (add-hook 'post-command-hook 'vm-isearch-narrow)
  70                (add-hook 'post-command-hook 'vm-isearch-update)
  71                (isearch-mode forward vm-search-using-regexps nil t)
  72                (vm-isearch-update)
  73                (if (not (eq vm-message-pointer old-vm-message-pointer))
  74                    (progn
  75                      (vm-record-and-change-message-pointer
  76                       old-vm-message-pointer vm-message-pointer)
  77                      (vm-update-summary-and-mode-line)
  78                      ;; vm-show-current-message only adjusts (point-max),
  79                      ;; it doesn't change (point-min).
  80                      (widen)
  81                      (narrow-to-region
  82                       (if (< (point) (vm-vheaders-of (car vm-message-pointer)))
  83                           (vm-start-of (car vm-message-pointer))
  84                         (vm-vheaders-of (car vm-message-pointer)))
  85                       (vm-text-end-of (car vm-message-pointer)))
  86                      (save-excursion (vm-energize-urls))
  87                      (vm-display nil nil
  88                                  '(vm-isearch-forward vm-isearch-backward)
  89                                  '(reading-message))
  90                      ;; turn the unwinds into a noop
  91                      (setq old-vm-message-pointer vm-message-pointer)
  92                      (setq clip-head (point-min))
  93                      (setq clip-tail (point-max)))))
  94       (remove-hook 'pre-command-hook 'vm-isearch-widen)
  95       (remove-hook 'post-command-hook 'vm-isearch-update)
  96       (remove-hook 'post-command-hook 'vm-isearch-narrow)
  97       (narrow-to-region clip-head clip-tail)
  98       (setq vm-message-pointer old-vm-message-pointer))))
  99
 100 (defun vm-isearch-widen ()
 101   (if (eq major-mode 'vm-mode)
 102       (widen)))
 103
 104 (defun vm-isearch-narrow ()
 105   (if (eq major-mode 'vm-mode)
 106       (narrow-to-region
 107        (if (< (point) (vm-vheaders-of (car vm-message-pointer)))
 108            (vm-start-of (car vm-message-pointer))
 109          (vm-vheaders-of (car vm-message-pointer)))
 110        (vm-text-end-of (car vm-message-pointer)))))
 111
 112 (defun vm-isearch-update ()
 113   (if (eq major-mode 'vm-mode)
 114       (if (and (>= (point) (vm-start-of (car vm-message-pointer)))
 115                (<= (point) (vm-end-of (car vm-message-pointer))))
 116           nil
 117         (let ((mp vm-message-list)
 118               (point (point)))
 119           (while mp
 120             (if (and (>= point (vm-start-of (car mp)))
 121                      (<= point (vm-end-of (car mp))))
 122                 (setq vm-message-pointer mp mp nil)
 123               (setq mp (cdr mp))))
 124           (setq vm-need-summary-pointer-update t)
 125           (intern (buffer-name) vm-buffers-needing-display-update)
 126           (vm-update-summary-and-mode-line)))))
 127
 128 (provide 'vm-search)
 129
 130 ;;; vm-search.el ends here