home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / modes / S-mode / comint-isearch.el < prev    next >
Encoding:
Text File  |  1992-06-08  |  9.2 KB  |  292 lines
  1. ;;; -*-Emacs-Lisp-*- Incremental command search for comint
  2. ;;; Terry Glanfield (tg.southern@rxuk.xerox.com)
  3. ;;; Version 1.0
  4. ;;; 
  5. ;;; This file is not part of GNU Emacs but the same permissions apply.
  6. ;;; 
  7. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  8. ;;; it under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 1, or (at your option)
  10. ;;; any later version.
  11. ;;;
  12. ;;; GNU Emacs is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  19. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20. ;;;
  21. ;;;
  22. ;;; This is an incremental command search mode for comint.  Previous
  23. ;;; commands that match are inserted on the command line as you type.
  24. ;;; Anyone familiar with the emacs isearch or bash should find this easy
  25. ;;; to adapt to.
  26. ;;; 
  27. ;;; It is based on ideas from bash and borrows heavily from isearch.el.
  28. ;;; 
  29. ;;; Differences from bash:
  30. ;;;   * C-s searches forwards
  31. ;;;   * DEL cancels characters or moves to previous search
  32. ;;;   * C-g also moves to previous successful search
  33. ;;;   * Inserts previous search string
  34. ;;; 
  35. ;;; Differences from isearch:
  36. ;;;   * No C-w or C-y
  37. ;;;   * No wrap around, yet
  38. ;;; 
  39. ;;; It uses the variables search-repeat-char, search-exit-char etc.
  40. ;;; 
  41. ;;;  recommended usage:
  42. ;;; (setq cmushell-load-hook
  43. ;;;       '((lambda ()
  44. ;;;       (require 'comint-isearch)
  45. ;;;       (define-key cmushell-mode-map "\C-r" 'comint-isearch))))
  46.  
  47. ;; LCD Archive Entry:
  48. ;; comint-isearch|Terry Glanfield|tg.southern@rxuk.xerox.com
  49. ;; |Command line incremental searching for comint.
  50. ;; |92-04-10|Version 1.0|~/packages/comint-isearch.el.Z
  51.  
  52. (require 'comint)
  53. (provide 'comint-isearch)
  54.  
  55. (defvar comint-last-isearch-string nil
  56.   "Last string searched for in comint-isearch.")
  57.  
  58. (defvar comint-isearch-buffer " *Ring Buffer*"
  59.   "Buffer used in comint-isearch")
  60.  
  61. (defun comint-isearch ()
  62.   "Do incremental searching for commands in comint shells.
  63. As you type characters, they add to the search string and the
  64. matching command line from the history ring is inserted.
  65. Type Delete to cancel characters from end of search string.
  66. Type ESC to exit, leaving point at location found.
  67. Type C-r to search again, C-s to search again forwards.
  68. Type C-q to quote control character to search for it.
  69. Type RET to send this command to the shell.
  70. Other control and meta characters terminate the search
  71.  and are then executed normally.
  72. The above special characters are mostly controlled by parameters;
  73.  do M-x apropos on search-.*-char to find them.
  74. C-g while searching or when search has failed
  75.  cancels input back to what has been found successfully.
  76. C-g when search is successful aborts and moves point to starting point."
  77.   (interactive)
  78.   (let ((ring-len (ring-length input-ring)))
  79.     (cond ((not (comint-after-pmark-p))
  80.        (isearch-backward))
  81.       ((<= ring-len 0)
  82.        (message "Empty input ring")
  83.        (ding))
  84.       (t
  85.        (comint-isearch-internal)))))
  86.  
  87. (defun comint-isearch-internal ()
  88.   (let* ((search-string "")
  89.      (search-message "")
  90.      (success t)
  91.      (cmds nil)
  92.      (forward nil)
  93.      (pmark (marker-position
  94.          (process-mark (get-buffer-process (current-buffer)))))
  95.      (saved-prompt (buffer-substring
  96.             (save-excursion (beginning-of-line) (point))
  97.             pmark))
  98.      (saved-command (buffer-substring
  99.              pmark
  100.              (save-excursion (end-of-line) (point))))
  101.      (saved-point (- (point-max) (point)))
  102.      (ring input-ring)
  103.      (ring-buf (get-buffer-create comint-isearch-buffer))
  104.      (ring-point nil)
  105.      (line-point 0)
  106.      (abort-flag nil)
  107.      (inhibit-quit t))  ;Prevent ^G from quitting.
  108.     (save-excursion
  109.       (set-buffer ring-buf)
  110.       ;; fill temporary buffer with history ring
  111.       (erase-buffer)
  112.       (let ((n ring-len))
  113.     (while (> n 0)
  114.       (setq n (1- n))
  115.       (insert (ring-ref ring n) 10)))
  116.       (insert saved-command)
  117.       (end-of-buffer)
  118.       (backward-char saved-point)
  119.       (setq ring-point (point))
  120.       (setq line-point (- (point-max) (point))))
  121.     (comint-isearch-push)
  122.     (catch 'search-done
  123.       (while t
  124.     (or (>= unread-command-char 0)
  125.         (progn
  126.           (or (input-pending-p)
  127.           (comint-isearch-prompt))))
  128.     (let ((char (if quit-flag
  129.             ?\C-g
  130.               (read-char))))
  131.       (setq quit-flag nil)
  132.       (cond ((and (>= char 128)
  133.               search-exit-option)
  134.          (setq unread-command-char char)
  135.          ;; Meta character means exit search.
  136.          (setq unread-command-char char)
  137.          (throw 'search-done t))
  138.         ((eq char search-exit-char)
  139.          ;; Esc means exit search normally.
  140.          (throw 'search-done t))
  141.         ((= char ?\C-g)
  142.          ;; ^G means the user tried to quit.
  143.          ;; needs to be more clever
  144.          (ding)
  145.          (discard-input)
  146.          (if success
  147.              ;; really do quit.
  148.              (progn (setq abort-flag t)
  149.                 (throw 'search-done t))
  150.            ;; If search is failing, rub out until it is once more
  151.            ;;  successful.
  152.            (while (not success) (comint-isearch-pop))
  153.            ;; If it is now at the start, exit anyway
  154.            (if (equal search-string "")
  155.                (progn (setq abort-flag t)
  156.                   (throw 'search-done t)))))
  157.         ((or (eq char search-repeat-char)
  158.              (eq char search-reverse-char))
  159.          (if (eq forward (eq char search-repeat-char))
  160.              ;; C-s in forward or C-r in reverse.
  161.              (if (equal search-string "")
  162.              ;; If search string is empty, use last one.
  163.              (setq search-string comint-last-isearch-string
  164.                    search-message (mapconcat 'text-char-description
  165.                              search-string ""))
  166.                ;; If already have what to search for, repeat it.
  167.                (or success (ding)))
  168.            ;; C-s in reverse or C-r in forward, change direction.
  169.            (setq forward (not forward)))
  170.          (setq success t)
  171.          (or (equal search-string "")
  172.              (comint-isearch-search t))
  173.          (comint-isearch-push))
  174.         ((= char search-delete-char)
  175.          ;; Rubout means discard last input item and move point
  176.          ;; back.  If buffer is empty, just beep.
  177.           (if (null (cdr cmds))
  178.               (ding)
  179.             (comint-isearch-pop)))
  180.         ((or (= char ?\r)
  181.              (= char ?\n))
  182.          ;; Accept this line
  183.          (setq unread-command-char char)
  184.          (throw 'search-done t))
  185.         (t
  186.          ;; could add search-yank-word-char
  187.          ;; and search-yank-line-char in here
  188.          (cond ((and
  189.              search-exit-option
  190.              (/= char search-quote-char)
  191.              (or (= char ?\177)
  192.                  (and (< char ? ) (/= char ?\t) (/= char ?\r))))
  193.             ;; Any other control char =>
  194.             ;;  unread it and exit the search normally.
  195.             (setq unread-command-char char)
  196.             (throw 'search-done t))
  197.                (t
  198.             ;; Any other character => add it to the
  199.             ;;  search string and search.
  200.             (and (= char search-quote-char)
  201.                  (setq char (read-quoted-char
  202.                      (comint-isearch-prompt t))))
  203.             (setq search-string (concat
  204.                          search-string
  205.                          (char-to-string char))
  206.                   search-message (concat
  207.                           search-message
  208.                           (text-char-description char)))))
  209.          (if success
  210.              (comint-isearch-search))
  211.          (comint-isearch-push))))))
  212.     (message "")
  213.     (delete-region
  214.      (progn (beginning-of-line) (point))
  215.      (progn (end-of-line) (point)))
  216.     (insert-string saved-prompt)
  217.     (if (or abort-flag
  218.         (equal search-string ""))
  219.     (progn (insert saved-command)
  220.            (backward-char saved-point))
  221.       (progn (insert (comint-isearch-selected-line))
  222.          (backward-char line-point)
  223.          (if (> (length search-string) 0)
  224.          (setq comint-last-isearch-string search-string))))
  225.     (set-marker (process-mark (get-buffer-process (current-buffer))) pmark)))
  226.  
  227. (defun comint-isearch-selected-line ()
  228.   (save-excursion
  229.     (set-buffer ring-buf)
  230.     (goto-char ring-point)
  231.     (beginning-of-line)
  232.     (buffer-substring
  233.      (point)
  234.      (progn (end-of-line) (point)))))
  235.  
  236. (defun comint-isearch-prompt (&optional c-q-hack)
  237.   (let ((m (concat "(I-search: '"
  238.            search-message
  239.            (if c-q-hack "^Q" "")
  240.            "'): "))
  241.     (c (if ring-point
  242.            (comint-isearch-selected-line)
  243.          "")))
  244.     (beginning-of-line)
  245.     (delete-region (point) (save-excursion (end-of-line) (point)))
  246.     (insert-string m c)
  247.     (backward-char line-point)
  248.     ;; ditch garbage from mini-buffer
  249.     (message " ")))
  250.  
  251. (defun comint-isearch-pop ()
  252.   (setq cmds (cdr cmds))
  253.   (let ((cmd (car cmds)))
  254.     (setq search-string (car cmd)
  255.       search-message (car (cdr cmd))
  256.       success (nth 2 cmd)
  257.       forward (nth 3 cmd)
  258.       ring-point (nth 4 cmd)
  259.       line-point (nth 5 cmd))
  260.     (save-excursion
  261.       (set-buffer ring-buf)
  262.       (goto-char ring-point))))
  263.  
  264. (defun comint-isearch-push ()
  265.   (setq cmds (cons (list search-string search-message success
  266.              forward ring-point line-point)
  267.            cmds)))
  268.  
  269. (defun comint-isearch-search (&optional repeat)
  270.   (save-excursion
  271.     (set-buffer ring-buf)
  272.     (if forward
  273.     (goto-char ring-point)
  274.       (goto-char (+ ring-point (if (null repeat) (length search-string) 0))))
  275.     (condition-case lossage
  276.     (let ((inhibit-quit nil))
  277.       (setq success
  278.         (funcall
  279.          (if forward 'search-forward 'search-backward)
  280.          search-string nil t))
  281.       (if success
  282.           (progn (setq ring-point (point))
  283.              (end-of-line)
  284.              (setq line-point (- (point) ring-point)))))
  285.       (quit (setq unread-command-char ?\C-g)
  286.         (setq success nil)))
  287.     (if success
  288.     nil
  289.       ;; Ding if failed this time after succeeding last time.
  290.       (and (nth 2 (car cmds))
  291.        (ding)))))
  292.