0
|
1 ;; Incremental search through a mail folder
|
|
2 ;; For version 18 of FSF Emacs only.
|
|
3 ;; Copyright (C) 1985, 1986 Free Software Foundation, Inc.
|
|
4
|
|
5 ;; This file is part of GNU Emacs.
|
|
6
|
|
7 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
8 ;; but WITHOUT ANY WARRANTY. No author or distributor
|
|
9 ;; accepts responsibility to anyone for the consequences of using it
|
|
10 ;; or for whether it serves any particular purpose or works at all,
|
|
11 ;; unless he says so in writing. Refer to the GNU Emacs General Public
|
|
12 ;; License for full details.
|
|
13
|
|
14 ;; Everyone is granted permission to copy, modify and redistribute
|
|
15 ;; GNU Emacs, but only under the conditions described in the
|
|
16 ;; GNU Emacs General Public License. A copy of this license is
|
|
17 ;; supposed to have been given to you along with GNU Emacs so you
|
|
18 ;; can know your rights and responsibilities. It should be in a
|
|
19 ;; file named COPYING. Among other things, the copyright notice
|
|
20 ;; and this notice must be preserved on all copies.
|
|
21
|
|
22
|
|
23 (provide 'vm-search)
|
|
24
|
|
25 ;; Adapted for the VM mail reader, Kyle Jones, May 1989
|
|
26
|
|
27
|
|
28 ;; This function does all the work of incremental search.
|
|
29 ;; The functions attached to ^R and ^S are trivial,
|
|
30 ;; merely calling this one, but they are always loaded by default
|
|
31 ;; whereas this file can optionally be autoloadable.
|
|
32 ;; This is the only entry point in this file.
|
|
33
|
|
34 (defun vm-isearch (forward &optional regexp)
|
|
35 (let ((search-string "")
|
|
36 (search-message "")
|
|
37 (cmds nil)
|
|
38 (success t)
|
|
39 (wrapped nil)
|
|
40 (barrier (point))
|
|
41 adjusted
|
|
42 (invalid-regexp nil)
|
|
43 (slow-terminal-mode (and (<= (baud-rate) search-slow-speed)
|
|
44 (> (window-height)
|
|
45 (* 4 search-slow-window-lines))))
|
|
46 (other-end nil) ;Start of last match if fwd, end if backwd.
|
|
47 (small-window nil) ;if t, using a small window
|
|
48 (found-point nil) ;to restore point from a small window
|
|
49 ;; This is the window-start value found by the search.
|
|
50 (found-start nil)
|
|
51 (opoint (point))
|
|
52 (vm-ml-message-new vm-ml-message-new)
|
|
53 (vm-ml-message-unread vm-ml-message-unread)
|
|
54 (vm-ml-message-read vm-ml-message-read)
|
|
55 (vm-ml-message-edited vm-ml-message-edited)
|
|
56 (vm-ml-message-replied vm-ml-message-replied)
|
|
57 (vm-ml-message-forwarded vm-ml-message-forwarded)
|
|
58 (vm-ml-message-filed vm-ml-message-filed)
|
|
59 (vm-ml-message-written vm-ml-message-written)
|
|
60 (vm-ml-message-marked vm-ml-message-marked)
|
|
61 (vm-ml-message-deleted vm-ml-message-deleted)
|
|
62 (vm-ml-message-number vm-ml-message-number)
|
|
63 (vm-message-pointer vm-message-pointer)
|
|
64 (inhibit-quit t)) ;Prevent ^G from quitting immediately.
|
|
65 (vm-isearch-push-state)
|
|
66 (save-window-excursion
|
|
67 (catch 'search-done
|
|
68 (while t
|
|
69 (or (>= unread-command-char 0)
|
|
70 (progn
|
|
71 (or (input-pending-p)
|
|
72 (vm-isearch-message))
|
|
73 (if (and slow-terminal-mode
|
|
74 (not (or small-window (pos-visible-in-window-p))))
|
|
75 (progn
|
|
76 (setq small-window t)
|
|
77 (setq found-point (point))
|
|
78 (move-to-window-line 0)
|
|
79 (let ((window-min-height 1))
|
|
80 (split-window nil (if (< search-slow-window-lines 0)
|
|
81 (1+ (- search-slow-window-lines))
|
|
82 (- (window-height)
|
|
83 (1+ search-slow-window-lines)))))
|
|
84 (if (< search-slow-window-lines 0)
|
|
85 (progn (vertical-motion (- 1 search-slow-window-lines))
|
|
86 (set-window-start (next-window) (point))
|
|
87 (set-window-hscroll (next-window)
|
|
88 (window-hscroll))
|
|
89 (set-window-hscroll (selected-window) 0))
|
|
90 (other-window 1))
|
|
91 (goto-char found-point)))))
|
|
92 (let ((char (if quit-flag
|
|
93 ?\C-g
|
|
94 (read-char))))
|
|
95 (setq quit-flag nil adjusted nil)
|
|
96 ;; Meta character means exit search.
|
|
97 (cond ((and (>= char 128)
|
|
98 search-exit-option)
|
|
99 (setq unread-command-char char)
|
|
100 (throw 'search-done t))
|
|
101 ((eq char search-exit-char)
|
|
102 ;; Esc means exit search normally.
|
|
103 ;; Except, if first thing typed, it means do nonincremental
|
|
104 (if (= 0 (length search-string))
|
|
105 (vm-nonincremental-search forward regexp))
|
|
106 (throw 'search-done t))
|
|
107 ((= char ?\C-g)
|
|
108 ;; ^G means the user tried to quit.
|
|
109 (ding)
|
|
110 (discard-input)
|
|
111 (if success
|
|
112 ;; If search is successful, move back to starting point
|
|
113 ;; and really do quit.
|
|
114 (progn (goto-char opoint)
|
|
115 (vm-update-search-position)
|
|
116 (signal 'quit nil))
|
|
117 ;; If search is failing, rub out until it is once more
|
|
118 ;; successful.
|
|
119 (while (not success) (vm-isearch-pop))))
|
|
120 ((or (eq char search-repeat-char)
|
|
121 (eq char search-reverse-char))
|
|
122 (if (eq forward (eq char search-repeat-char))
|
|
123 ;; C-s in forward or C-r in reverse.
|
|
124 (if (equal search-string "")
|
|
125 ;; If search string is empty, use last one.
|
|
126 (setq search-string
|
|
127 (if regexp
|
|
128 search-last-regexp search-last-string)
|
|
129 search-message
|
|
130 (mapconcat 'text-char-description
|
|
131 search-string ""))
|
|
132 ;; If already have what to search for, repeat it.
|
|
133 (or success
|
|
134 (progn (goto-char (if forward (point-min) (point-max)))
|
|
135 (setq wrapped t))))
|
|
136 ;; C-s in reverse or C-r in forward, change direction.
|
|
137 (setq forward (not forward)))
|
|
138 (setq barrier (point)) ; For subsequent \| if regexp.
|
|
139 (setq success t)
|
|
140 (or (equal search-string "")
|
|
141 (vm-isearch-search))
|
|
142 (vm-isearch-push-state))
|
|
143 ((= char search-delete-char)
|
|
144 ;; Rubout means discard last input item and move point
|
|
145 ;; back. If buffer is empty, just beep.
|
|
146 (if (null (cdr cmds))
|
|
147 (ding)
|
|
148 (vm-isearch-pop)))
|
|
149 (t
|
|
150 (cond ((or (eq char search-yank-word-char)
|
|
151 (eq char search-yank-line-char))
|
|
152 ;; ^W means gobble next word from buffer.
|
|
153 ;; ^Y means gobble rest of line from buffer.
|
|
154 (let ((word (save-excursion
|
|
155 (and (not forward) other-end
|
|
156 (goto-char other-end))
|
|
157 (buffer-substring
|
|
158 (point)
|
|
159 (save-excursion
|
|
160 (if (eq char search-yank-line-char)
|
|
161 (end-of-line)
|
|
162 (forward-word 1))
|
|
163 (point))))))
|
|
164 (setq search-string (concat search-string word)
|
|
165 search-message
|
|
166 (concat search-message
|
|
167 (mapconcat 'text-char-description
|
|
168 word "")))))
|
|
169 ;; Any other control char =>
|
|
170 ;; unread it and exit the search normally.
|
|
171 ((and search-exit-option
|
|
172 (/= char search-quote-char)
|
|
173 (or (= char ?\177)
|
|
174 (and (< char ? ) (/= char ?\t) (/= char ?\r))))
|
|
175 (setq unread-command-char char)
|
|
176 (throw 'search-done t))
|
|
177 (t
|
|
178 ;; Any other character => add it to the
|
|
179 ;; search string and search.
|
|
180 (cond ((= char search-quote-char)
|
|
181 (setq char (read-quoted-char
|
|
182 (vm-isearch-message t))))
|
|
183 ((= char ?\r)
|
|
184 ;; unix braindeath
|
|
185 (setq char ?\n)))
|
|
186 (setq search-string (concat search-string
|
|
187 (char-to-string char))
|
|
188 search-message (concat search-message
|
|
189 (text-char-description char)))))
|
|
190 (if (and (not success)
|
|
191 ;; unsuccessful regexp search may become
|
|
192 ;; successful by addition of characters which
|
|
193 ;; make search-string valid
|
|
194 (not regexp))
|
|
195 nil
|
|
196 ;; If a regexp search may have been made more
|
|
197 ;; liberal, retreat the search start.
|
|
198 ;; Go back to place last successful search started
|
|
199 ;; or to the last ^S/^R (barrier), whichever is nearer.
|
|
200 (and regexp success cmds
|
|
201 (cond ((memq char '(?* ??))
|
|
202 (setq adjusted t)
|
|
203 (let ((cs (nth (if forward
|
|
204 5 ; other-end
|
|
205 2) ; saved (point)
|
|
206 (car (cdr cmds)))))
|
|
207 ;; (car cmds) is after last search;
|
|
208 ;; (car (cdr cmds)) is from before it.
|
|
209 (setq cs (or cs barrier))
|
|
210 (goto-char
|
|
211 (if forward
|
|
212 (max cs barrier)
|
|
213 (min cs barrier)))))
|
|
214 ((eq char ?\|)
|
|
215 (setq adjusted t)
|
|
216 (goto-char barrier))))
|
|
217 ;; In reverse regexp search, adding a character at
|
|
218 ;; the end may cause zero or many more chars to be
|
|
219 ;; matched, in the string following point.
|
|
220 ;; Allow all those possibilities without moving point as
|
|
221 ;; long as the match does not extend past search origin.
|
|
222 (if (and regexp (not forward) (not adjusted)
|
|
223 (condition-case ()
|
|
224 (looking-at search-string)
|
|
225 (error nil))
|
|
226 (<= (match-end 0) (min opoint barrier)))
|
|
227 (setq success t invalid-regexp nil
|
|
228 other-end (match-end 0))
|
|
229 ;; Not regexp, not reverse, or no match at point.
|
|
230 (if (and other-end (not adjusted))
|
|
231 (goto-char (if forward other-end
|
|
232 (min opoint barrier (1+ other-end)))))
|
|
233 (vm-isearch-search)))
|
|
234 (vm-isearch-push-state))))))
|
|
235 (setq found-start (window-start (selected-window)))
|
|
236 (setq found-point (point)))
|
|
237 (if (> (length search-string) 0)
|
|
238 (if regexp
|
|
239 (setq search-last-regexp search-string)
|
|
240 (setq search-last-string search-string)))
|
|
241 (message "")
|
|
242 (if small-window
|
|
243 (goto-char found-point)
|
|
244 ;; Exiting the save-window-excursion clobbers this; restore it.
|
|
245 (set-window-start (selected-window) found-start t))))
|
|
246
|
|
247 (defun vm-isearch-message (&optional c-q-hack ellipsis)
|
|
248 ;; If about to search, and previous search regexp was invalid,
|
|
249 ;; check that it still is. If it is valid now,
|
|
250 ;; let the message we display while searching say that it is valid.
|
|
251 (and invalid-regexp ellipsis
|
|
252 (condition-case ()
|
|
253 (progn (re-search-forward search-string (point) t)
|
|
254 (setq invalid-regexp nil))
|
|
255 (error nil)))
|
|
256 ;; If currently failing, display no ellipsis.
|
|
257 (or success (setq ellipsis nil))
|
|
258 (let ((m (concat (if success "" "failing ")
|
|
259 (if wrapped "wrapped ")
|
|
260 (if regexp "regexp " "")
|
|
261 "VM I-search"
|
|
262 (if forward ": " " backward: ")
|
|
263 search-message
|
|
264 (if c-q-hack "^Q" "")
|
|
265 (if invalid-regexp
|
|
266 (concat " [" invalid-regexp "]")
|
|
267 ""))))
|
|
268 (aset m 0 (upcase (aref m 0)))
|
|
269 (let ((cursor-in-echo-area ellipsis))
|
|
270 (if c-q-hack m (message "%s" m)))))
|
|
271
|
|
272 (defun vm-isearch-pop ()
|
|
273 (setq cmds (cdr cmds))
|
|
274 (let ((cmd (car cmds)))
|
|
275 (setq search-string (car cmd)
|
|
276 search-message (car (cdr cmd))
|
|
277 success (nth 3 cmd)
|
|
278 forward (nth 4 cmd)
|
|
279 other-end (nth 5 cmd)
|
|
280 invalid-regexp (nth 6 cmd)
|
|
281 wrapped (nth 7 cmd)
|
|
282 barrier (nth 8 cmd)
|
|
283 ; unused now
|
|
284 ; vm-ml-attributes-string (nth 9 cmd)
|
|
285 vm-ml-message-number (nth 10 cmd)
|
|
286 vm-message-pointer (nth 11 cmd))
|
|
287 (if vm-summary-buffer
|
|
288 (save-excursion
|
|
289 (set-buffer vm-summary-buffer)
|
|
290 (setq
|
|
291 ; unused now
|
|
292 ;vm-ml-attributes-string (nth 9 cmd)
|
|
293 vm-ml-message-number (nth 10 cmd))))
|
|
294 (goto-char (car (cdr (cdr cmd))))
|
|
295 (vm-set-summary-pointer (car vm-message-pointer))))
|
|
296
|
|
297 (defun vm-isearch-push-state ()
|
|
298 (setq cmds (cons (list search-string search-message (point)
|
|
299 success forward other-end invalid-regexp
|
|
300 wrapped barrier
|
|
301 ; unused now
|
|
302 ; vm-ml-attributes-string
|
|
303 nil
|
|
304 vm-ml-message-number
|
|
305 vm-message-pointer)
|
|
306 cmds)))
|
|
307
|
|
308 (defun vm-isearch-search ()
|
|
309 (vm-isearch-message nil t)
|
|
310 (condition-case lossage
|
|
311 (let ((inhibit-quit nil))
|
|
312 (if regexp (setq invalid-regexp nil))
|
|
313 (setq success
|
|
314 (funcall
|
|
315 (if regexp
|
|
316 (if forward 're-search-forward 're-search-backward)
|
|
317 (if forward 'search-forward 'search-backward))
|
|
318 search-string nil t))
|
|
319 (if success
|
|
320 (setq other-end
|
|
321 (if forward (match-beginning 0) (match-end 0)))))
|
|
322 (quit (setq unread-command-char ?\C-g)
|
|
323 (setq success nil))
|
|
324 (invalid-regexp (setq invalid-regexp (car (cdr lossage)))
|
|
325 (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
|
|
326 invalid-regexp)
|
|
327 (setq invalid-regexp "incomplete input"))))
|
|
328 (if success
|
|
329 (vm-update-search-position)
|
|
330 ;; Ding if failed this time after succeeding last time.
|
|
331 (and (nth 3 (car cmds))
|
|
332 (ding))
|
|
333 (goto-char (nth 2 (car cmds)))))
|
|
334
|
|
335 ;; This is called from incremental-search
|
|
336 ;; if the first input character is the exit character.
|
|
337 ;; The interactive-arg-reader uses free variables `forward' and `regexp'
|
|
338 ;; which are bound by `incremental-search'.
|
|
339
|
|
340 ;; We store the search string in `search-string'
|
|
341 ;; which has been bound already by `incremental-search'
|
|
342 ;; so that, when we exit, it is copied into `search-last-string'.
|
|
343
|
|
344 (defun vm-nonincremental-search (forward regexp)
|
|
345 (let (message char function string inhibit-quit
|
|
346 (cursor-in-echo-area t))
|
|
347 ;; Prompt assuming not word search,
|
|
348 (setq message (if regexp
|
|
349 (if forward "VM Regexp search: "
|
|
350 "VM Regexp search backward: ")
|
|
351 (if forward "VM Search: " "VM Search backward: ")))
|
|
352 (message "%s" message)
|
|
353 ;; Read 1 char and switch to word search if it is ^W.
|
|
354 (setq char (read-char))
|
|
355 (if (eq char search-yank-word-char)
|
|
356 (setq message (if forward "VM Word search: " "VM Word search backward: "))
|
|
357 ;; Otherwise let that 1 char be part of the search string.
|
|
358 (setq unread-command-char char))
|
|
359 (setq function
|
|
360 (if (eq char search-yank-word-char)
|
|
361 (if forward 'word-search-forward 'word-search-backward)
|
|
362 (if regexp
|
|
363 (if forward 're-search-forward 're-search-backward)
|
|
364 (if forward 'search-forward 'search-backward))))
|
|
365 ;; Read the search string with corrected prompt.
|
|
366 (setq string (read-string message))
|
|
367 ;; Empty means use default.
|
|
368 (if (= 0 (length string))
|
|
369 (setq string search-last-string)
|
|
370 ;; Set last search string now so it is set even if we fail.
|
|
371 (setq search-last-string string))
|
|
372 ;; Since we used the minibuffer, we should be available for redo.
|
|
373 (setq command-history (cons (list function string) command-history))
|
|
374 ;; Go ahead and search.
|
|
375 (funcall function string)))
|
|
376
|
|
377 (defun vm-update-search-position (&optional record-change)
|
|
378 (if (and (>= (point) (vm-start-of (car vm-message-pointer)))
|
|
379 (<= (point) (vm-end-of (car vm-message-pointer))))
|
|
380 nil
|
|
381 (let ((mp vm-message-list)
|
|
382 (point (point)))
|
|
383 (while mp
|
|
384 (if (and (>= point (vm-start-of (car mp)))
|
|
385 (<= point (vm-end-of (car mp))))
|
|
386 (if record-change
|
|
387 (progn
|
|
388 (vm-record-and-change-message-pointer vm-message-pointer mp)
|
|
389 (setq mp nil))
|
|
390 (setq vm-message-pointer mp mp nil))
|
|
391 (setq mp (cdr mp))))
|
|
392 (setq vm-need-summary-pointer-update t)
|
|
393 (vm-update-summary-and-mode-line))))
|
|
394
|
|
395 (defun vm-isearch-forward (&optional arg)
|
|
396 "Incrementally search forward through the current folder's messages.
|
|
397 Usage is identical to the standard Emacs incremental search.
|
|
398 When the search terminates the message containing point will be selected.
|
|
399
|
|
400 If the variable vm-search-using-regexps is non-nil, regular expressions
|
|
401 are understood; nil means the search will be for the input string taken
|
|
402 literally. Specifying a prefix ARG interactively toggles the value of
|
|
403 vm-search-using-regexps for this search."
|
|
404 (interactive "P")
|
|
405 (vm-follow-summary-cursor)
|
|
406 (vm-select-folder-buffer)
|
|
407 (vm-check-for-killed-summary)
|
|
408 (vm-error-if-folder-empty)
|
|
409 (vm-error-if-virtual-folder)
|
|
410 (vm-display (current-buffer) t '(vm-isearch-forward) '(vm-isearch-forward))
|
|
411 (let ((clip-head (point-min))
|
|
412 (clip-tail (point-max))
|
|
413 (old-w (selected-window)))
|
|
414 (unwind-protect
|
|
415 (progn (select-window (get-buffer-window (current-buffer)))
|
|
416 (widen)
|
|
417 (vm-isearch t (if arg
|
|
418 (not vm-search-using-regexps)
|
|
419 vm-search-using-regexps))
|
|
420 (vm-update-search-position t)
|
|
421 ;; vm-show-current-message only adjusts (point-max),
|
|
422 ;; it doesn't change (point-min).
|
|
423 (narrow-to-region
|
|
424 (if (< (point) (vm-vheaders-of (car vm-message-pointer)))
|
|
425 (vm-start-of (car vm-message-pointer))
|
|
426 (vm-vheaders-of (car vm-message-pointer)))
|
|
427 (point-max))
|
|
428 (vm-show-current-message)
|
|
429 (setq vm-system-state 'reading)
|
|
430 ;; turn the clipping unwind into a noop
|
|
431 (setq clip-head (point-min))
|
|
432 (setq clip-tail (point-max)))
|
|
433 (narrow-to-region clip-head clip-tail)
|
|
434 (select-window old-w))))
|
|
435
|
|
436 (defun vm-isearch-backward (&optional arg)
|
|
437 "Incrementally search backward through the current folder's messages.
|
|
438 Usage is identical to the standard Emacs incremental search.
|
|
439 When the search terminates the message containing point will be selected.
|
|
440
|
|
441 If the variable vm-search-using-regexps is non-nil, regular expressions
|
|
442 are understood; nil means the search will be for the input string taken
|
|
443 literally. Specifying a prefix ARG interactively toggles the value of
|
|
444 vm-search-using-regexps for this search."
|
|
445 (interactive "P")
|
|
446 (vm-follow-summary-cursor)
|
|
447 (vm-select-folder-buffer)
|
|
448 (vm-check-for-killed-summary)
|
|
449 (vm-error-if-folder-empty)
|
|
450 (vm-error-if-virtual-folder)
|
|
451 (vm-display (current-buffer) t '(vm-isearch-backward)
|
|
452 (list 'vm-isearch-backward 'searching-message))
|
|
453 (let ((clip-head (point-min))
|
|
454 (clip-tail (point-max))
|
|
455 (old-w (selected-window)))
|
|
456 (unwind-protect
|
|
457 (progn (select-window (get-buffer-window (current-buffer)))
|
|
458 (widen)
|
|
459 (vm-isearch nil (if arg
|
|
460 (not vm-search-using-regexps)
|
|
461 vm-search-using-regexps))
|
|
462 (vm-update-search-position t)
|
|
463 ;; vm-show-current-message only adjusts (point-max),
|
|
464 ;; it doesn't change (point-min).
|
|
465 (narrow-to-region
|
|
466 (if (< (point) (vm-vheaders-of (car vm-message-pointer)))
|
|
467 (vm-start-of (car vm-message-pointer))
|
|
468 (vm-vheaders-of (car vm-message-pointer)))
|
|
469 (point-max))
|
|
470 (vm-show-current-message)
|
|
471 (setq vm-system-state 'reading)
|
|
472 ;; turn the clipping unwind into a noop
|
|
473 (setq clip-head (point-min))
|
|
474 (setq clip-tail (point-max)))
|
|
475 (narrow-to-region clip-head clip-tail)
|
|
476 (select-window old-w))))
|