home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / prim / oisearch.el < prev    next >
Encoding:
Text File  |  1992-08-20  |  19.7 KB  |  559 lines
  1. ;; Incremental search
  2. ;; Copyright (C) 1985, 1986, 1992 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs 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, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs 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
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. ; in loaddefs.el
  21. ;(defvar search-last-string ""
  22. ;  "Last string search for by a search command.
  23. ;This does not include direct calls to the primitive search functions,
  24. ;and does not include searches that are aborted.")
  25. ;(defvar search-last-regexp ""
  26. ;  "Last string searched for by a regexp search command.
  27. ;This does not include direct calls to the primitive search functions,
  28. ;and does not include searches that are aborted.")
  29. ;
  30. ;(defconst search-repeat-char ?\C-s
  31. ;  "Character to repeat incremental search forwards.")
  32. ;(defconst search-reverse-char ?\C-r
  33. ;  "Character to repeat incremental search backwards.")
  34. ;(defconst search-exit-char ?\e
  35. ;  "Character to exit incremental search.")
  36. ;(defconst search-delete-char ?\177
  37. ;  "Character to delete from incremental search string.")
  38. ;(defconst search-quote-char ?\C-q
  39. ;  "Character to quote special characters for incremental search.")
  40. ;(defconst search-yank-word-char ?\C-w
  41. ;  "Character to pull next word from buffer into search string.")
  42. ;(defconst search-yank-line-char ?\C-y
  43. ;  "Character to pull rest of line from buffer into search string.")
  44. ;(defconst search-exit-option t
  45. ;  "Non-nil means random control characters terminate incremental search.")
  46. ;
  47. ;(defvar search-slow-window-lines 1
  48. ;  "*Number of lines in slow search display windows.")
  49. ;(defconst search-slow-speed 1200
  50. ;  "*Highest terminal speed at which to use \"slow\" style incremental search.
  51. ;This is the style where a one-line window is created to show the line
  52. ;that the search has reached.")
  53.  
  54. (fset 'search-forward-regexp 're-search-forward)
  55. (fset 'search-backward-regexp 're-search-backward)
  56.  
  57. (defvar search-ring nil
  58.   "List of search string sequences.")
  59. (defvar regex-search-ring nil
  60.   "List of regular expression search string sequences.")
  61.  
  62. (defconst search-ring-max 16
  63.   "*Maximum length of search ring before oldest elements are thrown away.")
  64. (defconst regex-search-ring-max 16
  65.   "*Maximum length of search ring before oldest elements are thrown away.")
  66.  
  67. (defvar search-ring-yank-pointer nil
  68.   "The tail of the search ring whose car is the last thing searched for.")
  69. (defvar regex-search-ring-yank-pointer nil
  70.   "The tail of the regular expression search ring whose car is the last
  71. thing searched for.")
  72.  
  73. ;; This function does all the work of incremental search.
  74. ;; The functions attached to ^R and ^S are trivial,
  75. ;; merely calling this one, but they are always loaded by default
  76. ;; whereas this file can optionally be autoloadable.
  77. ;; This is the only entry point in this file.
  78.  
  79. ;; OP-FUN is a function to be called after each input character is processed.
  80. ;; (It is not called after characters that exit the search.)
  81.  
  82. (defun isearch (forward &optional regexp op-fun)
  83.   (let ((search-string "")
  84.     (search-message "")
  85.     (cmds nil)
  86.     (success t)
  87.     (wrapped nil)
  88.     (barrier (point))
  89.     adjusted yank-flag
  90.     (invalid-regexp nil)
  91.     (slow-terminal-mode (and (<= baud-rate search-slow-speed)
  92.                  (> (window-height)
  93.                     (* 4 search-slow-window-lines))))
  94.     (other-end nil)    ;Start of last match if fwd, end if backwd.
  95.     (small-window nil)        ;if t, using a small window
  96.     (found-point nil)        ;to restore point from a small window
  97.     ;; This is the window-start value found by the search.
  98.     (found-start nil)
  99.     (opoint (point))
  100.     (event (allocate-event))
  101.     (inhibit-quit t))  ;Prevent ^G from quitting immediately.
  102.     (isearch-push-state)
  103.     (save-window-excursion
  104.      (catch 'search-done
  105.        (while t
  106.      (or unread-command-event
  107.          (progn
  108.            (or (input-pending-p)
  109.            (isearch-message))
  110.            (if (and slow-terminal-mode
  111.             (not (or small-window (pos-visible-in-window-p))))
  112.            (progn
  113.              (setq small-window t)
  114.              (setq found-point (point))
  115.              (move-to-window-line 0)
  116.              (let ((window-min-height 1))
  117.                (split-window nil (if (< search-slow-window-lines 0)
  118.                          (1+ (- search-slow-window-lines))
  119.                        (- (window-height)
  120.                           (1+ search-slow-window-lines)))))
  121.              (if (< search-slow-window-lines 0)
  122.              (progn (vertical-motion (- 1 search-slow-window-lines))
  123.                 (set-window-start (next-window) (point))
  124.                 (set-window-hscroll (next-window)
  125.                             (window-hscroll))
  126.                 (set-window-hscroll (selected-window) 0))
  127.                (other-window 1))
  128.              (goto-char found-point)))))
  129.      (isearch-next-event event)
  130.      (let ((char (if quit-flag
  131.              interrupt-char
  132.                (if (zerop (logand (event-modifier-bits event) -2))
  133.                (or (event-to-character event t) event)
  134.              event))))
  135.        (setq quit-flag nil adjusted nil yank-flag nil)
  136.        (cond ((and (or (not (integerp char))
  137. ;               (and (>= char 128)
  138. ;                (not (= char search-ring-advance-char))
  139. ;                (not (= char search-ring-retreat-char)))
  140.                )
  141.                search-exit-option)
  142.           (setq unread-command-event event)
  143.           (throw 'search-done t))
  144.          ((eq char search-exit-char)
  145.           ;; Esc means exit search normally.
  146.           ;; Except, if first thing typed, it means do nonincremental
  147.           (if (= 0 (length search-string))
  148.               (nonincremental-search forward regexp))
  149.           (throw 'search-done t))
  150.          ((= char interrupt-char)
  151.           ;; ^G means the user tried to quit.
  152.           (ding nil 'isearch-quit)
  153.           (discard-input)
  154.           (if success
  155.               ;; If search is successful, move back to starting point
  156.               ;; and really do quit.
  157.               (progn (goto-char opoint)
  158.                  (signal 'quit nil))
  159.             ;; If search is failing, rub out until it is once more
  160.             ;;  successful.
  161.             (while (not success) (isearch-pop))))
  162.          ((or (eq char search-repeat-char)
  163.               (eq char search-reverse-char))
  164.           (if (eq forward (eq char search-repeat-char))
  165.               ;; C-s in forward or C-r in reverse.
  166.               (if (equal search-string "")
  167.               ;; If search string is empty, use last one.
  168.               (setq search-string
  169.                 (or (if regexp
  170.                     (if regex-search-ring-yank-pointer
  171.                         (car regex-search-ring-yank-pointer)
  172.                       (car regex-search-ring))
  173.                       (if search-ring-yank-pointer
  174.                       (car search-ring-yank-pointer)
  175.                     (car search-ring)))
  176.                     "")
  177.                 search-message
  178.                 (mapconcat 'isearch-text-char-description
  179.                        search-string ""))
  180.             ;; If already have what to search for, repeat it.
  181.             (or success
  182.                 (progn (goto-char (if forward (point-min) (point-max)))
  183.                    (setq wrapped t))))
  184.             ;; C-s in reverse or C-r in forward, change direction.
  185.             (setq forward (not forward)))
  186.           (setq barrier (point)) ; For subsequent \| if regexp.
  187.           (setq success t)
  188.           (or (equal search-string "")
  189.               (progn
  190.             ;; If repeating a search that found
  191.             ;; an empty string, ensure we advance.
  192.             (if (equal (match-end 0) (match-beginning 0))
  193.                 (forward-char (if forward 1 -1)))
  194.             (isearch-search)))
  195.           (isearch-push-state))
  196.          ((= char search-delete-char)
  197.           ;; Rubout means discard last input item and move point
  198.           ;; back.  If buffer is empty, just beep.
  199.           (if (null (cdr cmds))
  200.               (ding nil 'isearch-quit)
  201.             (isearch-pop)))
  202.          ((= char search-ring-advance-char)
  203.           (isearch-pop)
  204.           (if regexp
  205.               (let ((length (length regex-search-ring)))
  206.             (if (zerop length)
  207.                 ()
  208.               (setq regex-search-ring-yank-pointer
  209.                 (nthcdr (% (+ 1 (- length (length regex-search-ring-yank-pointer)))
  210.                        length)
  211.                     regex-search-ring)
  212.                 search-string (car regex-search-ring-yank-pointer)
  213.                 search-message
  214.                 (mapconcat 'isearch-text-char-description
  215.                        search-string ""))))
  216.             (let ((length (length search-ring)))
  217.             (if (zerop length)
  218.                 ()
  219.               (setq search-ring-yank-pointer
  220.                 (nthcdr (% (+ 1 (- length (length search-ring-yank-pointer)))
  221.                        length)
  222.                     search-ring)
  223.                 search-string (car search-ring-yank-pointer)
  224.                 search-message
  225.                 (mapconcat 'isearch-text-char-description
  226.                        search-string "")))))
  227.           (isearch-push-state)
  228.           (isearch-search))
  229.          ((= char search-ring-retreat-char)
  230.           (isearch-pop)
  231.           (if regexp
  232.               (let ((length (length regex-search-ring)))
  233.             (if (zerop length)
  234.                 ()
  235.               (setq regex-search-ring-yank-pointer
  236.                 (nthcdr (% (+ (- length (length regex-search-ring-yank-pointer))
  237.                           (1- length))
  238.                        length)
  239.                     regex-search-ring)
  240.                 search-string (car regex-search-ring-yank-pointer)
  241.                 search-message
  242.                 (mapconcat 'isearch-text-char-description
  243.                        search-string ""))))
  244.             (let ((length (length search-ring)))
  245.             (if (zerop length)
  246.                 ()
  247.               (setq search-ring-yank-pointer
  248.                 (nthcdr (% (+ (- length (length search-ring-yank-pointer))
  249.                           (1- length))
  250.                        length)
  251.                     search-ring)
  252.                 search-string (car search-ring-yank-pointer)
  253.                 search-message
  254.                 (mapconcat 'isearch-text-char-description
  255.                        search-string "")))))
  256.           (isearch-push-state)
  257.           (isearch-search))
  258.          (t
  259.           (cond ((or (eq char search-yank-word-char)
  260.                  (eq char search-yank-line-char))
  261.              ;; ^W means gobble next word from buffer.
  262.              ;; ^Y means gobble rest of line from buffer.
  263.              (let ((word (save-excursion
  264.                        (and (not forward) other-end
  265.                         (goto-char other-end))
  266.                        (buffer-substring
  267.                     (point)
  268.                     (save-excursion
  269.                       (if (eq char search-yank-line-char)
  270.                           (end-of-line)
  271.                         (forward-word 1))
  272.                       (point))))))
  273.                (if regexp
  274.                    (setq word (regexp-quote word)))
  275.                (setq search-string (concat search-string word)
  276.                  search-message
  277.                  (concat search-message
  278.                      (mapconcat 'isearch-text-char-description
  279.                             word ""))
  280.                  ;; Don't move cursor in reverse search.
  281.                  yank-flag t)))
  282.              ;; Any other control char =>
  283.              ;;  unread it and exit the search normally.
  284.              ((and search-exit-option
  285.                    (/= char search-quote-char)
  286.                    (or (= char ?\177)
  287.                    (and (< char ? ) (/= char ?\t) (/= char ?\r))))
  288.               (setq unread-command-event event)
  289.               (throw 'search-done t))
  290.              (t
  291.               ;; Any other character => add it to the
  292.               ;;  search string and search.
  293.               (cond ((= char search-quote-char)
  294.                  (setq char (read-quoted-char
  295.                          (isearch-message t))))
  296.                 ((= char ?\r)
  297.                  ;; RET translates to newline.
  298.                  (setq char ?\n)))
  299.               (setq search-string (concat search-string
  300.                               (char-to-string char))
  301.                 search-message (concat search-message
  302.                                (isearch-text-char-description char)))))
  303.           (if (and (not success)
  304.                ;; unsuccessful regexp search may become
  305.                ;;  successful by addition of characters which
  306.                ;;  make search-string valid
  307.                (not regexp))
  308.               nil
  309.             ;; Check for chars that can make a regexp more liberal.
  310.             ;; They can make a regexp match sooner
  311.             ;; or make it succeed instead of failing.
  312.             ;; So go back to place last successful search started
  313.             ;; or to the last ^S/^R (barrier), whichever is nearer.
  314.             (and regexp cmds
  315.              (cond ((memq char '(?* ??))
  316.                 (setq adjusted t)
  317.                 (let ((cs (nth (if forward
  318.                            5 ; other-end
  319.                          2) ; saved (point)
  320.                            (car (cdr cmds)))))
  321.                   ;; (car cmds) is after last search;
  322.                   ;; (car (cdr cmds)) is from before it.
  323.                   (setq cs (or cs barrier))
  324.                   (goto-char
  325.                    (if forward
  326.                        (max cs barrier)
  327.                      (min cs barrier)))))
  328.                    ((eq char ?\|)
  329.                 (setq adjusted t)
  330.                 (goto-char barrier))))
  331.             ;; In reverse search, adding stuff at
  332.             ;; the end may cause zero or many more chars to be
  333.             ;; matched, in the string following point.
  334.             ;; Allow all those possibilities without moving point as
  335.             ;; long as the match does not extend past search origin.
  336.             (if (and (not forward) (not adjusted)
  337.                  (condition-case ()
  338.                  (looking-at (if regexp search-string
  339.                            (regexp-quote search-string)))
  340.                    (error nil))
  341.                  (or yank-flag
  342.                  (<= (match-end 0) (min opoint barrier))))
  343.             (setq success t invalid-regexp nil
  344.                   other-end (match-end 0))
  345.               ;; Not regexp, not reverse, or no match at point.
  346.               (if (and other-end (not adjusted))
  347.               (goto-char (if forward other-end
  348.                        (min opoint barrier (1+ other-end)))))
  349.               (isearch-search)))
  350.           (isearch-push-state))))
  351.      (if op-fun (funcall op-fun))))
  352.      (setq found-start (window-start (selected-window))
  353.        found-point (point)))
  354.     (if (> (length search-string) 0)
  355.     (if (and regexp (not (setq regex-search-ring-yank-pointer
  356.                    (member search-string regex-search-ring))))
  357.         (progn
  358.           (setq regex-search-ring (cons search-string regex-search-ring)
  359.             regex-search-ring-yank-pointer regex-search-ring)
  360.           (if (> (length regex-search-ring) regex-search-ring-max)
  361.           (setcdr (nthcdr (1- regex-search-ring-max)
  362.                   regex-search-ring) nil)))
  363.       (if (not (setq search-ring-yank-pointer
  364.              (member search-string search-ring)))
  365.           (progn
  366.         (setq search-ring (cons search-string search-ring)
  367.               search-ring-yank-pointer search-ring)
  368.         (if (> (length search-ring) search-ring-max)
  369.             (setcdr (nthcdr (1- search-ring-max) search-ring) nil))))))
  370.     ;; If there was movement, mark the starting position.
  371.     ;; Maybe should test difference between and set mark iff > threshold.
  372.     (if (/= (point) opoint)
  373.     (push-mark opoint)
  374.       (message ""))
  375.     (if small-window
  376.     (goto-char found-point)
  377.       ;; Exiting the save-window-excursion clobbers this; restore it.
  378.       (set-window-start (selected-window) found-start t))))
  379.  
  380.  
  381. (defun isearch-text-char-description (c)
  382.   ;; like text-char-description but doesn't hack bit 8 to meta
  383.   (if (zerop (logand c 128))
  384.       (text-char-description c)
  385.     (char-to-string c)))
  386.  
  387.  
  388. ; in loaddefs.el
  389. ;(defvar isearch-highlight t
  390. ;  "*If true, then isearch will highlight the text which currently matches
  391. ;the search-string.  It will be highlighted in the same way that the X
  392. ;selection is.")
  393.  
  394. (defvar isearch-extent nil)
  395.  
  396. (or (find-face 'isearch)
  397.     (make-face 'isearch))
  398.  
  399. (defun isearch-highlight (begin end)
  400.   (if (and (extentp isearch-extent)
  401.        (eq (extent-buffer isearch-extent) (current-buffer)))
  402.       (update-extent isearch-extent begin end)
  403.     (if (and (extentp isearch-extent)
  404.          (bufferp (extent-buffer isearch-extent))
  405.          (buffer-name (extent-buffer isearch-extent)))
  406.     (delete-extent isearch-extent))
  407.     (setq isearch-extent (make-extent begin end (current-buffer))))
  408.   (set-extent-face isearch-extent 'isearch))
  409.  
  410. (defun isearch-dehighlight (totally)
  411.   (if isearch-extent
  412.       (if totally
  413.       (let ((inhibit-quit t))
  414.         (if (and (extentp isearch-extent)
  415.              (bufferp (extent-buffer isearch-extent))
  416.              (buffer-name (extent-buffer isearch-extent)))
  417.         (delete-extent isearch-extent))
  418.         (setq isearch-extent nil))
  419.     (if (and (extentp isearch-extent)
  420.          (bufferp (extent-buffer isearch-extent))
  421.          (buffer-name (extent-buffer isearch-extent)))
  422.         (set-extent-face isearch-extent 'default)
  423.       (isearch-dehighlight t)))))
  424.  
  425. (defun isearch-next-event (event)
  426.   (if (not isearch-highlight)
  427.       (next-command-event event)
  428.     (let* ((begin
  429.         (and other-end (/= other-end (point))
  430.          (if (< other-end (point)) other-end (point))))
  431.        (end
  432.         (and begin
  433.          (if (< other-end (point)) (point) other-end))))
  434.       (if end
  435.       (isearch-highlight begin end)
  436.     (isearch-dehighlight nil))
  437.       (unwind-protect
  438.       (next-command-event event)
  439.     (isearch-dehighlight nil)))))
  440.  
  441.  
  442. (defun isearch-message (&optional c-q-hack ellipsis)
  443.   ;; If about to search, and previous search regexp was invalid,
  444.   ;; check that it still is.  If it is valid now,
  445.   ;; let the message we display while searching say that it is valid.
  446.   (and invalid-regexp ellipsis
  447.        (condition-case ()
  448.        (progn (re-search-forward search-string (point) t)
  449.           (setq invalid-regexp nil))
  450.      (error nil)))
  451.   ;; If currently failing, display no ellipsis.
  452.   (or success (setq ellipsis nil))
  453.   (let ((m (concat (if success "" "failing ")
  454.            (if wrapped "wrapped ")
  455.            (if regexp "regexp " "")
  456.            "I-search"
  457.            (if forward ": " " backward: ")
  458.            search-message
  459.            (if c-q-hack "^Q" "")
  460.            (if invalid-regexp
  461.                (concat " [" invalid-regexp "]")
  462.              ""))))
  463.     (aset m 0 (upcase (aref m 0)))
  464.     (let ((cursor-in-echo-area ellipsis))
  465.       (if c-q-hack m (message "%s" m)))))
  466.  
  467. (defun isearch-pop ()
  468.   (setq cmds (cdr cmds))
  469.   (let ((cmd (car cmds)))
  470.     (setq search-string (car cmd)
  471.       search-message (car (cdr cmd))
  472.       success (nth 3 cmd)
  473.       forward (nth 4 cmd)
  474.       other-end (nth 5 cmd)
  475.       invalid-regexp (nth 6 cmd)
  476.       wrapped (nth 7 cmd)
  477.       barrier (nth 8 cmd))
  478.     (goto-char (car (cdr (cdr cmd))))))
  479.  
  480. (defun isearch-push-state ()
  481.   (setq cmds (cons (list search-string search-message (point)
  482.              success forward other-end invalid-regexp
  483.              wrapped barrier)
  484.            cmds)))
  485.  
  486. (defun isearch-search ()
  487.   (isearch-message nil t)
  488.   (condition-case lossage
  489.       (let ((inhibit-quit nil))
  490.     (if regexp (setq invalid-regexp nil))
  491.     (setq success
  492.           (funcall
  493.            (if regexp
  494.            (if forward 're-search-forward 're-search-backward)
  495.          (if forward 'search-forward 'search-backward))
  496.            search-string nil t))
  497.     (if success
  498.         (setq other-end
  499.           (if forward (match-beginning 0) (match-end 0)))))
  500.     ;; ## This cruft probably isn't necessary with the new event loop.
  501.     (quit (setq unread-command-event
  502.         (character-to-event interrupt-char (allocate-event)))
  503.       (setq success nil))
  504.     (invalid-regexp (setq invalid-regexp (car (cdr lossage)))
  505.             (if (string-match "\\`Premature \\|\\`Unmatched \\|\\`Invalid "
  506.                       invalid-regexp)
  507.             (setq invalid-regexp "incomplete input"))))
  508.   (if success
  509.       nil
  510.     ;; Ding if failed this time after succeeding last time.
  511.     (and (nth 3 (car cmds))
  512.      (ding nil 'isearch-failed))
  513.     (goto-char (nth 2 (car cmds)))))
  514.  
  515. ;; This is called from incremental-search
  516. ;; if the first input character is the exit character.
  517. ;; The interactive-arg-reader uses free variables `forward' and `regexp'
  518. ;; which are bound by `incremental-search'.
  519.  
  520. ;; We store the search string in `search-string'
  521. ;; which has been bound already by `incremental-search'
  522. ;; so that, when we exit, it is copied into `search-last-string'.
  523.  
  524. (defun nonincremental-search (forward regexp)
  525.   (let (message char function string inhibit-quit
  526.         (cursor-in-echo-area t))
  527.     ;; Prompt assuming not word search,
  528.     (setq message (if regexp 
  529.               (if forward "Regexp search: "
  530.             "Regexp search backward: ")
  531.             (if forward "Search: " "Search backward: ")))
  532.     (message "%s" message)
  533.     ;; Read 1 char and switch to word search if it is ^W.
  534.     (isearch-next-event event) ; dynamic reference
  535.     (setq char (or (event-to-character event t) event))
  536.     (if (and (numberp char) (eq char search-yank-word-char))
  537.     (setq message (if forward "Word search: " "Word search backward: "))
  538.       ;; Otherwise let that 1 char be part of the search string.
  539.       (if (numberp char)
  540.       (setq unread-command-event event)
  541.     (dispatch-event event)))
  542.     (setq function
  543.       (if (eq char search-yank-word-char)
  544.           (if forward 'word-search-forward 'word-search-backward)
  545.         (if regexp
  546.         (if forward 're-search-forward 're-search-backward)
  547.           (if forward 'search-forward 'search-backward))))
  548.     ;; Read the search string with corrected prompt.
  549.     (setq string (read-string message))
  550.     ;; Empty means use default.
  551.     (if (= 0 (length string))
  552.     (setq string search-last-string)
  553.       ;; Set last search string now so it is set even if we fail.
  554.       (setq search-last-string string))
  555.     ;; Since we used the minibuffer, we should be available for redo.
  556.     (setq command-history (cons (list function string) command-history))
  557.     ;; Go ahead and search.
  558.     (funcall function string)))
  559.