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 / minibuf.el < prev    next >
Encoding:
Text File  |  1993-02-17  |  55.6 KB  |  1,334 lines

  1. ;;; minibuf.el
  2. ;; Copyright (C) 1992-1993 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. ;; Written by Richard Mlynarik 2-Oct-92
  21.  
  22. (defvar insert-default-directory t
  23.  "*Non-nil means when reading a filename start with default dir in minibuffer."
  24.  )
  25.  
  26. (defvar minibuffer-completion-table nil
  27.   "Alist or obarray used for completion in the minibuffer.
  28. This becomes the ALIST argument to `try-completion' and `all-completions'.
  29.  
  30. The value may alternatively be a function, which is given three arguments:
  31.   STRING, the current buffer contents;
  32.   PREDICATE, the predicate for filtering possible matches;
  33.   CODE, which says what kind of things to do.
  34. CODE can be nil, t or `lambda'.
  35. nil means to return the best completion of STRING, nil if there is none,
  36.   or t if it is was already a unique completion.
  37. t means to return a list of all possible completions of STRING.
  38. `lambda' means to return t if STRING is a valid completion as it stands.")
  39.  
  40. (defvar minibuffer-completion-predicate nil
  41.   "Within call to `completing-read', this holds the PREDICATE argument.")
  42.  
  43. (defvar minibuffer-completion-confirm nil
  44.   "Non-nil => demand confirmation of completion before exiting minibuffer.")
  45.  
  46. (defvar minibuffer-confirm-incomplete nil
  47.   "If true, then in contexts where completing-read allows answers which
  48. are not valid completions, an extra RET must be typed to confirm the
  49. response.  This is helpful for catching typos, etc.")
  50.  
  51. (defvar completion-auto-help t
  52.   "*Non-nil means automatically provide help for invalid completion input.")
  53.  
  54. (defvar enable-recursive-minibuffers nil
  55.   "*Non-nil means to allow minibuffer commands while in the minibuffer.
  56. More precisely, this variable makes a difference when the minibuffer window
  57. is the selected window.  If you are in some other window, minibuffer commands
  58. are allowed even if a minibuffer is active.")
  59.  
  60.  
  61. (defvar minibuffer-help-form nil
  62.   "Value that `help-form' takes on inside the minibuffer.")
  63.  
  64. (defvar minibuffer-local-map
  65.   (let ((map (make-sparse-keymap)))
  66.     (set-keymap-name map 'minibuffer-local-map)
  67.     map)
  68.   "Default keymap to use when reading from the minibuffer.")
  69.  
  70. (defvar minibuffer-local-completion-map
  71.   (let ((map (make-sparse-keymap)))
  72.     (set-keymap-name map 'minibuffer-local-completion-map)
  73.     (set-keymap-parent map minibuffer-local-map)
  74.     map)
  75.   "Local keymap for minibuffer input with completion.")
  76.  
  77. (defvar minibuffer-local-must-match-map
  78.   (let ((map (make-sparse-keymap)))
  79.     (set-keymap-name map 'minibuffer-must-match-map)
  80.     (set-keymap-parent map minibuffer-local-completion-map)
  81.     map)
  82.   "Local keymap for minibuffer input with completion, for exact match.")
  83.  
  84. (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit)
  85. (define-key minibuffer-local-map "\r" 'exit-minibuffer)
  86. (define-key minibuffer-local-map "\n" 'exit-minibuffer)
  87.  
  88. ;; Historical crock.  Unused by anything but user code, if even that
  89. ;(defvar minibuffer-local-ns-map
  90. ;  (let ((map (make-sparse-keymap)))
  91. ;    (set-keymap-name map 'minibuffer-local-ns-map)
  92. ;    (set-keymap-parent map minibuffer-local-map)
  93. ;    map)
  94. ;  "Local keymap for the minibuffer when spaces are not allowed.")
  95. ;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer)
  96. ;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer)
  97. ;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit)
  98.  
  99. (define-key minibuffer-local-completion-map "\t" 'minibuffer-complete)
  100. (define-key minibuffer-local-completion-map " " 'minibuffer-complete-word)
  101. (define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help)
  102. (define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit)
  103. (define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit)
  104.  
  105. (define-key minibuffer-local-map "\M-n" 'next-history-element)
  106. (define-key minibuffer-local-map "\M-p" 'previous-history-element)
  107. (define-key minibuffer-local-map [next] 'next-history-element)
  108. (define-key minibuffer-local-map [prior] 'previous-history-element)
  109. (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
  110. (define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
  111.  
  112. (defvar read-expression-map (let ((map (make-sparse-keymap)))
  113.                               (set-keymap-parent map minibuffer-local-map)
  114.                   (set-keymap-name map 'read-expression-map)
  115.                               map)
  116.   "Minibuffer keymap used for reading Lisp expressions.")
  117.  
  118. (define-key read-expression-map "\M-\t" 'lisp-complete-symbol)
  119.  
  120. (defvar read-shell-command-map
  121.   (let ((map (make-sparse-keymap)))
  122.     (set-keymap-parent map minibuffer-local-map)
  123.     (set-keymap-name map 'read-shell-command-map)
  124.     (define-key map "\t" 'comint-dynamic-complete)
  125.     (define-key map "\M-\t" 'comint-dynamic-complete)
  126.     (define-key map "\M-?" 'comint-dynamic-list-completions)
  127.     map)
  128.   "Minibuffer keymap used by shell-command and related commands.")
  129.  
  130. ;;;; Guts of minibuffer invocation
  131.  
  132. ;;>>> The only things remaining in C are
  133. ;; "Vminibuf_prompt" and the display junk
  134. ;;  "minibuf_prompt_width" and "minibuf_prompt_pix_width"
  135. ;; Also "active_screen", though I suspect I could already
  136. ;;   hack that in Lisp if I could make any sense of the
  137. ;;   complete mess of screen/frame code in Emacs.
  138. ;; Vminibuf_prompt could easily be made Lisp-bindable.
  139. ;;  I suspect that minibuf_prompt*_width are actually recomputed
  140. ;;  by redisplay as needed -- or could be arranged to be so --
  141. ;;  and that there could be need for read-minibuffer-internal to
  142. ;;  save and restore them.
  143. ;;>>> The only other thing which read-from-minibuffer-internal does
  144. ;;  which we can't presently do in Lisp is move the screen cursor
  145. ;;  to the start of the minibuffer line as it returns.  This is
  146. ;;  a rather nice touch and should be preserved -- probably by
  147. ;;  providing some Lisp-level mechanism (extension to cursor-in-echo-area ?)
  148. ;;  to effect it.
  149.  
  150.  
  151. ;; Like reset_buffer in buffer.c
  152. ;;  (Except that kill-all-local-variables doesn't nuke 'permanent-local
  153. ;;   variables -- we preserve them, reset_buffer doesn't.)
  154. (defun reset-buffer (buffer)
  155.   (save-excursion
  156.     (set-buffer buffer)
  157.     ;(if (fboundp 'unlock-buffer) (unlock-buffer))
  158.     (kill-all-local-variables)
  159.     (setq buffer-read-only nil)
  160.     (erase-buffer)
  161.     ;(setq default-directory nil)
  162.     (setq buffer-file-name nil)
  163.     (setq buffer-file-truename nil)
  164.     (set-buffer-modified-p nil)
  165.     (setq buffer-backed-up nil)
  166.     (setq buffer-auto-save-file-name nil)
  167.     (set-buffer-dedicated-screen buffer nil)
  168.     buffer))
  169.  
  170. (defun read-from-minibuffer (prompt &optional initial-contents
  171.                                     keymap
  172.                                     readp
  173.                                     history)
  174.   "Read a string from the minibuffer, prompting with string PROMPT.
  175. If optional second arg INITIAL-CONTENTS is non-nil, it is a string
  176.   to be inserted into the minibuffer before reading input.
  177.   If INITIAL-CONTENTS is (STRING . POSITION), the initial input
  178.   is STRING, but point is placed POSITION characters into the string.
  179. Third arg KEYMAP is a keymap to use whilst reading;
  180.   if omitted or nil, the default is `minibuffer-local-map'.
  181. If fourth arg READ is non-nil, then interpret the result as a lisp object
  182.   and return that object:
  183.   in other words, do `(car (read-from-string INPUT-STRING))'
  184. Fifth arg HISTORY, if non-nil, specifies a history list
  185.   and optionally the initial position in the list.
  186.   It can be a symbol, which is the history list variable to use,
  187.   or it can be a cons cell (HISTVAR . HISTPOS).
  188.   In that case, HISTVAR is the history list variable to use,
  189.   and HISTPOS is the initial position (the position in the list
  190.   which INITIAL-CONTENTS corresponds to).
  191.   If HISTORY is `t', no history will be recorded.
  192.   Positions are counted starting from 1 at the beginning of the list."
  193.   (if (and (not enable-recursive-minibuffers)
  194.            (> (minibuffer-depth) 0)
  195.            (eq (selected-window) (minibuffer-window)))
  196.       (error "Command attempted to use minibuffer while in minibuffer"))
  197.  
  198.   ;; catch this error before the poor user has typed something...
  199.   (if history
  200.       (if (symbolp history)
  201.       (or (boundp history)
  202.           (error "History list %S is unbound" history))
  203.     (or (boundp (car history))
  204.         (error "History list %S is unbound" (car history)))))
  205.  
  206.   (if (noninteractive)
  207.       (progn
  208.         ;; Emacs in -batch mode calls minibuffer: print the prompt.
  209.         (message "%s" prompt)
  210.         ;;>>> force-output
  211.  
  212.         ;;>>> Should this even be falling though to the code below?
  213.         ;;>>>  How does this stuff work now, anyway?
  214.         ))
  215.   (let* ((dir default-directory)
  216.          (owindow (selected-window))
  217.          (window (minibuffer-window))
  218.          (buffer (if (eq (minibuffer-depth) 0)
  219.                      (window-buffer window)
  220.                      (get-buffer-create (format " *Minibuf-%d"
  221.                                                 (minibuffer-depth))))))
  222.     (save-window-excursion
  223.       (set-buffer buffer)
  224.       (reset-buffer buffer)
  225.       (setq default-directory dir)
  226.       (make-local-variable 'print-escape-newlines)
  227.       (setq print-escape-newlines t)
  228.       (make-local-variable 'mode-motion-hook)
  229.       (setq mode-motion-hook 'minibuf-mouse-tracker) ;>>>disgusting
  230.       (set-window-buffer window buffer)
  231.       (select-window window)
  232.       (set-window-hscroll window 0)
  233.       (erase-buffer)
  234.       (buffer-enable-undo buffer)
  235.       (message nil)
  236.       (if initial-contents
  237.           (if (consp initial-contents)
  238.               (progn
  239.                 (insert (car initial-contents))
  240.                 (goto-char (cdr initial-contents)))
  241.               (insert initial-contents)))
  242.       (use-local-map (or keymap minibuffer-local-map))
  243.       (let ((mouse-grabbed-buffer (current-buffer))
  244.             (current-prefix-arg current-prefix-arg)
  245.             (help-form minibuffer-help-form)
  246.             (minibuffer-history-variable (cond ((not history)
  247.                                                 'minibuffer-history)
  248.                                                ((consp history)
  249.                                                 (car history))
  250.                                                (t
  251.                                                 history)))
  252.             (minibuffer-history-position (cond ((consp history)
  253.                                                 (cdr history))
  254.                                                (t
  255.                                                 0)))
  256.             (minibuffer-scroll-window owindow))
  257.         (unwind-protect
  258.              (if (eq 't
  259.                      (catch 'exit
  260.                        (if (> (recursion-depth) (minibuffer-depth))
  261.                            (let ((standard-output t)
  262.                                  (standard-input t))
  263.                              (read-minibuffer-internal prompt))
  264.                            (read-minibuffer-internal prompt))))
  265.                  ;; Translate an "abort" (throw 'exit 't)
  266.                  ;;  into a real quit
  267.                  (signal 'quit '())
  268.                  ;; return value
  269.                  (let ((val (progn (set-buffer buffer) (buffer-string)))
  270.                (list (symbol-value minibuffer-history-variable)))
  271.                    ;; Add the value to the appropriate history list unless
  272.            ;; it's already the most recent element, or it's only
  273.            ;; two characters long.
  274.            (or (eq list t)
  275.                (null val)
  276.                (equal val (car list))
  277.                (and (stringp val) (< (length val) 3))
  278.                (set minibuffer-history-variable (cons val list)))
  279.                    (if readp
  280.                        (car (read-from-string val))
  281.                        val)))
  282.           ;; stupid display code requires this for some reason
  283.           (set-buffer buffer)
  284.           (buffer-disable-undo buffer)
  285.           (setq buffer-read-only nil)
  286.           (erase-buffer))))))
  287.  
  288.  
  289. ;;;; Guts of minibuffer completion
  290.  
  291.  
  292. ;; Used by minibuffer-do-completion
  293. (defvar last-exact-completion)
  294.  
  295. (defun temp-minibuffer-message (m)
  296.   (let ((savemax (point-max)))
  297.     (save-excursion
  298.       (goto-char (point-max))
  299.       (message nil)
  300.       (insert m))
  301.     (let ((inhibit-quit t))
  302.       (sit-for 2)
  303.       (delete-region savemax (point-max))
  304.       ;;  If the user types a ^G while we're in sit-for, then quit-flag 
  305.       ;;  gets set. In this case, we want that ^G to be interpreted 
  306.       ;;  as a normal character, and act just like typeahead.
  307.       (if (and quit-flag (not unread-command-event))
  308.           (setq unread-command-event (character-to-event interrupt-char)
  309.                 quit-flag nil)))))
  310.  
  311.  
  312. ;; Determines whether buffer-string is an exact completion
  313. (defun exact-minibuffer-completion-p (buffer-string)
  314.   (cond ((not minibuffer-completion-table)
  315.          ;; Empty alist
  316.          nil)
  317.         ((vectorp minibuffer-completion-table)
  318.          (let ((tem (intern-soft buffer-string
  319.                                  minibuffer-completion-table)))
  320.            (if (or tem
  321.                    (and (string-equal buffer-string "nil")
  322.                         ;; intern-soft loses for 'nil
  323.                         (catch 'found
  324.                           (mapatoms
  325.                            (function (lambda (s)
  326.                              (if (string-equal
  327.                                   (symbol-name s)
  328.                                   buffer-string)
  329.                                  (throw 'found t))))
  330.                            minibuffer-completion-table)
  331.                           nil)))
  332.                (if minibuffer-completion-predicate
  333.                    (funcall minibuffer-completion-predicate
  334.                             tem)
  335.                    t)
  336.                nil)))
  337.         ((and (consp minibuffer-completion-table)
  338.               ;;>>> Emacs-Lisp truly sucks!
  339.               ;; lambda, autoload, etc
  340.               (not (symbolp (car minibuffer-completion-table))))
  341.          (if (not completion-ignore-case)
  342.              (assoc buffer-string minibuffer-completion-table)
  343.              (let ((s (upcase buffer-string))
  344.                    (tail minibuffer-completion-table)
  345.                    tem)
  346.                (while tail
  347.                  (setq tem (car (car tail)))
  348.                  (if (or (equal tem buffer-string)
  349.                          (equal tem s)
  350.                          (equal (upcase tem) s))
  351.                      (setq s 'win
  352.                            tail nil)    ;exit
  353.                      (setq tail (cdr tail))))
  354.                (eq s 'win))))
  355.         (t
  356.          (funcall minibuffer-completion-table
  357.                   buffer-string
  358.                   minibuffer-completion-predicate
  359.                   'lambda)))
  360.   )
  361.  
  362. ;; 0 'none                 no possible completion
  363. ;; 1 'unique               was already an exact and unique completion
  364. ;; 3 'exact                was already an exact (but nonunique) completion
  365. ;; NOT USED 'completed-exact-unique completed to an exact and completion 
  366. ;; 4 'completed-exact      completed to an exact (but nonunique) completion
  367. ;; 5 'completed            some completion happened
  368. ;; 6 'uncompleted          no completion happened
  369. (defun minibuffer-do-completion-1 (buffer-string completion)
  370.   (cond ((not completion)
  371.          'none)
  372.         ((eq completion t)
  373.          ;; exact and unique match
  374.          'unique)
  375.         (t
  376.          ;; It did find a match.  Do we match some possibility exactly now?
  377.          (let ((completedp (not (string-equal completion buffer-string))))
  378.            (if completedp
  379.                (progn
  380.                  ;; Some completion happened
  381.                  (erase-buffer)
  382.                  (insert completion)
  383.                  (setq buffer-string completion)))
  384.            (if (exact-minibuffer-completion-p buffer-string)
  385.                ;; An exact completion was possible
  386.                (if completedp
  387. ;; Since no callers need to know the difference, don't bother
  388. ;;  with this (potentially expensive) discrimination.
  389. ;;                 (if (eq (try-completion completion
  390. ;;                                         minibuffer-completion-table
  391. ;;                                         minibuffer-completion-predicate)
  392. ;;                         't)
  393. ;;                     'completed-exact-unique
  394.                        'completed-exact
  395. ;;                     )
  396.                    'exact)
  397.                ;; Not an exact match
  398.                (if completedp
  399.                    'completed
  400.                    'uncompleted))))))
  401.  
  402.  
  403. (defun minibuffer-do-completion (buffer-string)
  404.   (let* ((completion (try-completion buffer-string
  405.                                      minibuffer-completion-table
  406.                                      minibuffer-completion-predicate))
  407.          (status (minibuffer-do-completion-1 buffer-string completion))
  408.          (last last-exact-completion))
  409.     (setq last-exact-completion nil)
  410.     (cond ((eq status 'none)
  411.            ;; No completions
  412.            (ding nil 'no-completion)
  413.            (temp-minibuffer-message " [No match]"))
  414.           ((eq status 'unique)
  415.            )
  416.           (t
  417.            ;; It did find a match.  Do we match some possibility exactly now?
  418.            (if (not (string-equal completion buffer-string))
  419.                (progn
  420.                  ;; Some completion happened
  421.                  (erase-buffer)
  422.                  (insert completion)
  423.                  (setq buffer-string completion)))
  424.            (cond ((eq status 'exact)
  425.                   ;; If the last exact completion and this one were
  426.                   ;;  the same, it means we've already given a
  427.                   ;;  "Complete but not unique" message and that the
  428.                   ;;  user's hit TAB again, so now we give help.
  429.                   (setq last-exact-completion completion)
  430.                   (if (equal buffer-string last)
  431.                       (minibuffer-completion-help)))
  432.                  ((eq status 'uncompleted)
  433.                   (if completion-auto-help
  434.                       (minibuffer-completion-help)
  435.                       (temp-minibuffer-message " [Next char not unique]")))
  436.                  (t
  437.                   nil))))
  438.     status))
  439.  
  440.  
  441. ;;;; completing-read
  442.  
  443. (defun completing-read (prompt table
  444.                         &optional predicate require-match
  445.                                   initial-contents history)
  446.   "Read a string in the minibuffer, with completion.
  447. Args: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-CONTENTS, HISTORY.
  448. PROMPT is a string to prompt with; normally it ends in a colon and a space.
  449. TABLE is an alist whose elements' cars are strings, or an obarray.
  450. PREDICATE limits completion to a subset of TABLE.
  451. See `try-completion' for more details on completion, TABLE, and PREDICATE.
  452. If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
  453.  the input is (or completes to) an element of TABLE.
  454.  If it is also not t, Return does not exit if it does non-null completion.
  455. If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially.
  456.   If it is (STRING . POSITION), the initial input
  457.   is STRING, but point is placed POSITION characters into the string.
  458. HISTORY, if non-nil, specifies a history list
  459.   and optionally the initial position in the list.
  460.   It can be a symbol, which is the history list variable to use,
  461.   or it can be a cons cell (HISTVAR . HISTPOS).
  462.   In that case, HISTVAR is the history list variable to use,
  463.   and HISTPOS is the initial position (the position in the list
  464.   which INITIAL-CONTENTS corresponds to).
  465.   If HISTORY is `t', no history will be recorded.
  466.   Positions are counted starting from 1 at the beginning of the list.
  467. Completion ignores case if the ambient value of
  468.   `completion-ignore-case' is non-nil."
  469.   (let ((minibuffer-completion-table table)
  470.         (minibuffer-completion-predicate predicate)
  471.         (minibuffer-completion-confirm (if (eq require-match 't) nil t))
  472.         (last-exact-completion nil))
  473.     (read-from-minibuffer prompt
  474.                           initial-contents
  475.                           (if (not require-match)
  476.                               minibuffer-local-completion-map
  477.                               minibuffer-local-must-match-map)
  478.                           nil
  479.                           history)))
  480.  
  481.  
  482. ;;;; Minibuffer completion commands
  483.  
  484.  
  485. (defun minibuffer-complete ()
  486.   "Complete the minibuffer contents as far as possible."
  487.   (interactive)
  488.   (let ((status (minibuffer-do-completion (buffer-string))))
  489.     (if (eq status 'none)
  490.         nil
  491.       (progn
  492.         (cond ((eq status 'unique)
  493.                (temp-minibuffer-message " [Sole completion]"))
  494.               ((eq status 'exact)
  495.                (temp-minibuffer-message " [Complete, but not unique]")))
  496.         t))))
  497.  
  498.  
  499. (defun minibuffer-complete-and-exit ()
  500.   "Complete the minibuffer contents, and maybe exit.
  501. Exit if the name is valid with no completion needed.
  502. If name was completed to a valid match,
  503. a repetition of this command will exit."
  504.   (interactive)
  505.   (if (= (point-min) (point-max))
  506.       ;; Crockishly allow user to specify null string
  507.       (throw 'exit nil))
  508.   (let ((buffer-string (buffer-string)))
  509.     ;; Short-cut -- don't call minibuffer-do-completion if we already
  510.     ;;  have an (possibly nonunique) exact completion.
  511.     (if (exact-minibuffer-completion-p buffer-string)
  512.         (throw 'exit nil))
  513.     (let ((status (minibuffer-do-completion buffer-string)))
  514.       (if (or (eq status 'unique)
  515.               (eq status 'exact)
  516.               (if (or (eq status 'completed-exact)
  517.                       (eq status 'completed-exact-unique))
  518.                   (if minibuffer-completion-confirm
  519.                       (progn (temp-minibuffer-message " [Confirm]")
  520.                              nil)
  521.                       t)))
  522.           (throw 'exit nil)))))
  523.  
  524.  
  525. (defun self-insert-and-exit ()
  526.   "Terminate minibuffer input."
  527.   (interactive)
  528.   (self-insert-command)
  529.   (throw 'exit nil))
  530.  
  531. (defun exit-minibuffer ()
  532.   "Terminate this minibuffer argument.
  533. If minibuffer-confirm-incomplete is true, and we are in a completing-read
  534. of some kind, and the contents of the minibuffer is not an existing
  535. completion, requires an additional RET before the minibuffer will be exited
  536. \(assuming that RET was the character that invoked this command:
  537. the character in question must be typed again)."
  538.   (interactive)
  539.   (if (not minibuffer-confirm-incomplete)
  540.       (throw 'exit nil))
  541.   (let ((buffer-string (buffer-string)))
  542.     (if (exact-minibuffer-completion-p buffer-string)
  543.         (throw 'exit nil))
  544.     (let ((completion (if (not minibuffer-completion-table)
  545.                           t
  546.                           (try-completion buffer-string
  547.                                           minibuffer-completion-table
  548.                                           minibuffer-completion-predicate))))
  549.       (if (or (eq completion 't)
  550.               ;; Crockishly allow user to specify null string
  551.               (string-equal buffer-string ""))
  552.           (throw 'exit nil))
  553.       (temp-minibuffer-message (if completion
  554.                                    " [incomplete; confirm]"
  555.                                    " [no completions; confirm]"))
  556.       (let ((event (allocate-event)))
  557.         (let ((inhibit-quit t))
  558.           (next-command-event event)
  559.           (setq quit-flag nil))
  560.         (cond ((equal event last-command-event)
  561.                (throw 'exit nil))
  562.               ((equal interrupt-char (event-to-character event nil))
  563.                (deallocate-event event)
  564.                ;; Minibuffer abort.
  565.                (throw 'exit t)))
  566.         (dispatch-event event)
  567.         (deallocate-event event)))))
  568.  
  569. ;;;; minibuffer-complete-word
  570.  
  571.  
  572. ;;;>>> I think I have done this correctly; it certainly is simpler
  573. ;;;>>>  than what the C code seemed to be trying to do.
  574. (defun minibuffer-complete-word ()
  575.   "Complete the minibuffer contents at most a single word.
  576. After one word is completed as much as possible, a space or hyphen
  577. is added, provided that matches some possible completion."
  578.   (interactive)
  579.   (let* ((buffer-string (buffer-string))
  580.          (completion (try-completion buffer-string
  581.                                      minibuffer-completion-table
  582.                                      minibuffer-completion-predicate))
  583.          (status (minibuffer-do-completion-1 buffer-string completion)))
  584.     (cond ((eq status 'none)
  585.            (ding nil 'no-completion)
  586.            (temp-minibuffer-message " [No match]")
  587.            nil)
  588.           ((eq status 'unique)
  589.            ;; New message, only in this new Lisp code
  590.            (temp-minibuffer-message " [Sole completion]")
  591.            t)
  592.           (t
  593.            (cond ((or (eq status 'uncompleted)
  594.                       (eq status 'exact))
  595.                   (let ((foo (function (lambda (s)
  596.                                (condition-case nil
  597.                                    (if (try-completion
  598.                                         (concat buffer-string s)
  599.                                         minibuffer-completion-table
  600.                                         minibuffer-completion-predicate)
  601.                                        (progn
  602.                                          (goto-char (point-max))
  603.                                          (insert s)
  604.                                          t)
  605.                                        nil)
  606.                                    (error nil)))))
  607.                         (char last-command-char))
  608.                     ;; Try to complete by adding a word-delimiter
  609.                     (or (and (integerp char) (> char 0)
  610.                              (funcall foo (char-to-string char)))
  611.                         (and (not (eq char ?\ ))
  612.                              (funcall foo " "))
  613.                         (and (not (eq char ?\-))
  614.                              (funcall foo "-"))
  615.                         (progn
  616.                           (if completion-auto-help 
  617.                               (minibuffer-completion-help)
  618.                               ;; New message, only in this new Lisp code
  619.                               (temp-minibuffer-message
  620.                                (if (eq status 'exact)
  621.                                    " [Complete, but not unique]"
  622.                                    " [Ambiguous]")))
  623.                           nil))))
  624.                  (t
  625.                   (erase-buffer)
  626.                   (insert completion)
  627.                   ;; First word-break in stuff found by completion
  628.                   (goto-char (point-min))
  629.                   (let ((len (length buffer-string))
  630.                         n)
  631.                     (if (and (< len (length completion))
  632.                              (catch 'match
  633.                                (setq n 0)
  634.                                (while (< n len)
  635.                                  (if (char-equal
  636.                                        (upcase (aref buffer-string n))
  637.                                        (upcase (aref completion n)))
  638.                                      (setq n (1+ n))
  639.                                      (throw 'match nil)))
  640.                                t)
  641.                              (progn
  642.                                (goto-char (point-min))
  643.                                (forward-char len)
  644.                                (re-search-forward "\\W" nil t)))
  645.                         (delete-region (point) (point-max))
  646.                         (goto-char (point-max))))
  647.                   t))))))
  648.  
  649. ;;;; Completion help
  650.  
  651. (defun display-completion-list (completions)
  652.   "Display the list of completions, COMPLETIONS, using `standard-output'.
  653. Each element may be just a symbol or string
  654. or may be a list of two strings to be printed as if concatenated."
  655.   (let ((old-buffer (current-buffer))
  656.         (bufferp (bufferp standard-output)))
  657.     (if bufferp
  658.         (set-buffer standard-output))
  659.     (if (null completions)
  660.         (princ "There are no possible completions of what you have typed.")
  661.       (let ((win-width (if bufferp
  662.                            ;; This needs fixing for the case of windows 
  663.                            ;; that aren't the same width s the screen.
  664.                            ;; Sadly, the window it will appear in is not known
  665.                            ;; until after the text has been made.
  666.                            (screen-width (selected-screen))
  667.                            80)))
  668.         (let ((count 0)
  669.               (max-width 0))
  670.           ;; Find longest completion
  671.           (let ((tail completions))
  672.             (while tail
  673.               (let* ((elt (car tail))
  674.                      (len (cond ((stringp elt)
  675.                                  (length elt))
  676.                                 ((and (consp elt)
  677.                                       (stringp (car elt))
  678.                                       (stringp (car (cdr elt))))
  679.                                  (+ (length (car elt))
  680.                                     (length (car (cdr elt)))))
  681.                                 (t
  682.                                  (signal 'wrong-type-argument
  683.                                          (list 'stringp elt))))))
  684.                 (if (> len max-width)
  685.                     (setq max-width len))
  686.                 (setq count (1+ count)
  687.                       tail (cdr tail)))))
  688.         
  689.           (setq max-width (+ 2 max-width)) ; at least two chars between cols
  690.           (let ((rows (let ((cols (min (/ win-width max-width) count)))
  691.                         (if (<= cols 1)
  692.                             count
  693.                           (progn
  694.                             ;; re-space the columns
  695.                             (setq max-width (/ win-width cols))
  696.                             (if (/= (% count cols) 0) ; want ceiling...
  697.                                 (1+ (/ count cols))
  698.                                 (/ count cols)))))))
  699.             (princ "Possible completions are:")
  700.             (let ((tail completions)
  701.                   (r 0))
  702.               (while (< r rows)
  703.                 (terpri)
  704.                 (let ((indent 0)
  705.                       (column 0)
  706.                       (tail2 tail))
  707.                   (while tail2
  708.                     (let ((elt (car tail2)))
  709.                       (if (/= indent 0)
  710.                           (if bufferp
  711.                               (indent-to indent 1)
  712.                               (while (progn (write-char ?\ )
  713.                                             (setq column (1+ column))
  714.                                             (< column indent)))))
  715.                       (setq indent (+ indent max-width))
  716.                       (if (consp elt)
  717.                           (progn
  718.                             (princ (car elt))
  719.                             (princ (car (cdr elt)))
  720.                             (or bufferp
  721.                                 (setq column (+ column
  722.                                                 (length (car elt))
  723.                                                 (length (car (cdr elt)))))))
  724.                           (progn
  725.                             (princ elt)
  726.                             (or bufferp
  727.                                 (setq column (+ column (length elt)))))))
  728.                     (setq tail2 (nthcdr rows tail2)))
  729.                   (setq tail (cdr tail)
  730.                         r (1+ r)))))))))
  731.     (if bufferp
  732.         (set-buffer old-buffer))))
  733.  
  734. (defun minibuffer-completion-help ()
  735.   "Display a list of possible completions of the current minibuffer contents."
  736.   (interactive)
  737.   (message "Making completion list...")
  738.   (let ((completions (all-completions (buffer-string)
  739.                                       minibuffer-completion-table
  740.                                       minibuffer-completion-predicate)))
  741.     (message nil)
  742.     (if (null completions)
  743.         (progn
  744.           (ding nil 'no-completion)
  745.           (temp-minibuffer-message " [No completions]"))
  746.         (with-output-to-temp-buffer "*Completions*"
  747.           (display-completion-list (sort completions 
  748.                                          (function string-lessp)))))))
  749.  
  750. ;;;; Minibuffer History
  751.  
  752. (defvar minibuffer-history '()
  753.   "Default minibuffer history list.
  754. This is used for all minibuffer input except when an alternate history
  755. list is specified.")
  756.  
  757. ;; Some other history lists:
  758. ;;
  759. (defvar minibuffer-history-search-history '())
  760. (defvar minibuffer-sexp-history '())
  761. (defvar minibuffer-command-history '())
  762. (defvar minibuffer-function-history '())
  763. (defvar minibuffer-variable-history '())
  764. (defvar minibuffer-buffer-history '())
  765. (defvar minibuffer-shell-command-history '())
  766. (defvar minibuffer-file-name-history '())
  767.  
  768. (defvar minibuffer-history-sexp-flag nil ;weird RMS Emacs kludge
  769.   "Non-nil when doing history operations on `command-history'.
  770. More generally, indicates that the history list being acted on
  771. contains expressions rather than strings.")
  772.  
  773. (defvar minibuffer-history-variable 'minibuffer-history
  774.   "History list symbol to add minibuffer values to.
  775. Each minibuffer output is added with
  776.   (set minibuffer-history-variable
  777.        (cons STRING (symbol-value minibuffer-history-variable)))")
  778. (defvar minibuffer-history-position)
  779.  
  780. (defun previous-matching-history-element (regexp n)
  781.   "Find the previous history element that matches REGEXP.
  782. \(Previous history elements refer to earlier actions.)
  783. With prefix argument N, search for Nth previous match.
  784. If N is negative, find the next or Nth next match."
  785.   (interactive
  786.    (let ((enable-recursive-minibuffers t)
  787.      (minibuffer-history-sexp-flag nil))
  788.      (if (eq 't (symbol-value minibuffer-history-variable))
  789.      (error "history is not being recorded in this context"))
  790.      (list (read-from-minibuffer "Previous element matching (regexp): "
  791.                  nil
  792.                  minibuffer-local-map
  793.                  nil
  794.                  'minibuffer-history-search-history)
  795.        (prefix-numeric-value current-prefix-arg))))
  796.   (let ((history (symbol-value minibuffer-history-variable))
  797.     prevpos
  798.     (pos minibuffer-history-position))
  799.     (if (eq history t)
  800.     (error "history is not being recorded in this context"))
  801.     (while (/= n 0)
  802.       (setq prevpos pos)
  803.       (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
  804.       (if (= pos prevpos)
  805.       (error (if (= pos 1)
  806.              "No later matching history item"
  807.            "No earlier matching history item")))
  808.       (if (string-match regexp
  809.             (if minibuffer-history-sexp-flag
  810.                 (prin1-to-string (nth (1- pos) history))
  811.                             (nth (1- pos) history)))
  812.       (setq n (+ n (if (< n 0) 1 -1)))))
  813.     (setq minibuffer-history-position pos)
  814.     (erase-buffer)
  815.     (let ((elt (nth (1- pos) history)))
  816.       (insert (if minibuffer-history-sexp-flag
  817.           (prin1-to-string elt)
  818.                   elt)))
  819.       (goto-char (point-min)))
  820.   (if (or (eq (car (car command-history)) 'previous-matching-history-element)
  821.       (eq (car (car command-history)) 'next-matching-history-element))
  822.       (setq command-history (cdr command-history))))
  823.  
  824. (defun next-matching-history-element (regexp n)
  825.   "Find the next history element that matches REGEXP.
  826. \(The next history element refers to a more recent action.)
  827. With prefix argument N, search for Nth next match.
  828. If N is negative, find the previous or Nth previous match."
  829.   (interactive
  830.    (let ((enable-recursive-minibuffers t)
  831.      (minibuffer-history-sexp-flag nil))
  832.      (if (eq t (symbol-value minibuffer-history-variable))
  833.      (error "history is not being recorded in this context"))
  834.      (list (read-from-minibuffer "Next element matching (regexp): "
  835.                  nil
  836.                  minibuffer-local-map
  837.                  nil
  838.                  'minibuffer-history-search-history)
  839.        (prefix-numeric-value current-prefix-arg))))
  840.   (previous-matching-history-element regexp (- n)))
  841.  
  842. (defun next-history-element (n)
  843.   "Insert the next element of the minibuffer history into the minibuffer."
  844.   (interactive "p")
  845.   (if (eq 't (symbol-value minibuffer-history-variable))
  846.       (error "history is not being recorded in this context"))
  847.   (let ((narg (min (max 1 (- minibuffer-history-position n))
  848.            (length (symbol-value minibuffer-history-variable)))))
  849.     (if (= minibuffer-history-position narg)
  850.     (error (format "No %s item in %s"
  851.                (if (>= n 0) "following" "preceding")
  852.                minibuffer-history-variable))
  853.       (erase-buffer)
  854.       (setq minibuffer-history-position narg)
  855.       (let ((elt (nth (1- minibuffer-history-position)
  856.               (symbol-value minibuffer-history-variable))))
  857.     (insert
  858.      (if minibuffer-history-sexp-flag
  859.          (condition-case ()
  860.          (let ((print-readably t)) (prin1-to-string elt))
  861.            (error (prin1-to-string elt)))
  862.              elt)))
  863.       (goto-char (point-max)))))
  864.  
  865. (defun previous-history-element (n)
  866.   "Inserts the previous element of the minibuffer history into the minibuffer."
  867.   (interactive "p")
  868.   (next-history-element (- n)))
  869.  
  870.  
  871. ;;;; reading various things from a minibuffer
  872.  
  873. (defun read-minibuffer (prompt &optional initial-contents history)
  874.   "Return a Lisp object read using the minibuffer.
  875. Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
  876. is a string to insert in the minibuffer before reading.
  877. Third arg HISTORY, if non-nil, specifies a history list."
  878.   (read-from-minibuffer prompt
  879.                         initial-contents
  880.                         minibuffer-local-map
  881.                         t
  882.             (or history 'minibuffer-sexp-history)))
  883.  
  884. (defun read-string (prompt &optional initial-contents history)
  885.   "Return a string from the minibuffer, prompting with string PROMPT.
  886. If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
  887. in the minibuffer before reading.
  888. Third arg HISTORY, if non-nil, specifies a history list."
  889.   (read-from-minibuffer prompt
  890.                         initial-contents
  891.                         minibuffer-local-map
  892.                         nil history))
  893.  
  894. (defun eval-minibuffer (prompt &optional initial-contents history)
  895.   "Return value of Lisp expression read using the minibuffer.
  896. Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
  897. is a string to insert in the minibuffer before reading.
  898. Third arg HISTORY, if non-nil, specifies a history list."
  899.   (eval (read-minibuffer prompt initial-contents history)))
  900.  
  901. ;;;>> Screw this crock!!
  902. ;(defun read-no-blanks-input (prompt &optional initial-contents)
  903. ; "Read a string from the terminal, not allowing blanks.
  904. ;Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
  905. ;is a string to insert in the minibuffer before reading."
  906. ; (read-from-minibuffer prompt
  907. ;                       initial-contents
  908. ;                       minibuffer-local-ns-map
  909. ;                       nil))
  910.  
  911. (defun read-command (prompt)
  912.   "Read the name of a command and return as a symbol.
  913. Prompts with PROMPT."
  914.   (intern (completing-read prompt obarray 'commandp t nil
  915.                'minibuffer-command-history)))
  916.  
  917. (defun read-function (prompt)
  918.   "Read the name of a function and return as a symbol.
  919. Prompts with PROMPT."
  920.   (intern (completing-read prompt obarray 'fboundp t nil
  921.                'minibuffer-function-history)))
  922.  
  923. (defun read-variable (prompt)
  924.   "Read the name of a user variable and return it as a symbol.
  925. Prompts with PROMPT.
  926. A user variable is one whose documentation starts with a `*' character."
  927.   (intern (completing-read prompt obarray 'user-variable-p t nil
  928.                'minibuffer-variable-history)))
  929.  
  930. (defun read-buffer (prompt &optional default require-match)
  931.   "Read the name of a buffer and return as a string.
  932. Prompts with PROMPT.  Optional second arg DEFAULT is value to return if user
  933. enters an empty line.  If optional third arg REQUIRE-MATCH is non-nil,
  934. only existing buffer names are allowed."
  935.   (let ((prompt (if default 
  936.                     (format "%s(default %s) "
  937.                             prompt (if (bufferp default)
  938.                                        (buffer-name default)
  939.                                        default))
  940.                     prompt))
  941.         (alist (mapcar (function (lambda (b)
  942.                          (cons (buffer-name b) b)))
  943.                        (buffer-list)))
  944.         result)
  945.     (while (progn
  946.              (setq result (completing-read prompt alist nil require-match
  947.                        nil 'minibuffer-buffer-history))
  948.              (cond ((not (equal result ""))
  949.                     nil)
  950.                    ((not require-match)
  951.                     (setq result default)
  952.                     nil)
  953.                    ((not default)
  954.                     t)
  955.                    ((not (get-buffer default))
  956.                     t)
  957.                    (t
  958.                     (setq result default)
  959.                     nil))))
  960.     (if (bufferp result)
  961.         (buffer-name result)
  962.       result)))
  963.  
  964. (defun read-number (prompt &optional integers-only)
  965.   "Reads a number from the minibuffer."
  966.   (let ((pred (if integers-only 'integerp 'numberp))
  967.     num)
  968.     (while (not (funcall pred num))
  969.       (setq num (condition-case ()
  970.             (read-from-minibuffer
  971.              prompt (if num (prin1-to-string num)) nil t
  972.              t) ;no history
  973.           (invalid-read-syntax nil)
  974.           (end-of-file nil)))
  975.       (or (funcall pred num) (beep)))
  976.     num))
  977.  
  978. (defun read-shell-command (prompt &optional initial-input)
  979.   "Just like read-string, but uses read-shell-command-map:
  980. \\{read-shell-command-map}"
  981.   (read-from-minibuffer prompt initial-input read-shell-command-map
  982.             nil 'minibuffer-shell-command-history))
  983.  
  984.  
  985. ;;; This read-file-name stuff probably belongs in files.el
  986.  
  987. ;; Quote "$" as "$$" to get it past substitute-in-file-name
  988. (defun un-substitute-in-file-name (string)
  989.   (let ((regexp "\\$")
  990.         (olen (length string))
  991.         new
  992.         n o ch)
  993.     (cond ((eq system-type 'vax-vms)
  994.            string)
  995.           ((not (string-match regexp string))
  996.            string)
  997.           (t
  998.            (setq n 1)
  999.            (while (string-match regexp string (match-end 0))
  1000.              (setq n (1+ n)))
  1001.            (setq new (make-string (+ olen n) ?$))
  1002.            (setq n 0 o 0)
  1003.            (while (< o olen)
  1004.              (setq ch (aref string o))
  1005.              (aset new n ch)
  1006.              (setq o (1+ o) n (1+ n))
  1007.              (if (eq ch ?$)
  1008.                  ;; already aset by make-string initial-value
  1009.                  (setq n (1+ n))))
  1010.            new))))
  1011.   
  1012. (defun read-file-name-1 (history prompt dir default 
  1013.                          must-match initial-contents
  1014.                          completer)
  1015.   (if (not dir)
  1016.       (setq dir default-directory))
  1017.   (setq dir (abbreviate-file-name dir t))
  1018.   (let* ((insert (cond ((not insert-default-directory)
  1019.                         "")
  1020.                        (initial-contents
  1021.                         (cons (un-substitute-in-file-name
  1022.                                 (concat dir initial-contents))
  1023.                               (1+ (length dir))))
  1024.                        (t
  1025.                         (un-substitute-in-file-name dir))))
  1026.          (val (let ((completion-ignore-case (eq system-type 'vax-vms)))
  1027.                 ;;  Hateful, broken, case-sensitive un*x
  1028.                 (completing-read prompt
  1029.                                  completer
  1030.                                  dir
  1031.                                  must-match
  1032.                                  insert
  1033.                                  history))))
  1034.     ;; Kludge!  Put "/foo/bar" on history rather than "/default//foo/bar"
  1035.     (let ((hist (cond ((not history) 'minibuffer-history)
  1036.                       ((consp history) (car history))
  1037.                       (t history))))
  1038.       (if (and val
  1039.                hist
  1040.                (not (eq hist 't))
  1041.                (boundp hist)
  1042.                (equal (car-safe (symbol-value hist)) val))
  1043.           (let ((e (condition-case nil
  1044.                        (expand-file-name val)
  1045.                      (error nil))))
  1046.             (if (and e (not (equal e val)))
  1047.                 (set hist (cons e (cdr (symbol-value hist))))))))
  1048.  
  1049.     (cond ((not val)
  1050.            (error "No file name specified"))
  1051.           ((and default
  1052.                 (equal val (if (consp insert) (car insert) insert)))
  1053.            default)
  1054.           (t
  1055.            (substitute-in-file-name val)))))
  1056.  
  1057.  
  1058. (defun read-file-name (prompt
  1059.                        &optional dir default must-match initial-contents
  1060.                history)
  1061.   "Read file name, prompting with PROMPT and completing in directory DIR.
  1062. Value is not expanded---you must call `expand-file-name' yourself.
  1063. Value is subject to interpreted by substitute-in-file-name however.
  1064. Default name to DEFAULT if user enters a null string.
  1065.  (If DEFAULT is omitted, the visited file name is used.)
  1066. Fourth arg MUST-MATCH non-nil means require existing file's name.
  1067.  Non-nil and non-t means also require confirmation after completion.
  1068. Fifth arg INITIAL-CONTENTS specifies text to start with.
  1069. Sixth arg HISTORY specifies the history list to use.  Default is
  1070.  `minibuffer-file-name-history'.
  1071. DIR defaults to current buffer's directory default."
  1072.   (read-file-name-1
  1073.    (or history 'minibuffer-file-name-history)
  1074.    prompt dir (or default buffer-file-name) must-match initial-contents
  1075.    ;; A separate function (not an anonymous lambda-expression)
  1076.    ;; and passed as a symbol because of disgusting kludges in various
  1077.    ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...)
  1078.    'read-file-name-internal))
  1079.  
  1080. (defun read-directory-name (prompt
  1081.                             &optional dir default must-match initial-contents)
  1082.   ;;>>> document me
  1083.   (read-file-name-1 
  1084.     'minibuffer-file-name-history
  1085.     prompt dir (or default default-directory) must-match initial-contents
  1086.     'read-directory-name-internal))
  1087.  
  1088.  
  1089. ;; Environment-variable completion hack
  1090. (defun read-file-name-internal-1 (string dir action completer)
  1091.   (if (not (string-match "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'"
  1092.                          string))
  1093.       ;; Not doing environment-variable completion hack
  1094.       (let* ((orig (if (equal string "") nil string))
  1095.              (sstring (if orig (substitute-in-file-name string) string))
  1096.              (specdir (if orig (file-name-directory sstring) nil)))
  1097.         (funcall completer 
  1098.                  action 
  1099.                  orig 
  1100.                  sstring 
  1101.                  specdir
  1102.                  (if specdir (expand-file-name specdir dir) dir)
  1103.                  (if orig (file-name-nondirectory sstring) string)))
  1104.       ;; An odd number of trailing $'s
  1105.       (let* ((start (match-beginning 3))
  1106.              (env (substring string 
  1107.                              (cond ((= start (length string))
  1108.                                     ;; "...$"
  1109.                                     start)
  1110.                                    ((= (aref string start) ?{)
  1111.                                     ;; "...${..."
  1112.                                     (1+ start))
  1113.                                    (t
  1114.                                     start))))
  1115.              (head (substring string 0 (1- start))))
  1116.         (cond ((eq action 'lambda)
  1117.                nil)
  1118.               ((eq action 't)
  1119.                ;; all completions
  1120.                (mapcar (function (lambda (p)
  1121.                          (if (and (> (length p) 0)
  1122.                                   ;;>>> Unix-specific
  1123.                                   ;;>>>  -- need absolute-pathname-p
  1124.                                   (/= (aref p 0) ?/))
  1125.                              (concat "$" p)
  1126.                              (concat head "$" p))))
  1127.                        (all-completions env (getenv t))))
  1128.               (t ;; 'nil
  1129.                ;; complete
  1130.                (let* ((e (getenv t))
  1131.                       (val (try-completion env e)))
  1132.                  (cond ((stringp val)
  1133.                         (if (string-match "[^A-Za-z0-9_]" val)
  1134.                             (concat head
  1135.                                     "${" val
  1136.                                     ;; completed uniquely?
  1137.                                     (if (eq (try-completion val e) 't)
  1138.                                         "}" ""))
  1139.                             (concat head "$" val)))
  1140.                        ((eql val 't)
  1141.                         (concat head
  1142.                                 (un-substitute-in-file-name (getenv env))))
  1143.                        (t nil))))))))
  1144.  
  1145.  
  1146. (defun read-file-name-internal (string dir action)
  1147.   (read-file-name-internal-1 
  1148.     string dir action
  1149.     (function (lambda (action orig string specdir dir name)
  1150.       (cond ((eq action 'lambda)
  1151.              (if (not orig)
  1152.                  nil
  1153.                (let ((sstring (condition-case nil 
  1154.                                   (expand-file-name string)
  1155.                                 (error nil))))
  1156.                  (if (not sstring)
  1157.                      ;; Some pathname syntax error in string
  1158.                      nil
  1159.                      (file-exists-p sstring)))))
  1160.             ((eq action 't)
  1161.              ;; all completions
  1162.              (mapcar (function un-substitute-in-file-name)
  1163.                      (file-name-all-completions name dir)))
  1164.             (t;; 'nil
  1165.              ;; complete
  1166.          (or specdir (setq specdir default-directory))
  1167.              (let ((val (file-name-completion name specdir)))
  1168.                (if (and (eq val 't)
  1169.                         (not (null completion-ignored-extensions)))
  1170.                    ;;>> (file-name-completion "foo") returns 't
  1171.                    ;;   when both "foo" and "foo~" exist and the latter
  1172.                    ;;   is "pruned" by completion-ignored-extensions.
  1173.                    ;; I think this is a bug in file-name-completion.
  1174.                    (setq val (let ((completion-ignored-extensions '()))
  1175.                                (file-name-completion name specdir))))
  1176.                (if (stringp val)
  1177.                    (un-substitute-in-file-name (if specdir
  1178.                                                    (concat specdir val)
  1179.                                                    val))
  1180.                    (let ((tem (un-substitute-in-file-name string)))
  1181.                      (if (not (equal tem orig))
  1182.                          ;; substitute-in-file-name did something
  1183.                          tem
  1184.                          val))))))))))
  1185.  
  1186.  
  1187. (defun read-directory-name-internal (string dir action)
  1188.   (read-file-name-internal-1 
  1189.     string dir action
  1190.     (function (lambda (action orig string specdir dir name)
  1191.       (let* (;; This looks better in a possibilities list than ""
  1192.              ;;>>>> Un*x-specific >>
  1193.              (standin "./")
  1194.              (dirs (function (lambda (fn)
  1195.                      (let ((l (if (equal name "")
  1196.                                   (cons standin (directory-files
  1197.                                                  dir
  1198.                                                  nil
  1199.                                                  ""
  1200.                                                  nil
  1201.                                                  'directories))
  1202.                                   (directory-files
  1203.                                    dir
  1204.                                    nil 
  1205.                                    (concat "\\`" (regexp-quote name))
  1206.                                    nil
  1207.                                    'directories))))
  1208.                        (mapcar fn
  1209.                                (cond ((eq system-type 'vax-vms)
  1210.                                       l)
  1211.                                      (t
  1212.                                       ;; Wretched unix
  1213.                                       (delete "." (delete ".." l))))))))))
  1214.         (cond ((eq action 'lambda)
  1215.                ;; complete?
  1216.                (if (not orig)
  1217.                    nil
  1218.                    (and (file-directory-p string)
  1219.                         ;; So "foo" is ambiguous between "foo/" and "foobar/"
  1220.                         (equal string (file-name-as-directory string)))))
  1221.               ((eq action 't)
  1222.                ;; all completions
  1223.                (funcall dirs (function (lambda (n)
  1224.                                (un-substitute-in-file-name 
  1225.                                 (if (equal n standin) 
  1226.                                     standin
  1227.                                     (file-name-as-directory n)))))))
  1228.               (t
  1229.                ;; complete
  1230.                (let ((val (try-completion
  1231.                            name
  1232.                            (funcall dirs
  1233.                                     (function (lambda (n)
  1234.                                       (if (equal n standin)
  1235.                                           (list standin)
  1236.                                           (list (file-name-as-directory
  1237.                                                  n)))))))))
  1238.                  (if (stringp val)
  1239.                      (un-substitute-in-file-name (if specdir
  1240.                                                      (concat specdir val)
  1241.                                                      val))
  1242.                      (let ((tem (un-substitute-in-file-name string)))
  1243.                        (if (not (equal tem orig))
  1244.                            ;; substitute-in-file-name did something
  1245.                            tem
  1246.                            val)))))))))))
  1247.  
  1248. ;;;; Stuff which has ended up here for want of a better place
  1249.  
  1250. (defun execute-extended-command (prefix-arg)
  1251.   (interactive "P")
  1252.   ;; Note:  This doesn't hack "this-command-keys"
  1253.   (let ((prefix-arg prefix-arg))
  1254.     (setq this-command (read-command
  1255.                         ;; Note: this has the hard-wired
  1256.                         ;;  "C-u" and "M-x" string bug in common
  1257.                         ;;  with all GNU Emacs's.
  1258.                         (cond ((eq prefix-arg '-)
  1259.                                "- M-x ")
  1260.                               ((equal prefix-arg '(4))
  1261.                                "C-u M-x ")
  1262.                               ((integerp prefix-arg)
  1263.                                (format "%d M-x " prefix-arg))
  1264.                               ((and (consp prefix-arg)
  1265.                                     (integerp (car prefix-arg)))
  1266.                                (format "%d M-x " (car prefix-arg)))
  1267.                               (t
  1268.                                "M-x ")))))
  1269.   (command-execute this-command t))
  1270.  
  1271. (defun y-or-n-p-minibuf (prompt)
  1272.   "Ask user a \"y or n\" question.  Return t if answer is \"y\".
  1273. Takes one argument, which is the string to display to ask the question.
  1274. It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
  1275. No confirmation of the answer is requested; a single character is enough.
  1276. Also accepts Space to mean yes, or Delete to mean no."
  1277.   (let* ((prompt (format "%s(y or n) " prompt))
  1278.          (p prompt)
  1279.          (event (allocate-event)))
  1280.     (while (stringp p)
  1281.       (if (let ((cursor-in-echo-area t)
  1282.                 (inhibit-quit t))
  1283.             (message "%s" p)
  1284.             (next-command-event event)
  1285.             (prog1 quit-flag (setq quit-flag nil)))
  1286.           (progn
  1287.             (message "%s%s" p (single-key-description event))
  1288.             (deallocate-event event)
  1289.             (setq quit-flag nil)
  1290.             (signal 'quit '())))
  1291.       (let* ((key (and (key-press-event-p event) (event-key event)))
  1292.              (char (and key (event-to-character event))))
  1293.         (if char (setq char (downcase char)))
  1294.         (cond ((or (eq char ?y) (eq char ? ))
  1295.                (message "%sYes" p)
  1296.                (setq p t))
  1297.               ((or (eq char ?n) (eq key 'delete))
  1298.                (message "%sNo" p)
  1299.                (setq p nil))
  1300.           ((button-release-event-p event) ; ignore them
  1301.            nil)
  1302.               (t
  1303.                (message "%s%s" p (single-key-description event))
  1304.                (ding nil 'y-or-n-p)
  1305.                (discard-input)
  1306.                (if (eq p prompt)
  1307.                    (setq p (concat "Please answer y or n.  " prompt)))))))
  1308.     (deallocate-event event)
  1309.     p))
  1310.  
  1311. (defun yes-or-no-p-minibuf (prompt)
  1312.   "Ask user a yes-or-no question.  Return t if answer is yes.
  1313. Takes one argument, which is the string to display to ask the question.
  1314. It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
  1315. The user must confirm the answer with RET,
  1316. and can edit it until it as been confirmed."
  1317.   (let ((p (concat prompt "(yes or no) ")))
  1318.     (while (stringp p)
  1319.       (setq p (downcase (read-string p nil t))) ;no history
  1320.       (cond ((string-equal p "yes")
  1321.              (setq p 't))
  1322.             ((string-equal p "no")
  1323.              (setq p 'nil))
  1324.             (t
  1325.              (ding nil 'yes-or-no-p)
  1326.              (discard-input)
  1327.              (message "Please answer yes or no.")
  1328.              (sleep-for 2))))
  1329.     p))
  1330.  
  1331. ;; these may be redefined later, but make the original def easily encapsulable
  1332. (fset 'yes-or-no-p 'yes-or-no-p-minibuf)
  1333. (fset 'y-or-n-p 'y-or-n-p-minibuf)
  1334.