home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-02-17 | 55.6 KB | 1,334 lines |
- ;;; minibuf.el
- ;; Copyright (C) 1992-1993 Free Software Foundation, Inc.
-
- ;; This file is part of GNU Emacs.
-
- ;; GNU Emacs is free software; you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
-
- ;; GNU Emacs is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
-
- ;; You should have received a copy of the GNU General Public License
- ;; along with GNU Emacs; see the file COPYING. If not, write to
- ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ;; Written by Richard Mlynarik 2-Oct-92
-
- (defvar insert-default-directory t
- "*Non-nil means when reading a filename start with default dir in minibuffer."
- )
-
- (defvar minibuffer-completion-table nil
- "Alist or obarray used for completion in the minibuffer.
- This becomes the ALIST argument to `try-completion' and `all-completions'.
-
- The value may alternatively be a function, which is given three arguments:
- STRING, the current buffer contents;
- PREDICATE, the predicate for filtering possible matches;
- CODE, which says what kind of things to do.
- CODE can be nil, t or `lambda'.
- nil means to return the best completion of STRING, nil if there is none,
- or t if it is was already a unique completion.
- t means to return a list of all possible completions of STRING.
- `lambda' means to return t if STRING is a valid completion as it stands.")
-
- (defvar minibuffer-completion-predicate nil
- "Within call to `completing-read', this holds the PREDICATE argument.")
-
- (defvar minibuffer-completion-confirm nil
- "Non-nil => demand confirmation of completion before exiting minibuffer.")
-
- (defvar minibuffer-confirm-incomplete nil
- "If true, then in contexts where completing-read allows answers which
- are not valid completions, an extra RET must be typed to confirm the
- response. This is helpful for catching typos, etc.")
-
- (defvar completion-auto-help t
- "*Non-nil means automatically provide help for invalid completion input.")
-
- (defvar enable-recursive-minibuffers nil
- "*Non-nil means to allow minibuffer commands while in the minibuffer.
- More precisely, this variable makes a difference when the minibuffer window
- is the selected window. If you are in some other window, minibuffer commands
- are allowed even if a minibuffer is active.")
-
-
- (defvar minibuffer-help-form nil
- "Value that `help-form' takes on inside the minibuffer.")
-
- (defvar minibuffer-local-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'minibuffer-local-map)
- map)
- "Default keymap to use when reading from the minibuffer.")
-
- (defvar minibuffer-local-completion-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'minibuffer-local-completion-map)
- (set-keymap-parent map minibuffer-local-map)
- map)
- "Local keymap for minibuffer input with completion.")
-
- (defvar minibuffer-local-must-match-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'minibuffer-must-match-map)
- (set-keymap-parent map minibuffer-local-completion-map)
- map)
- "Local keymap for minibuffer input with completion, for exact match.")
-
- (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit)
- (define-key minibuffer-local-map "\r" 'exit-minibuffer)
- (define-key minibuffer-local-map "\n" 'exit-minibuffer)
-
- ;; Historical crock. Unused by anything but user code, if even that
- ;(defvar minibuffer-local-ns-map
- ; (let ((map (make-sparse-keymap)))
- ; (set-keymap-name map 'minibuffer-local-ns-map)
- ; (set-keymap-parent map minibuffer-local-map)
- ; map)
- ; "Local keymap for the minibuffer when spaces are not allowed.")
- ;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer)
- ;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer)
- ;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit)
-
- (define-key minibuffer-local-completion-map "\t" 'minibuffer-complete)
- (define-key minibuffer-local-completion-map " " 'minibuffer-complete-word)
- (define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help)
- (define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit)
- (define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit)
-
- (define-key minibuffer-local-map "\M-n" 'next-history-element)
- (define-key minibuffer-local-map "\M-p" 'previous-history-element)
- (define-key minibuffer-local-map [next] 'next-history-element)
- (define-key minibuffer-local-map [prior] 'previous-history-element)
- (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
- (define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
-
- (defvar read-expression-map (let ((map (make-sparse-keymap)))
- (set-keymap-parent map minibuffer-local-map)
- (set-keymap-name map 'read-expression-map)
- map)
- "Minibuffer keymap used for reading Lisp expressions.")
-
- (define-key read-expression-map "\M-\t" 'lisp-complete-symbol)
-
- (defvar read-shell-command-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map minibuffer-local-map)
- (set-keymap-name map 'read-shell-command-map)
- (define-key map "\t" 'comint-dynamic-complete)
- (define-key map "\M-\t" 'comint-dynamic-complete)
- (define-key map "\M-?" 'comint-dynamic-list-completions)
- map)
- "Minibuffer keymap used by shell-command and related commands.")
-
- ;;;; Guts of minibuffer invocation
-
- ;;>>> The only things remaining in C are
- ;; "Vminibuf_prompt" and the display junk
- ;; "minibuf_prompt_width" and "minibuf_prompt_pix_width"
- ;; Also "active_screen", though I suspect I could already
- ;; hack that in Lisp if I could make any sense of the
- ;; complete mess of screen/frame code in Emacs.
- ;; Vminibuf_prompt could easily be made Lisp-bindable.
- ;; I suspect that minibuf_prompt*_width are actually recomputed
- ;; by redisplay as needed -- or could be arranged to be so --
- ;; and that there could be need for read-minibuffer-internal to
- ;; save and restore them.
- ;;>>> The only other thing which read-from-minibuffer-internal does
- ;; which we can't presently do in Lisp is move the screen cursor
- ;; to the start of the minibuffer line as it returns. This is
- ;; a rather nice touch and should be preserved -- probably by
- ;; providing some Lisp-level mechanism (extension to cursor-in-echo-area ?)
- ;; to effect it.
-
-
- ;; Like reset_buffer in buffer.c
- ;; (Except that kill-all-local-variables doesn't nuke 'permanent-local
- ;; variables -- we preserve them, reset_buffer doesn't.)
- (defun reset-buffer (buffer)
- (save-excursion
- (set-buffer buffer)
- ;(if (fboundp 'unlock-buffer) (unlock-buffer))
- (kill-all-local-variables)
- (setq buffer-read-only nil)
- (erase-buffer)
- ;(setq default-directory nil)
- (setq buffer-file-name nil)
- (setq buffer-file-truename nil)
- (set-buffer-modified-p nil)
- (setq buffer-backed-up nil)
- (setq buffer-auto-save-file-name nil)
- (set-buffer-dedicated-screen buffer nil)
- buffer))
-
- (defun read-from-minibuffer (prompt &optional initial-contents
- keymap
- readp
- history)
- "Read a string from the minibuffer, prompting with string PROMPT.
- If optional second arg INITIAL-CONTENTS is non-nil, it is a string
- to be inserted into the minibuffer before reading input.
- If INITIAL-CONTENTS is (STRING . POSITION), the initial input
- is STRING, but point is placed POSITION characters into the string.
- Third arg KEYMAP is a keymap to use whilst reading;
- if omitted or nil, the default is `minibuffer-local-map'.
- If fourth arg READ is non-nil, then interpret the result as a lisp object
- and return that object:
- in other words, do `(car (read-from-string INPUT-STRING))'
- Fifth arg HISTORY, if non-nil, specifies a history list
- and optionally the initial position in the list.
- It can be a symbol, which is the history list variable to use,
- or it can be a cons cell (HISTVAR . HISTPOS).
- In that case, HISTVAR is the history list variable to use,
- and HISTPOS is the initial position (the position in the list
- which INITIAL-CONTENTS corresponds to).
- If HISTORY is `t', no history will be recorded.
- Positions are counted starting from 1 at the beginning of the list."
- (if (and (not enable-recursive-minibuffers)
- (> (minibuffer-depth) 0)
- (eq (selected-window) (minibuffer-window)))
- (error "Command attempted to use minibuffer while in minibuffer"))
-
- ;; catch this error before the poor user has typed something...
- (if history
- (if (symbolp history)
- (or (boundp history)
- (error "History list %S is unbound" history))
- (or (boundp (car history))
- (error "History list %S is unbound" (car history)))))
-
- (if (noninteractive)
- (progn
- ;; Emacs in -batch mode calls minibuffer: print the prompt.
- (message "%s" prompt)
- ;;>>> force-output
-
- ;;>>> Should this even be falling though to the code below?
- ;;>>> How does this stuff work now, anyway?
- ))
- (let* ((dir default-directory)
- (owindow (selected-window))
- (window (minibuffer-window))
- (buffer (if (eq (minibuffer-depth) 0)
- (window-buffer window)
- (get-buffer-create (format " *Minibuf-%d"
- (minibuffer-depth))))))
- (save-window-excursion
- (set-buffer buffer)
- (reset-buffer buffer)
- (setq default-directory dir)
- (make-local-variable 'print-escape-newlines)
- (setq print-escape-newlines t)
- (make-local-variable 'mode-motion-hook)
- (setq mode-motion-hook 'minibuf-mouse-tracker) ;>>>disgusting
- (set-window-buffer window buffer)
- (select-window window)
- (set-window-hscroll window 0)
- (erase-buffer)
- (buffer-enable-undo buffer)
- (message nil)
- (if initial-contents
- (if (consp initial-contents)
- (progn
- (insert (car initial-contents))
- (goto-char (cdr initial-contents)))
- (insert initial-contents)))
- (use-local-map (or keymap minibuffer-local-map))
- (let ((mouse-grabbed-buffer (current-buffer))
- (current-prefix-arg current-prefix-arg)
- (help-form minibuffer-help-form)
- (minibuffer-history-variable (cond ((not history)
- 'minibuffer-history)
- ((consp history)
- (car history))
- (t
- history)))
- (minibuffer-history-position (cond ((consp history)
- (cdr history))
- (t
- 0)))
- (minibuffer-scroll-window owindow))
- (unwind-protect
- (if (eq 't
- (catch 'exit
- (if (> (recursion-depth) (minibuffer-depth))
- (let ((standard-output t)
- (standard-input t))
- (read-minibuffer-internal prompt))
- (read-minibuffer-internal prompt))))
- ;; Translate an "abort" (throw 'exit 't)
- ;; into a real quit
- (signal 'quit '())
- ;; return value
- (let ((val (progn (set-buffer buffer) (buffer-string)))
- (list (symbol-value minibuffer-history-variable)))
- ;; Add the value to the appropriate history list unless
- ;; it's already the most recent element, or it's only
- ;; two characters long.
- (or (eq list t)
- (null val)
- (equal val (car list))
- (and (stringp val) (< (length val) 3))
- (set minibuffer-history-variable (cons val list)))
- (if readp
- (car (read-from-string val))
- val)))
- ;; stupid display code requires this for some reason
- (set-buffer buffer)
- (buffer-disable-undo buffer)
- (setq buffer-read-only nil)
- (erase-buffer))))))
-
-
- ;;;; Guts of minibuffer completion
-
-
- ;; Used by minibuffer-do-completion
- (defvar last-exact-completion)
-
- (defun temp-minibuffer-message (m)
- (let ((savemax (point-max)))
- (save-excursion
- (goto-char (point-max))
- (message nil)
- (insert m))
- (let ((inhibit-quit t))
- (sit-for 2)
- (delete-region savemax (point-max))
- ;; If the user types a ^G while we're in sit-for, then quit-flag
- ;; gets set. In this case, we want that ^G to be interpreted
- ;; as a normal character, and act just like typeahead.
- (if (and quit-flag (not unread-command-event))
- (setq unread-command-event (character-to-event interrupt-char)
- quit-flag nil)))))
-
-
- ;; Determines whether buffer-string is an exact completion
- (defun exact-minibuffer-completion-p (buffer-string)
- (cond ((not minibuffer-completion-table)
- ;; Empty alist
- nil)
- ((vectorp minibuffer-completion-table)
- (let ((tem (intern-soft buffer-string
- minibuffer-completion-table)))
- (if (or tem
- (and (string-equal buffer-string "nil")
- ;; intern-soft loses for 'nil
- (catch 'found
- (mapatoms
- (function (lambda (s)
- (if (string-equal
- (symbol-name s)
- buffer-string)
- (throw 'found t))))
- minibuffer-completion-table)
- nil)))
- (if minibuffer-completion-predicate
- (funcall minibuffer-completion-predicate
- tem)
- t)
- nil)))
- ((and (consp minibuffer-completion-table)
- ;;>>> Emacs-Lisp truly sucks!
- ;; lambda, autoload, etc
- (not (symbolp (car minibuffer-completion-table))))
- (if (not completion-ignore-case)
- (assoc buffer-string minibuffer-completion-table)
- (let ((s (upcase buffer-string))
- (tail minibuffer-completion-table)
- tem)
- (while tail
- (setq tem (car (car tail)))
- (if (or (equal tem buffer-string)
- (equal tem s)
- (equal (upcase tem) s))
- (setq s 'win
- tail nil) ;exit
- (setq tail (cdr tail))))
- (eq s 'win))))
- (t
- (funcall minibuffer-completion-table
- buffer-string
- minibuffer-completion-predicate
- 'lambda)))
- )
-
- ;; 0 'none no possible completion
- ;; 1 'unique was already an exact and unique completion
- ;; 3 'exact was already an exact (but nonunique) completion
- ;; NOT USED 'completed-exact-unique completed to an exact and completion
- ;; 4 'completed-exact completed to an exact (but nonunique) completion
- ;; 5 'completed some completion happened
- ;; 6 'uncompleted no completion happened
- (defun minibuffer-do-completion-1 (buffer-string completion)
- (cond ((not completion)
- 'none)
- ((eq completion t)
- ;; exact and unique match
- 'unique)
- (t
- ;; It did find a match. Do we match some possibility exactly now?
- (let ((completedp (not (string-equal completion buffer-string))))
- (if completedp
- (progn
- ;; Some completion happened
- (erase-buffer)
- (insert completion)
- (setq buffer-string completion)))
- (if (exact-minibuffer-completion-p buffer-string)
- ;; An exact completion was possible
- (if completedp
- ;; Since no callers need to know the difference, don't bother
- ;; with this (potentially expensive) discrimination.
- ;; (if (eq (try-completion completion
- ;; minibuffer-completion-table
- ;; minibuffer-completion-predicate)
- ;; 't)
- ;; 'completed-exact-unique
- 'completed-exact
- ;; )
- 'exact)
- ;; Not an exact match
- (if completedp
- 'completed
- 'uncompleted))))))
-
-
- (defun minibuffer-do-completion (buffer-string)
- (let* ((completion (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (status (minibuffer-do-completion-1 buffer-string completion))
- (last last-exact-completion))
- (setq last-exact-completion nil)
- (cond ((eq status 'none)
- ;; No completions
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No match]"))
- ((eq status 'unique)
- )
- (t
- ;; It did find a match. Do we match some possibility exactly now?
- (if (not (string-equal completion buffer-string))
- (progn
- ;; Some completion happened
- (erase-buffer)
- (insert completion)
- (setq buffer-string completion)))
- (cond ((eq status 'exact)
- ;; If the last exact completion and this one were
- ;; the same, it means we've already given a
- ;; "Complete but not unique" message and that the
- ;; user's hit TAB again, so now we give help.
- (setq last-exact-completion completion)
- (if (equal buffer-string last)
- (minibuffer-completion-help)))
- ((eq status 'uncompleted)
- (if completion-auto-help
- (minibuffer-completion-help)
- (temp-minibuffer-message " [Next char not unique]")))
- (t
- nil))))
- status))
-
-
- ;;;; completing-read
-
- (defun completing-read (prompt table
- &optional predicate require-match
- initial-contents history)
- "Read a string in the minibuffer, with completion.
- Args: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-CONTENTS, HISTORY.
- PROMPT is a string to prompt with; normally it ends in a colon and a space.
- TABLE is an alist whose elements' cars are strings, or an obarray.
- PREDICATE limits completion to a subset of TABLE.
- See `try-completion' for more details on completion, TABLE, and PREDICATE.
- If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
- the input is (or completes to) an element of TABLE.
- If it is also not t, Return does not exit if it does non-null completion.
- If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially.
- If it is (STRING . POSITION), the initial input
- is STRING, but point is placed POSITION characters into the string.
- HISTORY, if non-nil, specifies a history list
- and optionally the initial position in the list.
- It can be a symbol, which is the history list variable to use,
- or it can be a cons cell (HISTVAR . HISTPOS).
- In that case, HISTVAR is the history list variable to use,
- and HISTPOS is the initial position (the position in the list
- which INITIAL-CONTENTS corresponds to).
- If HISTORY is `t', no history will be recorded.
- Positions are counted starting from 1 at the beginning of the list.
- Completion ignores case if the ambient value of
- `completion-ignore-case' is non-nil."
- (let ((minibuffer-completion-table table)
- (minibuffer-completion-predicate predicate)
- (minibuffer-completion-confirm (if (eq require-match 't) nil t))
- (last-exact-completion nil))
- (read-from-minibuffer prompt
- initial-contents
- (if (not require-match)
- minibuffer-local-completion-map
- minibuffer-local-must-match-map)
- nil
- history)))
-
-
- ;;;; Minibuffer completion commands
-
-
- (defun minibuffer-complete ()
- "Complete the minibuffer contents as far as possible."
- (interactive)
- (let ((status (minibuffer-do-completion (buffer-string))))
- (if (eq status 'none)
- nil
- (progn
- (cond ((eq status 'unique)
- (temp-minibuffer-message " [Sole completion]"))
- ((eq status 'exact)
- (temp-minibuffer-message " [Complete, but not unique]")))
- t))))
-
-
- (defun minibuffer-complete-and-exit ()
- "Complete the minibuffer contents, and maybe exit.
- Exit if the name is valid with no completion needed.
- If name was completed to a valid match,
- a repetition of this command will exit."
- (interactive)
- (if (= (point-min) (point-max))
- ;; Crockishly allow user to specify null string
- (throw 'exit nil))
- (let ((buffer-string (buffer-string)))
- ;; Short-cut -- don't call minibuffer-do-completion if we already
- ;; have an (possibly nonunique) exact completion.
- (if (exact-minibuffer-completion-p buffer-string)
- (throw 'exit nil))
- (let ((status (minibuffer-do-completion buffer-string)))
- (if (or (eq status 'unique)
- (eq status 'exact)
- (if (or (eq status 'completed-exact)
- (eq status 'completed-exact-unique))
- (if minibuffer-completion-confirm
- (progn (temp-minibuffer-message " [Confirm]")
- nil)
- t)))
- (throw 'exit nil)))))
-
-
- (defun self-insert-and-exit ()
- "Terminate minibuffer input."
- (interactive)
- (self-insert-command)
- (throw 'exit nil))
-
- (defun exit-minibuffer ()
- "Terminate this minibuffer argument.
- If minibuffer-confirm-incomplete is true, and we are in a completing-read
- of some kind, and the contents of the minibuffer is not an existing
- completion, requires an additional RET before the minibuffer will be exited
- \(assuming that RET was the character that invoked this command:
- the character in question must be typed again)."
- (interactive)
- (if (not minibuffer-confirm-incomplete)
- (throw 'exit nil))
- (let ((buffer-string (buffer-string)))
- (if (exact-minibuffer-completion-p buffer-string)
- (throw 'exit nil))
- (let ((completion (if (not minibuffer-completion-table)
- t
- (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))))
- (if (or (eq completion 't)
- ;; Crockishly allow user to specify null string
- (string-equal buffer-string ""))
- (throw 'exit nil))
- (temp-minibuffer-message (if completion
- " [incomplete; confirm]"
- " [no completions; confirm]"))
- (let ((event (allocate-event)))
- (let ((inhibit-quit t))
- (next-command-event event)
- (setq quit-flag nil))
- (cond ((equal event last-command-event)
- (throw 'exit nil))
- ((equal interrupt-char (event-to-character event nil))
- (deallocate-event event)
- ;; Minibuffer abort.
- (throw 'exit t)))
- (dispatch-event event)
- (deallocate-event event)))))
-
- ;;;; minibuffer-complete-word
-
-
- ;;;>>> I think I have done this correctly; it certainly is simpler
- ;;;>>> than what the C code seemed to be trying to do.
- (defun minibuffer-complete-word ()
- "Complete the minibuffer contents at most a single word.
- After one word is completed as much as possible, a space or hyphen
- is added, provided that matches some possible completion."
- (interactive)
- (let* ((buffer-string (buffer-string))
- (completion (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (status (minibuffer-do-completion-1 buffer-string completion)))
- (cond ((eq status 'none)
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No match]")
- nil)
- ((eq status 'unique)
- ;; New message, only in this new Lisp code
- (temp-minibuffer-message " [Sole completion]")
- t)
- (t
- (cond ((or (eq status 'uncompleted)
- (eq status 'exact))
- (let ((foo (function (lambda (s)
- (condition-case nil
- (if (try-completion
- (concat buffer-string s)
- minibuffer-completion-table
- minibuffer-completion-predicate)
- (progn
- (goto-char (point-max))
- (insert s)
- t)
- nil)
- (error nil)))))
- (char last-command-char))
- ;; Try to complete by adding a word-delimiter
- (or (and (integerp char) (> char 0)
- (funcall foo (char-to-string char)))
- (and (not (eq char ?\ ))
- (funcall foo " "))
- (and (not (eq char ?\-))
- (funcall foo "-"))
- (progn
- (if completion-auto-help
- (minibuffer-completion-help)
- ;; New message, only in this new Lisp code
- (temp-minibuffer-message
- (if (eq status 'exact)
- " [Complete, but not unique]"
- " [Ambiguous]")))
- nil))))
- (t
- (erase-buffer)
- (insert completion)
- ;; First word-break in stuff found by completion
- (goto-char (point-min))
- (let ((len (length buffer-string))
- n)
- (if (and (< len (length completion))
- (catch 'match
- (setq n 0)
- (while (< n len)
- (if (char-equal
- (upcase (aref buffer-string n))
- (upcase (aref completion n)))
- (setq n (1+ n))
- (throw 'match nil)))
- t)
- (progn
- (goto-char (point-min))
- (forward-char len)
- (re-search-forward "\\W" nil t)))
- (delete-region (point) (point-max))
- (goto-char (point-max))))
- t))))))
-
- ;;;; Completion help
-
- (defun display-completion-list (completions)
- "Display the list of completions, COMPLETIONS, using `standard-output'.
- Each element may be just a symbol or string
- or may be a list of two strings to be printed as if concatenated."
- (let ((old-buffer (current-buffer))
- (bufferp (bufferp standard-output)))
- (if bufferp
- (set-buffer standard-output))
- (if (null completions)
- (princ "There are no possible completions of what you have typed.")
- (let ((win-width (if bufferp
- ;; This needs fixing for the case of windows
- ;; that aren't the same width s the screen.
- ;; Sadly, the window it will appear in is not known
- ;; until after the text has been made.
- (screen-width (selected-screen))
- 80)))
- (let ((count 0)
- (max-width 0))
- ;; Find longest completion
- (let ((tail completions))
- (while tail
- (let* ((elt (car tail))
- (len (cond ((stringp elt)
- (length elt))
- ((and (consp elt)
- (stringp (car elt))
- (stringp (car (cdr elt))))
- (+ (length (car elt))
- (length (car (cdr elt)))))
- (t
- (signal 'wrong-type-argument
- (list 'stringp elt))))))
- (if (> len max-width)
- (setq max-width len))
- (setq count (1+ count)
- tail (cdr tail)))))
-
- (setq max-width (+ 2 max-width)) ; at least two chars between cols
- (let ((rows (let ((cols (min (/ win-width max-width) count)))
- (if (<= cols 1)
- count
- (progn
- ;; re-space the columns
- (setq max-width (/ win-width cols))
- (if (/= (% count cols) 0) ; want ceiling...
- (1+ (/ count cols))
- (/ count cols)))))))
- (princ "Possible completions are:")
- (let ((tail completions)
- (r 0))
- (while (< r rows)
- (terpri)
- (let ((indent 0)
- (column 0)
- (tail2 tail))
- (while tail2
- (let ((elt (car tail2)))
- (if (/= indent 0)
- (if bufferp
- (indent-to indent 1)
- (while (progn (write-char ?\ )
- (setq column (1+ column))
- (< column indent)))))
- (setq indent (+ indent max-width))
- (if (consp elt)
- (progn
- (princ (car elt))
- (princ (car (cdr elt)))
- (or bufferp
- (setq column (+ column
- (length (car elt))
- (length (car (cdr elt)))))))
- (progn
- (princ elt)
- (or bufferp
- (setq column (+ column (length elt)))))))
- (setq tail2 (nthcdr rows tail2)))
- (setq tail (cdr tail)
- r (1+ r)))))))))
- (if bufferp
- (set-buffer old-buffer))))
-
- (defun minibuffer-completion-help ()
- "Display a list of possible completions of the current minibuffer contents."
- (interactive)
- (message "Making completion list...")
- (let ((completions (all-completions (buffer-string)
- minibuffer-completion-table
- minibuffer-completion-predicate)))
- (message nil)
- (if (null completions)
- (progn
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No completions]"))
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list (sort completions
- (function string-lessp)))))))
-
- ;;;; Minibuffer History
-
- (defvar minibuffer-history '()
- "Default minibuffer history list.
- This is used for all minibuffer input except when an alternate history
- list is specified.")
-
- ;; Some other history lists:
- ;;
- (defvar minibuffer-history-search-history '())
- (defvar minibuffer-sexp-history '())
- (defvar minibuffer-command-history '())
- (defvar minibuffer-function-history '())
- (defvar minibuffer-variable-history '())
- (defvar minibuffer-buffer-history '())
- (defvar minibuffer-shell-command-history '())
- (defvar minibuffer-file-name-history '())
-
- (defvar minibuffer-history-sexp-flag nil ;weird RMS Emacs kludge
- "Non-nil when doing history operations on `command-history'.
- More generally, indicates that the history list being acted on
- contains expressions rather than strings.")
-
- (defvar minibuffer-history-variable 'minibuffer-history
- "History list symbol to add minibuffer values to.
- Each minibuffer output is added with
- (set minibuffer-history-variable
- (cons STRING (symbol-value minibuffer-history-variable)))")
- (defvar minibuffer-history-position)
-
- (defun previous-matching-history-element (regexp n)
- "Find the previous history element that matches REGEXP.
- \(Previous history elements refer to earlier actions.)
- With prefix argument N, search for Nth previous match.
- If N is negative, find the next or Nth next match."
- (interactive
- (let ((enable-recursive-minibuffers t)
- (minibuffer-history-sexp-flag nil))
- (if (eq 't (symbol-value minibuffer-history-variable))
- (error "history is not being recorded in this context"))
- (list (read-from-minibuffer "Previous element matching (regexp): "
- nil
- minibuffer-local-map
- nil
- 'minibuffer-history-search-history)
- (prefix-numeric-value current-prefix-arg))))
- (let ((history (symbol-value minibuffer-history-variable))
- prevpos
- (pos minibuffer-history-position))
- (if (eq history t)
- (error "history is not being recorded in this context"))
- (while (/= n 0)
- (setq prevpos pos)
- (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
- (if (= pos prevpos)
- (error (if (= pos 1)
- "No later matching history item"
- "No earlier matching history item")))
- (if (string-match regexp
- (if minibuffer-history-sexp-flag
- (prin1-to-string (nth (1- pos) history))
- (nth (1- pos) history)))
- (setq n (+ n (if (< n 0) 1 -1)))))
- (setq minibuffer-history-position pos)
- (erase-buffer)
- (let ((elt (nth (1- pos) history)))
- (insert (if minibuffer-history-sexp-flag
- (prin1-to-string elt)
- elt)))
- (goto-char (point-min)))
- (if (or (eq (car (car command-history)) 'previous-matching-history-element)
- (eq (car (car command-history)) 'next-matching-history-element))
- (setq command-history (cdr command-history))))
-
- (defun next-matching-history-element (regexp n)
- "Find the next history element that matches REGEXP.
- \(The next history element refers to a more recent action.)
- With prefix argument N, search for Nth next match.
- If N is negative, find the previous or Nth previous match."
- (interactive
- (let ((enable-recursive-minibuffers t)
- (minibuffer-history-sexp-flag nil))
- (if (eq t (symbol-value minibuffer-history-variable))
- (error "history is not being recorded in this context"))
- (list (read-from-minibuffer "Next element matching (regexp): "
- nil
- minibuffer-local-map
- nil
- 'minibuffer-history-search-history)
- (prefix-numeric-value current-prefix-arg))))
- (previous-matching-history-element regexp (- n)))
-
- (defun next-history-element (n)
- "Insert the next element of the minibuffer history into the minibuffer."
- (interactive "p")
- (if (eq 't (symbol-value minibuffer-history-variable))
- (error "history is not being recorded in this context"))
- (let ((narg (min (max 1 (- minibuffer-history-position n))
- (length (symbol-value minibuffer-history-variable)))))
- (if (= minibuffer-history-position narg)
- (error (format "No %s item in %s"
- (if (>= n 0) "following" "preceding")
- minibuffer-history-variable))
- (erase-buffer)
- (setq minibuffer-history-position narg)
- (let ((elt (nth (1- minibuffer-history-position)
- (symbol-value minibuffer-history-variable))))
- (insert
- (if minibuffer-history-sexp-flag
- (condition-case ()
- (let ((print-readably t)) (prin1-to-string elt))
- (error (prin1-to-string elt)))
- elt)))
- (goto-char (point-max)))))
-
- (defun previous-history-element (n)
- "Inserts the previous element of the minibuffer history into the minibuffer."
- (interactive "p")
- (next-history-element (- n)))
-
-
- ;;;; reading various things from a minibuffer
-
- (defun read-minibuffer (prompt &optional initial-contents history)
- "Return a Lisp object read using the minibuffer.
- Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
- is a string to insert in the minibuffer before reading.
- Third arg HISTORY, if non-nil, specifies a history list."
- (read-from-minibuffer prompt
- initial-contents
- minibuffer-local-map
- t
- (or history 'minibuffer-sexp-history)))
-
- (defun read-string (prompt &optional initial-contents history)
- "Return a string from the minibuffer, prompting with string PROMPT.
- If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
- in the minibuffer before reading.
- Third arg HISTORY, if non-nil, specifies a history list."
- (read-from-minibuffer prompt
- initial-contents
- minibuffer-local-map
- nil history))
-
- (defun eval-minibuffer (prompt &optional initial-contents history)
- "Return value of Lisp expression read using the minibuffer.
- Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
- is a string to insert in the minibuffer before reading.
- Third arg HISTORY, if non-nil, specifies a history list."
- (eval (read-minibuffer prompt initial-contents history)))
-
- ;;;>> Screw this crock!!
- ;(defun read-no-blanks-input (prompt &optional initial-contents)
- ; "Read a string from the terminal, not allowing blanks.
- ;Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
- ;is a string to insert in the minibuffer before reading."
- ; (read-from-minibuffer prompt
- ; initial-contents
- ; minibuffer-local-ns-map
- ; nil))
-
- (defun read-command (prompt)
- "Read the name of a command and return as a symbol.
- Prompts with PROMPT."
- (intern (completing-read prompt obarray 'commandp t nil
- 'minibuffer-command-history)))
-
- (defun read-function (prompt)
- "Read the name of a function and return as a symbol.
- Prompts with PROMPT."
- (intern (completing-read prompt obarray 'fboundp t nil
- 'minibuffer-function-history)))
-
- (defun read-variable (prompt)
- "Read the name of a user variable and return it as a symbol.
- Prompts with PROMPT.
- A user variable is one whose documentation starts with a `*' character."
- (intern (completing-read prompt obarray 'user-variable-p t nil
- 'minibuffer-variable-history)))
-
- (defun read-buffer (prompt &optional default require-match)
- "Read the name of a buffer and return as a string.
- Prompts with PROMPT. Optional second arg DEFAULT is value to return if user
- enters an empty line. If optional third arg REQUIRE-MATCH is non-nil,
- only existing buffer names are allowed."
- (let ((prompt (if default
- (format "%s(default %s) "
- prompt (if (bufferp default)
- (buffer-name default)
- default))
- prompt))
- (alist (mapcar (function (lambda (b)
- (cons (buffer-name b) b)))
- (buffer-list)))
- result)
- (while (progn
- (setq result (completing-read prompt alist nil require-match
- nil 'minibuffer-buffer-history))
- (cond ((not (equal result ""))
- nil)
- ((not require-match)
- (setq result default)
- nil)
- ((not default)
- t)
- ((not (get-buffer default))
- t)
- (t
- (setq result default)
- nil))))
- (if (bufferp result)
- (buffer-name result)
- result)))
-
- (defun read-number (prompt &optional integers-only)
- "Reads a number from the minibuffer."
- (let ((pred (if integers-only 'integerp 'numberp))
- num)
- (while (not (funcall pred num))
- (setq num (condition-case ()
- (read-from-minibuffer
- prompt (if num (prin1-to-string num)) nil t
- t) ;no history
- (invalid-read-syntax nil)
- (end-of-file nil)))
- (or (funcall pred num) (beep)))
- num))
-
- (defun read-shell-command (prompt &optional initial-input)
- "Just like read-string, but uses read-shell-command-map:
- \\{read-shell-command-map}"
- (read-from-minibuffer prompt initial-input read-shell-command-map
- nil 'minibuffer-shell-command-history))
-
-
- ;;; This read-file-name stuff probably belongs in files.el
-
- ;; Quote "$" as "$$" to get it past substitute-in-file-name
- (defun un-substitute-in-file-name (string)
- (let ((regexp "\\$")
- (olen (length string))
- new
- n o ch)
- (cond ((eq system-type 'vax-vms)
- string)
- ((not (string-match regexp string))
- string)
- (t
- (setq n 1)
- (while (string-match regexp string (match-end 0))
- (setq n (1+ n)))
- (setq new (make-string (+ olen n) ?$))
- (setq n 0 o 0)
- (while (< o olen)
- (setq ch (aref string o))
- (aset new n ch)
- (setq o (1+ o) n (1+ n))
- (if (eq ch ?$)
- ;; already aset by make-string initial-value
- (setq n (1+ n))))
- new))))
-
- (defun read-file-name-1 (history prompt dir default
- must-match initial-contents
- completer)
- (if (not dir)
- (setq dir default-directory))
- (setq dir (abbreviate-file-name dir t))
- (let* ((insert (cond ((not insert-default-directory)
- "")
- (initial-contents
- (cons (un-substitute-in-file-name
- (concat dir initial-contents))
- (1+ (length dir))))
- (t
- (un-substitute-in-file-name dir))))
- (val (let ((completion-ignore-case (eq system-type 'vax-vms)))
- ;; Hateful, broken, case-sensitive un*x
- (completing-read prompt
- completer
- dir
- must-match
- insert
- history))))
- ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar"
- (let ((hist (cond ((not history) 'minibuffer-history)
- ((consp history) (car history))
- (t history))))
- (if (and val
- hist
- (not (eq hist 't))
- (boundp hist)
- (equal (car-safe (symbol-value hist)) val))
- (let ((e (condition-case nil
- (expand-file-name val)
- (error nil))))
- (if (and e (not (equal e val)))
- (set hist (cons e (cdr (symbol-value hist))))))))
-
- (cond ((not val)
- (error "No file name specified"))
- ((and default
- (equal val (if (consp insert) (car insert) insert)))
- default)
- (t
- (substitute-in-file-name val)))))
-
-
- (defun read-file-name (prompt
- &optional dir default must-match initial-contents
- history)
- "Read file name, prompting with PROMPT and completing in directory DIR.
- Value is not expanded---you must call `expand-file-name' yourself.
- Value is subject to interpreted by substitute-in-file-name however.
- Default name to DEFAULT if user enters a null string.
- (If DEFAULT is omitted, the visited file name is used.)
- Fourth arg MUST-MATCH non-nil means require existing file's name.
- Non-nil and non-t means also require confirmation after completion.
- Fifth arg INITIAL-CONTENTS specifies text to start with.
- Sixth arg HISTORY specifies the history list to use. Default is
- `minibuffer-file-name-history'.
- DIR defaults to current buffer's directory default."
- (read-file-name-1
- (or history 'minibuffer-file-name-history)
- prompt dir (or default buffer-file-name) must-match initial-contents
- ;; A separate function (not an anonymous lambda-expression)
- ;; and passed as a symbol because of disgusting kludges in various
- ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...)
- 'read-file-name-internal))
-
- (defun read-directory-name (prompt
- &optional dir default must-match initial-contents)
- ;;>>> document me
- (read-file-name-1
- 'minibuffer-file-name-history
- prompt dir (or default default-directory) must-match initial-contents
- 'read-directory-name-internal))
-
-
- ;; Environment-variable completion hack
- (defun read-file-name-internal-1 (string dir action completer)
- (if (not (string-match "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'"
- string))
- ;; Not doing environment-variable completion hack
- (let* ((orig (if (equal string "") nil string))
- (sstring (if orig (substitute-in-file-name string) string))
- (specdir (if orig (file-name-directory sstring) nil)))
- (funcall completer
- action
- orig
- sstring
- specdir
- (if specdir (expand-file-name specdir dir) dir)
- (if orig (file-name-nondirectory sstring) string)))
- ;; An odd number of trailing $'s
- (let* ((start (match-beginning 3))
- (env (substring string
- (cond ((= start (length string))
- ;; "...$"
- start)
- ((= (aref string start) ?{)
- ;; "...${..."
- (1+ start))
- (t
- start))))
- (head (substring string 0 (1- start))))
- (cond ((eq action 'lambda)
- nil)
- ((eq action 't)
- ;; all completions
- (mapcar (function (lambda (p)
- (if (and (> (length p) 0)
- ;;>>> Unix-specific
- ;;>>> -- need absolute-pathname-p
- (/= (aref p 0) ?/))
- (concat "$" p)
- (concat head "$" p))))
- (all-completions env (getenv t))))
- (t ;; 'nil
- ;; complete
- (let* ((e (getenv t))
- (val (try-completion env e)))
- (cond ((stringp val)
- (if (string-match "[^A-Za-z0-9_]" val)
- (concat head
- "${" val
- ;; completed uniquely?
- (if (eq (try-completion val e) 't)
- "}" ""))
- (concat head "$" val)))
- ((eql val 't)
- (concat head
- (un-substitute-in-file-name (getenv env))))
- (t nil))))))))
-
-
- (defun read-file-name-internal (string dir action)
- (read-file-name-internal-1
- string dir action
- (function (lambda (action orig string specdir dir name)
- (cond ((eq action 'lambda)
- (if (not orig)
- nil
- (let ((sstring (condition-case nil
- (expand-file-name string)
- (error nil))))
- (if (not sstring)
- ;; Some pathname syntax error in string
- nil
- (file-exists-p sstring)))))
- ((eq action 't)
- ;; all completions
- (mapcar (function un-substitute-in-file-name)
- (file-name-all-completions name dir)))
- (t;; 'nil
- ;; complete
- (or specdir (setq specdir default-directory))
- (let ((val (file-name-completion name specdir)))
- (if (and (eq val 't)
- (not (null completion-ignored-extensions)))
- ;;>> (file-name-completion "foo") returns 't
- ;; when both "foo" and "foo~" exist and the latter
- ;; is "pruned" by completion-ignored-extensions.
- ;; I think this is a bug in file-name-completion.
- (setq val (let ((completion-ignored-extensions '()))
- (file-name-completion name specdir))))
- (if (stringp val)
- (un-substitute-in-file-name (if specdir
- (concat specdir val)
- val))
- (let ((tem (un-substitute-in-file-name string)))
- (if (not (equal tem orig))
- ;; substitute-in-file-name did something
- tem
- val))))))))))
-
-
- (defun read-directory-name-internal (string dir action)
- (read-file-name-internal-1
- string dir action
- (function (lambda (action orig string specdir dir name)
- (let* (;; This looks better in a possibilities list than ""
- ;;>>>> Un*x-specific >>
- (standin "./")
- (dirs (function (lambda (fn)
- (let ((l (if (equal name "")
- (cons standin (directory-files
- dir
- nil
- ""
- nil
- 'directories))
- (directory-files
- dir
- nil
- (concat "\\`" (regexp-quote name))
- nil
- 'directories))))
- (mapcar fn
- (cond ((eq system-type 'vax-vms)
- l)
- (t
- ;; Wretched unix
- (delete "." (delete ".." l))))))))))
- (cond ((eq action 'lambda)
- ;; complete?
- (if (not orig)
- nil
- (and (file-directory-p string)
- ;; So "foo" is ambiguous between "foo/" and "foobar/"
- (equal string (file-name-as-directory string)))))
- ((eq action 't)
- ;; all completions
- (funcall dirs (function (lambda (n)
- (un-substitute-in-file-name
- (if (equal n standin)
- standin
- (file-name-as-directory n)))))))
- (t
- ;; complete
- (let ((val (try-completion
- name
- (funcall dirs
- (function (lambda (n)
- (if (equal n standin)
- (list standin)
- (list (file-name-as-directory
- n)))))))))
- (if (stringp val)
- (un-substitute-in-file-name (if specdir
- (concat specdir val)
- val))
- (let ((tem (un-substitute-in-file-name string)))
- (if (not (equal tem orig))
- ;; substitute-in-file-name did something
- tem
- val)))))))))))
-
- ;;;; Stuff which has ended up here for want of a better place
-
- (defun execute-extended-command (prefix-arg)
- (interactive "P")
- ;; Note: This doesn't hack "this-command-keys"
- (let ((prefix-arg prefix-arg))
- (setq this-command (read-command
- ;; Note: this has the hard-wired
- ;; "C-u" and "M-x" string bug in common
- ;; with all GNU Emacs's.
- (cond ((eq prefix-arg '-)
- "- M-x ")
- ((equal prefix-arg '(4))
- "C-u M-x ")
- ((integerp prefix-arg)
- (format "%d M-x " prefix-arg))
- ((and (consp prefix-arg)
- (integerp (car prefix-arg)))
- (format "%d M-x " (car prefix-arg)))
- (t
- "M-x ")))))
- (command-execute this-command t))
-
- (defun y-or-n-p-minibuf (prompt)
- "Ask user a \"y or n\" question. Return t if answer is \"y\".
- Takes one argument, which is the string to display to ask the question.
- It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
- No confirmation of the answer is requested; a single character is enough.
- Also accepts Space to mean yes, or Delete to mean no."
- (let* ((prompt (format "%s(y or n) " prompt))
- (p prompt)
- (event (allocate-event)))
- (while (stringp p)
- (if (let ((cursor-in-echo-area t)
- (inhibit-quit t))
- (message "%s" p)
- (next-command-event event)
- (prog1 quit-flag (setq quit-flag nil)))
- (progn
- (message "%s%s" p (single-key-description event))
- (deallocate-event event)
- (setq quit-flag nil)
- (signal 'quit '())))
- (let* ((key (and (key-press-event-p event) (event-key event)))
- (char (and key (event-to-character event))))
- (if char (setq char (downcase char)))
- (cond ((or (eq char ?y) (eq char ? ))
- (message "%sYes" p)
- (setq p t))
- ((or (eq char ?n) (eq key 'delete))
- (message "%sNo" p)
- (setq p nil))
- ((button-release-event-p event) ; ignore them
- nil)
- (t
- (message "%s%s" p (single-key-description event))
- (ding nil 'y-or-n-p)
- (discard-input)
- (if (eq p prompt)
- (setq p (concat "Please answer y or n. " prompt)))))))
- (deallocate-event event)
- p))
-
- (defun yes-or-no-p-minibuf (prompt)
- "Ask user a yes-or-no question. Return t if answer is yes.
- Takes one argument, which is the string to display to ask the question.
- It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
- The user must confirm the answer with RET,
- and can edit it until it as been confirmed."
- (let ((p (concat prompt "(yes or no) ")))
- (while (stringp p)
- (setq p (downcase (read-string p nil t))) ;no history
- (cond ((string-equal p "yes")
- (setq p 't))
- ((string-equal p "no")
- (setq p 'nil))
- (t
- (ding nil 'yes-or-no-p)
- (discard-input)
- (message "Please answer yes or no.")
- (sleep-for 2))))
- p))
-
- ;; these may be redefined later, but make the original def easily encapsulable
- (fset 'yes-or-no-p 'yes-or-no-p-minibuf)
- (fset 'y-or-n-p 'y-or-n-p-minibuf)
-