home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-minibuf.el < prev    next >
Encoding:
Text File  |  1995-08-18  |  14.7 KB  |  401 lines
  1. ;;; Minibuffer read functions for VM
  2. ;;; Copyright (C) 1993, 1994 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-minibuf)
  19.  
  20. (defun vm-minibuffer-complete-word (&optional exiting)
  21.   (interactive)
  22.   (let ((opoint (point))
  23.     trimmed-c-list c-list beg end diff word word-prefix-regexp completion)
  24.     ;; find the beginning and end of the word we're trying to complete
  25.     (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
  26.     (progn
  27.       (skip-chars-backward " \t\n")   
  28.       (and (not (eobp)) (forward-char))
  29.       (setq end (point)))
  30.       (skip-chars-forward "^ \t\n")
  31.       (setq end (point)))
  32.     (skip-chars-backward "^ \t\n")
  33.     (setq beg (point))
  34.     (goto-char opoint)
  35.     ;; copy the word into a string
  36.     (setq word (buffer-substring beg end))
  37.     ;; trim the completion list down to just likely candidates
  38.     ;; then convert it to an alist.
  39.     (setq word-prefix-regexp (concat "^" (regexp-quote word))
  40.       trimmed-c-list (vm-delete-non-matching-strings
  41.               word-prefix-regexp
  42.               vm-minibuffer-completion-table)
  43.       trimmed-c-list (mapcar 'list trimmed-c-list)
  44.       c-list (mapcar 'list vm-minibuffer-completion-table))
  45.     ;; Try the word against the completion list.
  46.     (and trimmed-c-list
  47.      (setq completion (try-completion word trimmed-c-list)))
  48.     ;; If completion is nil, figure out what prefix of the word would prefix
  49.     ;; something in the completion list... but only if the user is interested.
  50.     (if (and (null completion) vm-completion-auto-correct c-list)
  51.     (let ((i -1))
  52.       (while (null (setq completion
  53.                  (try-completion (substring word 0 i) c-list)))
  54.         (vm-decrement i))
  55.       (setq completion (substring word 0 i))))
  56.     ;; If completion is t, we had a perfect match already.
  57.     (if (eq completion t)
  58.     (cond ((and (cdr trimmed-c-list)
  59.             (not (eq last-command 'vm-minibuffer-complete-word)))
  60.            (and (not exiting)
  61.             (vm-minibuffer-completion-message
  62.              "[Complete, but not unique]")))
  63.           (vm-completion-auto-space
  64.            (goto-char end)
  65.            (insert " "))
  66.           (t
  67.            (and (not exiting)
  68.             (vm-minibuffer-completion-message "[Sole completion]"))))
  69.       ;; Compute the difference in length between the completion and the
  70.       ;; word.  A negative difference means no match and the magnitude
  71.       ;; indicates the number of chars that need to be shaved off the end
  72.       ;; before a match will occur.  A positive difference means a match
  73.       ;; occurred and the magnitude specifies the number of new chars that
  74.       ;; can be appended to the word as a completion.
  75.       ;;
  76.       ;; `completion' can be nil here, but the code works anyway because
  77.       ;; (length nil) still equals 0!
  78.       (setq diff (- (length completion) (length word)))
  79.       (cond
  80.        ;; We have some completion chars.  Insert them.
  81.        ((> diff 0)
  82.     (goto-char end)
  83.     (insert (substring completion (- diff)))
  84.     (if (and vm-completion-auto-space
  85.          (null (cdr trimmed-c-list)))
  86.         (insert " ")))
  87.        ;; The word prefixed more than one string, but we can't complete
  88.        ;; any further.  Either give help or say "Ambiguous".
  89.        ((zerop diff)
  90.     (and (not exiting)
  91.          (if (null completion-auto-help)
  92.          (vm-minibuffer-completion-message "[Ambiguous]")
  93.            (vm-minibuffer-show-completions (sort
  94.                         (mapcar 'car trimmed-c-list)
  95.                         'string-lessp)))))
  96.        ;; The word didn't prefix anything... if vm-completion-auto-correct is
  97.        ;; non-nil strip the offending characters and try again.
  98.        (vm-completion-auto-correct
  99.     (goto-char end)
  100.     (delete-char diff)
  101.     (vm-minibuffer-complete-word exiting))
  102.        ;; if we're not auto-correcting and we're doing
  103.        ;; multi-word, just let the user insert a space.
  104.        (vm-completion-auto-space
  105.     (insert " "))
  106.        ;; completion utterly failed, tell the user so.
  107.        (t
  108.     (and (not exiting)
  109.          (vm-minibuffer-completion-message "[No match]")))))))
  110.  
  111. (defun vm-minibuffer-complete-word-and-exit ()
  112.   (interactive)
  113.   (vm-minibuffer-complete-word t)
  114.   (exit-minibuffer))
  115.  
  116. (defun vm-minibuffer-completion-message (string &optional seconds)
  117.   "Briefly display STRING to the right of the current minibuffer input.
  118. Optional second arg SECONDS specifies how long to keep the message visible;
  119. the default is 2 seconds.
  120.  
  121. A keypress causes the immediate erasure of the STRING, and return of control
  122. to the calling program."
  123.   (let (omax (inhibit-quit t))
  124.     (save-excursion
  125.       (goto-char (point-max))
  126.       (setq omax (point))
  127.       (insert " " string))
  128.     (sit-for (or seconds 2))
  129.     (delete-region omax (point-max))))
  130.  
  131. (defun vm-minibuffer-replace-word (word)
  132.   (goto-char (point-max))
  133.   (skip-chars-backward "^ \t\n")
  134.   (delete-region (point) (point-max))
  135.   (insert word))
  136.  
  137. (defun vm-minibuffer-show-completions (list)
  138.   "Display LIST in a multi-column listing in the \" *Completions*\" buffer.
  139. LIST should be a list of strings."
  140.   (save-excursion
  141.     (set-buffer (get-buffer-create " *Completions*"))
  142.     (setq buffer-read-only nil)
  143.     (use-local-map (make-sparse-keymap))
  144.     ;; ignore vm-mutable-* here.  the user shouldn't mind
  145.     ;; because when they exit the minibuffer the windows will be
  146.     ;; set right again.
  147.     (display-buffer (current-buffer))
  148.     (erase-buffer)
  149.     (insert "Possible completions are:\n")
  150.     (setq buffer-read-only t)
  151.     (vm-show-list list 'vm-minibuffer-replace-word
  152.           (list (current-local-map) minibuffer-local-map))
  153.     (goto-char (point-min))))
  154.  
  155. (defun vm-show-list (list &optional function keymaps)
  156.   "Display LIST in a multi-column listing in the current buffer at point.
  157. The current buffer must be displayed in some window at the time
  158. this function is called.
  159.  
  160. LIST should be a list of strings.
  161.  
  162. Optional second argument FUNCTION will be called if the mouse is
  163. clicked on one of the strings in the current buffer.  The string
  164. clicked upon will be passed to FUNCTION as its sole argument.
  165.  
  166. Optional third argument KEYMAPS specifies a lists of keymaps
  167. where the FUNCTION should be bound to the mouse clicks.  By
  168. default the local keymap of the current buffer is used."
  169.   (or keymaps (setq keymaps (and (current-local-map)
  170.                  (list (current-local-map)))))
  171.   (save-excursion
  172.     (let ((buffer-read-only nil)
  173.       tab-stops longest rows columns list-length q i w start command
  174.       keymap)
  175.       (cond ((and function keymaps (vm-mouse-support-possible-p))
  176.          (setq command
  177.            (list 'lambda '(e) '(interactive "e")
  178.              (list 'let
  179.                    '((string (vm-mouse-get-mouse-track-string e)))
  180.                    (list 'and 'string (list function 'string)))))
  181.          (while keymaps
  182.            (setq keymap (car keymaps))
  183.            (cond ((vm-mouse-xemacs-mouse-p)
  184.               (define-key keymap 'button1 command)
  185.               (define-key keymap 'button2 command)
  186.               (define-key keymap 'button3 command))
  187.              ((vm-mouse-fsfemacs-mouse-p)
  188.               (define-key keymap [down-mouse-1] 'ignore)
  189.               (define-key keymap [drag-mouse-1] 'ignore)
  190.               (define-key keymap [mouse-1] command)
  191.               (define-key keymap [drag-mouse-2] 'ignore)
  192.               (define-key keymap [down-mouse-2] 'ignore)
  193.               (define-key keymap [mouse-2] command)
  194.               (define-key keymap [drag-mouse-3] 'ignore)
  195.               (define-key keymap [down-mouse-3] 'ignore)
  196.               (define-key keymap [mouse-3] command)))
  197.            (setq keymaps (cdr keymaps)))))
  198.       (setq w (vm-get-buffer-window (current-buffer)))
  199.       (setq q list
  200.         list-length 0
  201.         longest 0)
  202.       (while q
  203.     (setq longest (max longest (length (car q)))
  204.           list-length (1+ list-length)
  205.           q (cdr q)))
  206.       ;; provide for separation between columns
  207.       (setq longest (+ 3 longest))
  208.       (setq columns (max 1 (/ (- (window-width w) 2) longest))
  209.         rows (/ list-length columns)
  210.         rows
  211.         (+ (if (zerop (% list-length columns)) 0 1)
  212.            rows))
  213.       (setq i columns
  214.         tab-stops nil)
  215.       (while (not (zerop i))
  216.     (setq tab-stops (cons (* longest i) tab-stops)
  217.           i (1- i)))
  218.       (setq q list
  219.         i 0)
  220.       (while q
  221.     (setq start (point))
  222.     (insert (car q))
  223.     (and function (vm-mouse-set-mouse-track-highlight start (point)))
  224.     (setq i (1+ i)
  225.           q (cdr q))
  226.     (if (zerop (% i columns))
  227.         (insert "\n")
  228.       (let ((tab-stop-list tab-stops))
  229.         (tab-to-tab-stop)))))))
  230.  
  231. (defun vm-minibuffer-completion-help ()
  232.   (interactive)
  233.   (let ((opoint (point))
  234.     c-list beg end word word-prefix-regexp)
  235.     ;; find the beginning and end of the word we're trying to complete
  236.     (if (or (eobp) (memq (following-char) '(?\t ?\n ?\ )))
  237.     (progn
  238.       (skip-chars-backward " \t\n")   
  239.       (and (not (eobp)) (forward-char))
  240.       (setq end (point)))
  241.       (skip-chars-forward "^ \t\n")
  242.       (setq end (point)))
  243.     (skip-chars-backward "^ \t\n")
  244.     (setq beg (point))
  245.     (goto-char opoint)
  246.     ;; copy the word into a string
  247.     (setq word (buffer-substring beg end))
  248.     ;; trim the completion list down to just likely candidates
  249.     ;; then convert it to an alist.
  250.     (setq word-prefix-regexp (concat "^" (regexp-quote word))
  251.       c-list (vm-delete-non-matching-strings
  252.           word-prefix-regexp
  253.           vm-minibuffer-completion-table)
  254.       c-list (sort c-list (function string-lessp)))
  255.     (if c-list
  256.     (vm-minibuffer-show-completions c-list)
  257.       (vm-minibuffer-completion-message " [No match]"))))
  258.  
  259. (defun vm-keyboard-read-string (prompt completion-list &optional multi-word)
  260.   (let ((minibuffer-local-map (copy-keymap minibuffer-local-map))
  261.     (vm-completion-auto-space multi-word)
  262.     (vm-minibuffer-completion-table completion-list))
  263.     (define-key minibuffer-local-map "\t" 'vm-minibuffer-complete-word)
  264.     (define-key minibuffer-local-map " " 'vm-minibuffer-complete-word)
  265.     (define-key minibuffer-local-map "?" 'vm-minibuffer-completion-help)
  266.     (if (not multi-word)
  267.     (define-key minibuffer-local-map "\r"
  268.       'vm-minibuffer-complete-word-and-exit))
  269.     (read-string prompt)))
  270.  
  271. (defvar last-nonmenu-event)
  272.  
  273. (defun vm-read-string (prompt completion-list &optional multi-word)
  274.   ;; handle alist
  275.   (if (consp (car completion-list))
  276.       (setq completion-list (nreverse (mapcar 'car completion-list))))
  277.   (if (and completion-list (vm-mouse-support-possible-p))
  278.       (cond ((and (vm-mouse-xemacs-mouse-p)
  279.           (or (button-press-event-p last-command-event)
  280.               (button-release-event-p last-command-event)
  281.               (menu-event-p last-command-event)))
  282.          (vm-mouse-read-string prompt completion-list multi-word))
  283.         ((and (vm-mouse-fsfemacs-mouse-p)
  284.           (listp last-nonmenu-event))
  285.          (vm-mouse-read-string prompt completion-list multi-word))
  286.         (t
  287.          (vm-keyboard-read-string prompt completion-list multi-word)))
  288.     (vm-keyboard-read-string prompt completion-list multi-word)))
  289.  
  290. (defun vm-read-number (prompt)
  291.   (let (result)
  292.     (while
  293.     (null
  294.      (string-match "^[ \t]*-?[0-9]+" (setq result (read-string prompt)))))
  295.     (string-to-int result)))
  296.  
  297. (defun vm-read-password (prompt &optional confirm)
  298.   "Read and return a password from the minibuffer, prompting with PROMPT.
  299. Optional second argument CONFIRM non-nil means that the user will be asked
  300.   to type the password a second time for confirmation and if there is a
  301.   mismatch, the process is repeated.
  302.  
  303. Line editing keys are:
  304.   C-h, DEL    rubout
  305.   C-u, C-x      line kill
  306.   C-q, C-v      literal next"
  307.   (catch 'return-value
  308.     (save-excursion
  309.       (let ((cursor-in-echo-area t)
  310.         (echo-keystrokes 0)
  311.         (input-buffer nil)
  312.         (help-form nil)
  313.         (xxx "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")
  314.         (string nil)
  315.         char done form)
  316.     (unwind-protect
  317.         (save-excursion
  318.           (setq input-buffer (get-buffer-create " *password*"))
  319.           (set-buffer input-buffer)
  320.           (while t
  321.         (erase-buffer)
  322.         (vm-unsaved-message "%s%s" prompt
  323.                     (vm-truncate-string xxx (buffer-size)))
  324.         (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j)))
  325.           (if (setq form
  326.                 (cdr
  327.                  (assq char
  328.                    '((?\C-h . (delete-char -1))
  329.                      (?\C-? . (delete-char -1))
  330.                      (?\C-u . (delete-region 1 (point)))
  331.                      (?\C-x . (delete-region 1 (point)))
  332.                      (?\C-q . (quoted-insert 1))
  333.                      (?\C-v . (quoted-insert 1))))))
  334.               (condition-case error-data
  335.               (eval form)
  336.             (error t))
  337.             (insert char))
  338.           (vm-unsaved-message "%s%s" prompt
  339.                       (vm-truncate-string xxx (buffer-size))))
  340.         (cond ((and confirm string)
  341.                (cond ((not (string= string (buffer-string)))
  342.                   (vm-unsaved-message
  343.                    (concat prompt
  344.                        (vm-truncate-string xxx (buffer-size))
  345.                        " [Mismatch... try again.]"))
  346.                   (ding)
  347.                   (sit-for 2)
  348.                   (setq string nil))
  349.                  (t (throw 'return-value string))))
  350.               (confirm
  351.                (setq string (buffer-string))
  352.                (vm-unsaved-message
  353.             (concat prompt
  354.                 (vm-truncate-string xxx (buffer-size))
  355.                 " [Retype to confirm...]"))
  356.                (sit-for 2))
  357.               (t
  358.                (vm-unsaved-message "")
  359.                (throw 'return-value (buffer-string))))))
  360.       (and input-buffer (kill-buffer input-buffer)))))))
  361.  
  362. (defun vm-keyboard-read-file-name (prompt &optional dir default
  363.                       must-match initial history)
  364.   "Like read-file-name, except HISTORY's value is unaltered."
  365.   (let ((oldvalue (symbol-value history)))
  366.     (unwind-protect
  367.     (condition-case nil
  368.         (read-file-name prompt dir default must-match initial history)
  369.       (wrong-number-of-arguments
  370.        (if history
  371.            (let ((file-name-history (symbol-value history))
  372.              file)
  373.          (setq file
  374.                (read-file-name prompt dir default must-match initial))
  375.          file )
  376.          (read-file-name prompt dir default must-match initial))))
  377.       (and history (set history oldvalue)))))
  378.  
  379. (defun vm-read-file-name (prompt &optional dir default
  380.                  must-match initial history)
  381.   "Like read-file-name, except a mouse interface is used if a mouse
  382. click mouse triggered the current command."
  383.   (if (vm-mouse-support-possible-p)
  384.       (cond ((and (vm-mouse-xemacs-mouse-p)
  385.           (or (button-press-event-p last-command-event)
  386.               (button-release-event-p last-command-event)
  387.               (menu-event-p last-command-event)))
  388.          (vm-mouse-read-file-name prompt dir default
  389.                       must-match initial history))
  390.         ((and (vm-mouse-fsfemacs-mouse-p)
  391.           (listp last-nonmenu-event))
  392.          (vm-mouse-read-file-name prompt dir default
  393.                       must-match initial history))
  394.         (t
  395.          (vm-keyboard-read-file-name prompt dir default
  396.                      must-match initial history)))
  397.     (vm-keyboard-read-file-name prompt dir default
  398.                 must-match initial history)))
  399.  
  400.  
  401.