--- /dev/null
+;;; minibuf.el --- Minibuffer functions for XEmacs
+
+;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
+;; Copyright (C) 1995 Tinker Systems.
+;; Copyright (C) 1995, 1996, 2000 Ben Wing.
+
+;; Author: Richard Mlynarik
+;; Created: 2-Oct-92
+;; Maintainer: XEmacs Development Team
+;; Keywords: internal, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Synched up with: all the minibuffer history stuff is synched with
+;;; 19.30. Not sure about the rest.
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+;; Written by Richard Mlynarik 2-Oct-92
+
+;; 06/11/1997 - Use char-(after|before) instead of
+;; (following|preceding)-char. -slb
+
+;;; Code:
+
+(defgroup minibuffer nil
+ "Controling the behavior of the minibuffer."
+ :group 'environment)
+
+
+(defcustom insert-default-directory t
+ "*Non-nil means when reading a filename start with default dir in minibuffer."
+ :type 'boolean
+ :group 'minibuffer)
+
+(defcustom minibuffer-history-uniquify t
+ "*Non-nil means when adding an item to a minibuffer history, remove
+previous occurrences of the same item from the history list first,
+rather than just consing the new element onto the front of the list."
+ :type 'boolean
+ :group '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 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.")
+
+(defcustom 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."
+ :type 'boolean
+ :group 'minibuffer)
+
+(defcustom completion-auto-help t
+ "*Non-nil means automatically provide help for invalid completion input."
+ :type 'boolean
+ :group 'minibuffer)
+
+(defcustom 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."
+ :type 'boolean
+ :group 'minibuffer)
+
+(defcustom minibuffer-max-depth 1
+ ;; See comment in #'minibuffer-max-depth-exceeded
+ "*Global maximum number of minibuffers allowed;
+compare to enable-recursive-minibuffers, which is only consulted when the
+minibuffer is reinvoked while it is the selected window."
+ :type '(choice integer
+ (const :tag "Indefinite" nil))
+ :group 'minibuffer)
+
+;; Moved to C. The minibuffer prompt must be setup before this is run
+;; and that can only be done from the C side.
+;(defvar minibuffer-setup-hook nil
+; "Normal hook run just after entry to minibuffer.")
+
+;; see comment at list-mode-hook.
+(put 'minibuffer-setup-hook 'permanent-local t)
+
+(defvar minibuffer-exit-hook nil
+ "Normal hook run just after exit from minibuffer.")
+(put 'minibuffer-exit-hook 'permanent-local t)
+
+(defvar minibuffer-help-form nil
+ "Value that `help-form' takes on inside the minibuffer.")
+
+(defvar minibuffer-default nil
+ "Default value for minibuffer input.")
+
+(defvar minibuffer-local-map
+ (let ((map (make-sparse-keymap 'minibuffer-local-map)))
+ map)
+ "Default keymap to use when reading from the minibuffer.")
+
+(defvar minibuffer-local-completion-map
+ (let ((map (make-sparse-keymap 'minibuffer-local-completion-map)))
+ (set-keymap-parents map (list minibuffer-local-map))
+ map)
+ "Local keymap for minibuffer input with completion.")
+
+(defvar minibuffer-local-must-match-map
+ (let ((map (make-sparse-keymap 'minibuffer-must-match-map)))
+ (set-keymap-parents map (list 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 "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el
+(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 'minibuffer-local-ns-map)))
+; (set-keymap-parents map (list 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] "\M-n")
+(define-key minibuffer-local-map '[prior] "\M-p")
+(define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
+(define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
+(define-key minibuffer-local-must-match-map [next]
+ 'next-complete-history-element)
+(define-key minibuffer-local-must-match-map [prior]
+ 'previous-complete-history-element)
+
+;; This is an experiment--make up and down arrows do history.
+(define-key minibuffer-local-map [up] 'previous-history-element)
+(define-key minibuffer-local-map [down] 'next-history-element)
+(define-key minibuffer-local-completion-map [up] 'previous-history-element)
+(define-key minibuffer-local-completion-map [down] 'next-history-element)
+(define-key minibuffer-local-must-match-map [up] 'previous-history-element)
+(define-key minibuffer-local-must-match-map [down] 'next-history-element)
+
+(defvar read-expression-map (let ((map (make-sparse-keymap
+ 'read-expression-map)))
+ (set-keymap-parents map
+ (list minibuffer-local-map))
+ (define-key map "\M-\t" 'lisp-complete-symbol)
+ map)
+ "Minibuffer keymap used for reading Lisp expressions.")
+
+(defvar read-shell-command-map
+ (let ((map (make-sparse-keymap 'read-shell-command-map)))
+ (set-keymap-parents map (list minibuffer-local-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.")
+
+(defcustom use-dialog-box t
+ "*Variable controlling usage of the dialog box.
+If nil, the dialog box will never be used, even in response to mouse events."
+ :type 'boolean
+ :group 'minibuffer)
+\f
+(defcustom minibuffer-electric-file-name-behavior t
+ "*If non-nil, slash and tilde in certain places cause immediate deletion.
+These are the same places where this behavior would occur later on anyway,
+in `substitute-in-file-name'."
+ :type 'boolean
+ :group 'minibuffer)
+
+;; originally by Stig@hackvan.com
+(defun minibuffer-electric-separator ()
+ (interactive)
+ (let ((c last-command-char))
+ (and minibuffer-electric-file-name-behavior
+ (eq c directory-sep-char)
+ (eq c (char-before (point)))
+ (not (save-excursion
+ (goto-char (point-min))
+ (and (looking-at "/.+:~?[^/]*/.+")
+ (re-search-forward "^/.+:~?[^/]*" nil t)
+ (progn
+ (delete-region (point) (point-max))
+ t))))
+ (not (save-excursion
+ (goto-char (point-min))
+ (and (looking-at ".+://[^/]*/.+")
+ (re-search-forward "^.+:/" nil t)
+ (progn
+ (delete-region (point) (point-max))
+ t))))
+ ;; permit `//hostname/path/to/file'
+ (not (eq (point) (1+ (point-min))))
+ ;; permit `http://url/goes/here'
+ (or (not (eq ?: (char-after (- (point) 2))))
+ (eq ?/ (char-after (point-min))))
+ (delete-region (point-min) (point)))
+ (insert c)))
+
+(defun minibuffer-electric-tilde ()
+ (interactive)
+ (and minibuffer-electric-file-name-behavior
+ (eq directory-sep-char (char-before (point)))
+ ;; permit URL's with //, for e.g. http://hostname/~user
+ (not (save-excursion (search-backward "//" nil t)))
+ (delete-region (point-min) (point)))
+ (insert ?~))
+
+
+(defvar read-file-name-map
+ (let ((map (make-sparse-keymap 'read-file-name-map)))
+ (set-keymap-parents map (list minibuffer-local-completion-map))
+ (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
+ (define-key map "~" 'minibuffer-electric-tilde)
+ map
+ ))
+
+(defvar read-file-name-must-match-map
+ (let ((map (make-sparse-keymap 'read-file-name-map)))
+ (set-keymap-parents map (list minibuffer-local-must-match-map))
+ (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
+ (define-key map "~" 'minibuffer-electric-tilde)
+ map
+ ))
+\f
+(defun minibuffer-keyboard-quit ()
+ "Abort recursive edit.
+If `zmacs-regions' is true, and the zmacs region is active in this buffer,
+then this key deactivates the region without beeping."
+ (interactive)
+ (if (region-active-p)
+ ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
+ ;; deactivating the region. If it is inactive, beep.
+ nil
+ (abort-recursive-edit)))
+\f
+;;;; 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_frame", though I suspect I could already
+;; hack that in Lisp if I could make any sense of the
+;; complete mess of frame/frame code in XEmacs.
+;; 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 frame 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 FSF's 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)
+ (with-current-buffer buffer
+ ;(if (fboundp 'unlock-buffer) (unlock-buffer))
+ (kill-all-local-variables)
+ (setq buffer-read-only nil)
+ ;; don't let read only text yanked into the minibuffer
+ ;; permanently wedge it.
+ (make-local-variable 'inhibit-read-only)
+ (setq inhibit-read-only t)
+ (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-frame buffer nil)
+ buffer))
+
+(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)
+
+;; Added by hniksic:
+(defvar initial-minibuffer-history-position)
+(defvar current-minibuffer-contents)
+(defvar current-minibuffer-point)
+
+(defcustom minibuffer-history-minimum-string-length nil
+ "*If this variable is non-nil, a string will not be added to the
+minibuffer history if its length is less than that value."
+ :type '(choice (const :tag "Any" nil)
+ integer)
+ :group 'minibuffer)
+
+(define-error 'input-error "Keyboard input error")
+
+(put 'input-error 'display-error
+ #'(lambda (error-object stream)
+ (princ (cadr error-object) stream)))
+
+(defun read-from-minibuffer (prompt &optional initial-contents
+ keymap
+ readp
+ history
+ abbrev-table
+ default)
+ "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 while 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.
+Sixth arg ABBREV-TABLE, if non-nil, becomes the value of `local-abbrev-table'
+ in the minibuffer.
+Seventh arg DEFAULT, if non-nil, will be returned when user enters
+ an empty string.
+
+See also the variable `completion-highlight-first-word-only' for
+ control over completion display."
+ (if (and (not enable-recursive-minibuffers)
+ (> (minibuffer-depth) 0)
+ (eq (selected-window) (minibuffer-window)))
+ (error "Command attempted to use minibuffer while in minibuffer"))
+
+ (if (and minibuffer-max-depth
+ (> minibuffer-max-depth 0)
+ (>= (minibuffer-depth) minibuffer-max-depth))
+ (minibuffer-max-depth-exceeded))
+
+ ;; 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
+ ;; XEmacs in -batch mode calls minibuffer: print the prompt.
+ (message "%s" (gettext 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))
+ (oframe (selected-frame))
+ (window (minibuffer-window))
+ (buffer (if (eq (minibuffer-depth) 0)
+ (window-buffer window)
+ (get-buffer-create (format " *Minibuf-%d"
+ (minibuffer-depth)))))
+ (frame (window-frame window))
+ (mconfig (if (eq frame (selected-frame))
+ nil (current-window-configuration frame)))
+ (oconfig (current-window-configuration))
+ ;; dynamic scope sucks sucks sucks sucks sucks sucks.
+ ;; `M-x doctor' makes history a local variable, and thus
+ ;; our binding above is buffer-local and doesn't apply
+ ;; once we switch buffers!!!! We demand better scope!
+ (_history_ history)
+ (minibuffer-default default))
+ (unwind-protect
+ (progn
+ (set-buffer (reset-buffer buffer))
+ (setq default-directory dir)
+ (make-local-variable 'print-escape-newlines)
+ (setq print-escape-newlines t)
+ (make-local-variable 'current-minibuffer-contents)
+ (make-local-variable 'current-minibuffer-point)
+ (make-local-variable 'initial-minibuffer-history-position)
+ (setq current-minibuffer-contents ""
+ current-minibuffer-point 1)
+ (if (not minibuffer-smart-completion-tracking-behavior)
+ nil
+ (make-local-variable 'mode-motion-hook)
+ (or mode-motion-hook
+ ;;####disgusting
+ (setq mode-motion-hook 'minibuffer-smart-mouse-tracker))
+ (make-local-variable 'mouse-track-click-hook)
+ (add-hook 'mouse-track-click-hook
+ 'minibuffer-smart-maybe-select-highlighted-completion))
+ (set-window-buffer window buffer)
+ (select-window window)
+ (set-window-hscroll window 0)
+ (buffer-enable-undo buffer)
+ (message nil)
+ (if initial-contents
+ (if (consp initial-contents)
+ (progn
+ (insert (car initial-contents))
+ (goto-char (1+ (cdr initial-contents)))
+ (setq current-minibuffer-contents (car initial-contents)
+ current-minibuffer-point (cdr initial-contents)))
+ (insert initial-contents)
+ (setq current-minibuffer-contents initial-contents
+ current-minibuffer-point (point))))
+ (use-local-map (help-keymap-with-help-key
+ (or keymap minibuffer-local-map)
+ minibuffer-help-form))
+ (let ((mouse-grabbed-buffer
+ (and minibuffer-smart-completion-tracking-behavior
+ (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))
+ (setq initial-minibuffer-history-position
+ minibuffer-history-position)
+ (if abbrev-table
+ (setq local-abbrev-table abbrev-table
+ abbrev-mode t))
+ ;; This is now run from read-minibuffer-internal
+ ;(if minibuffer-setup-hook
+ ; (run-hooks 'minibuffer-setup-hook))
+ ;(message nil)
+ (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)
+ (if minibuffer-exit-hook
+ (run-hooks 'minibuffer-exit-hook))
+ (if (and (eq (char-after (point-min)) nil)
+ default)
+ default
+ (buffer-string))))
+ (histval (if (and default (string= val ""))
+ default
+ val))
+ (err nil))
+ (if readp
+ (condition-case e
+ (let ((v (read-from-string val)))
+ (if (< (cdr v) (length val))
+ (save-match-data
+ (or (string-match "[ \t\n]*\\'" val (cdr v))
+ (error "Trailing garbage following expression"))))
+ (setq v (car v))
+ ;; total total kludge
+ (if (stringp v) (setq v (list 'quote v)))
+ (setq val v))
+ (end-of-file
+ (setq err
+ '(input-error "End of input before end of expression")))
+ (error (setq err e))))
+ ;; Add the value to the appropriate history list unless
+ ;; it's already the most recent element, or it's only
+ ;; two characters long.
+ (if (and (symbolp minibuffer-history-variable)
+ (boundp minibuffer-history-variable))
+ (let ((list (symbol-value minibuffer-history-variable)))
+ (or (eq list t)
+ (null val)
+ (and list (equal histval (car list)))
+ (and (stringp val)
+ minibuffer-history-minimum-string-length
+ (< (length val)
+ minibuffer-history-minimum-string-length))
+ (set minibuffer-history-variable
+ (if minibuffer-history-uniquify
+ (cons histval (remove histval list))
+ (cons histval list))))))
+ (if err (signal (car err) (cdr err)))
+ val))))
+ ;; stupid display code requires this for some reason
+ (set-buffer buffer)
+ (buffer-disable-undo buffer)
+ (setq buffer-read-only nil)
+ (erase-buffer)
+
+ ;; restore frame configurations
+ (if (and mconfig (frame-live-p oframe)
+ (eq frame (selected-frame)))
+ ;; if we changed frames (due to surrogate minibuffer),
+ ;; and we're still on the new frame, go back to the old one.
+ (select-frame oframe))
+ (if mconfig (set-window-configuration mconfig))
+ (set-window-configuration oconfig))))
+
+
+(defun minibuffer-max-depth-exceeded ()
+ ;;
+ ;; This signals an error if an Nth minibuffer is invoked while N-1 are
+ ;; already active, whether the minibuffer window is selected or not.
+ ;; Since, under X, it's easy to jump out of the minibuffer (by doing M-x,
+ ;; getting distracted, and clicking elsewhere) many many novice users have
+ ;; had the problem of having multiple minibuffers build up, even to the
+ ;; point of exceeding max-lisp-eval-depth. Since the variable
+ ;; enable-recursive-minibuffers historically/crockishly is only consulted
+ ;; when the minibuffer is currently active (like typing M-x M-x) it doesn't
+ ;; help in this situation.
+ ;;
+ ;; This routine also offers to edit .emacs for you to get rid of this
+ ;; complaint, like `disabled' commands do, since it's likely that non-novice
+ ;; users will be annoyed by this change, so we give them an easy way to get
+ ;; rid of it forever.
+ ;;
+ (beep t 'minibuffer-limit-exceeded)
+ (message
+ "Minibuffer already active: abort it with `^]', enable new one with `n': ")
+ (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work??
+ (read-char))))
+ (cond
+ ((eq char ?n)
+ (cond
+ ((y-or-n-p "Enable recursive minibuffers for other sessions too? ")
+ ;; This is completely disgusting, but it's basically what novice.el
+ ;; does. This kind of thing should be generalized.
+ (setq minibuffer-max-depth nil)
+ (save-excursion
+ (set-buffer
+ (find-file-noselect
+ (substitute-in-file-name custom-file)))
+ (goto-char (point-min))
+ (if (re-search-forward
+ "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n"
+ nil t)
+ (delete-region (match-beginning 0 ) (match-end 0))
+ ;; Must have been disabled by default.
+ (goto-char (point-max)))
+ (insert"\n(setq minibuffer-max-depth nil)\n")
+ (save-buffer))
+ (message "Multiple minibuffers enabled")
+ (sit-for 1))))
+ ((eq char ?\1d)
+ (abort-recursive-edit))
+ (t
+ (error "Minibuffer already active")))))
+
+\f
+;;;; Guts of minibuffer completion
+
+
+;; Used by minibuffer-do-completion
+(defvar last-exact-completion nil)
+
+(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 (quit-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 #'(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)
+ (if tem (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))
+
+\f
+;;;; completing-read
+
+(defun completing-read (prompt table
+ &optional predicate require-match
+ initial-contents history default)
+ "Read a string in the minibuffer, with completion.
+
+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.
+TABLE can also be a function which does the completion itself.
+PREDICATE limits completion to a subset of TABLE.
+See `try-completion' and `all-completions' 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 or is null.
+ 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.
+DEFAULT, if non-nil, will be returned when the user enters an empty
+ string.
+
+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)
+ ret)
+ (setq ret (read-from-minibuffer prompt
+ initial-contents
+ (if (not require-match)
+ minibuffer-local-completion-map
+ minibuffer-local-must-match-map)
+ nil
+ history
+ nil
+ default))
+ (if (and (string= ret "")
+ default)
+ default
+ ret)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Minibuffer completion commands ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defun minibuffer-complete ()
+ "Complete the minibuffer contents as far as possible.
+Return nil if there is no valid completion, else t.
+If no characters can be completed, display a list of possible completions.
+If you repeat this command after it displayed such a list,
+scroll the window of possible completions."
+ (interactive)
+ ;; If the previous command was not this, then mark the completion
+ ;; buffer obsolete.
+ (or (eq last-command this-command)
+ (setq minibuffer-scroll-window nil))
+ (let ((window minibuffer-scroll-window))
+ (if (and window (windowp window) (window-buffer window)
+ (buffer-name (window-buffer window)))
+ ;; If there's a fresh completion window with a live buffer
+ ;; and this command is repeated, scroll that window.
+ (let ((obuf (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer (window-buffer window))
+ (if (pos-visible-in-window-p (point-max) window)
+ ;; If end is in view, scroll up to the beginning.
+ (set-window-start window (point-min))
+ ;; Else scroll down one frame.
+ (scroll-other-window)))
+ (set-buffer obuf))
+ nil)
+ (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 1)
+ (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))
+ (if completion ;; rewritten for I18N3 snarfing
+ (temp-minibuffer-message " [incomplete; confirm]")
+ (temp-minibuffer-message " [no completions; confirm]"))
+ (let ((event (let ((inhibit-quit t))
+ (prog1
+ (next-command-event)
+ (setq quit-flag nil)))))
+ (cond ((equal event last-command-event)
+ (throw 'exit nil))
+ ((equal (quit-char) (event-to-character event))
+ ;; Minibuffer abort.
+ (throw 'exit t)))
+ (dispatch-event event)))))
+\f
+;;;; 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.
+Return nil if there is no valid completion, else t."
+ (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 #'(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 (characterp 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
+ ;; rewritten for I18N3 snarfing
+ (if (eq status 'exact)
+ (temp-minibuffer-message
+ " [Complete, but not unique]")
+ (temp-minibuffer-message " [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))))))
+\f
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; "Smart minibuffer" hackery ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; ("Kludgy minibuffer hackery" is perhaps a better name)
+
+;; This works by setting `mouse-grabbed-buffer' to the minibuffer,
+;; defining button2 in the minibuffer keymap to
+;; `minibuffer-smart-select-highlighted-completion', and setting the
+;; mode-motion-hook of the minibuffer to `minibuffer-mouse-tracker'.
+;; By setting `mouse-grabbed-buffer', the minibuffer's keymap and
+;; mode-motion-hook apply (for mouse motion and presses) no matter
+;; what buffer the mouse is over. Then, `minibuffer-mouse-tracker'
+;; examines the text under the mouse looking for something that looks
+;; like a completion, and causes it to be highlighted, and
+;; `minibuffer-smart-select-highlighted-completion' looks for a
+;; flagged completion under the mouse and inserts it. This has the
+;; following advantages:
+;;
+;; -- filenames and such in any buffer can be inserted by clicking,
+;; not just completions
+;;
+;; but the following disadvantages:
+;;
+;; -- unless you're aware of the "filename in any buffer" feature,
+;; the fact that strings in arbitrary buffers get highlighted appears
+;; as a bug
+;; -- mouse motion can cause ange-ftp actions -- bad bad bad.
+;;
+;; There's some hackery in minibuffer-mouse-tracker to try to avoid the
+;; ange-ftp stuff, but it doesn't work.
+;;
+
+(defcustom minibuffer-smart-completion-tracking-behavior nil
+ "*If non-nil, look for completions under mouse in all buffers.
+This allows you to click on something that looks like a completion
+and have it selected, regardless of what buffer it is in.
+
+This is not enabled by default because
+
+-- The \"mysterious\" highlighting in normal buffers is confusing to
+ people not expecting it, and looks like a bug
+-- If ange-ftp is enabled, this tracking sometimes causes ange-ftp
+ action as a result of mouse motion, which is *bad bad bad*.
+ Hopefully this bug will be fixed at some point."
+ :type 'boolean
+ :group 'minibuffer)
+
+(defun minibuffer-smart-mouse-tracker (event)
+ ;; Used as the mode-motion-hook of the minibuffer window, which is the
+ ;; value of `mouse-grabbed-buffer' while the minibuffer is active. If
+ ;; the word under the mouse is a valid minibuffer completion, then it
+ ;; is highlighted.
+ ;;
+ ;; We do some special voodoo when we're reading a pathname, because
+ ;; the way filename completion works is funny. Possibly there's some
+ ;; more general way this could be dealt with...
+ ;;
+ ;; We do some further voodoo when reading a pathname that is an
+ ;; ange-ftp or efs path, because causing FTP activity as a result of
+ ;; mouse motion is a really bad time.
+ ;;
+ (and minibuffer-smart-completion-tracking-behavior
+ (event-point event)
+ ;; avoid conflict with display-completion-list extents
+ (not (extent-at (event-point event)
+ (event-buffer event)
+ 'list-mode-item))
+ (let ((filename-kludge-p (eq minibuffer-completion-table
+ 'read-file-name-internal)))
+ (mode-motion-highlight-internal
+ event
+ #'(lambda () (default-mouse-track-beginning-of-word
+ (if filename-kludge-p 'nonwhite t)))
+ #'(lambda ()
+ (let ((p (point))
+ (string ""))
+ (default-mouse-track-end-of-word
+ (if filename-kludge-p 'nonwhite t))
+ (if (and (/= p (point)) minibuffer-completion-table)
+ (setq string (buffer-substring p (point))))
+ (if (string-match "\\`[ \t\n]*\\'" string)
+ (goto-char p)
+ (if filename-kludge-p
+ (setq string (minibuffer-smart-select-kludge-filename
+ string)))
+ ;; try-completion bogusly returns a string even when
+ ;; that string is complete if that string is also a
+ ;; prefix for other completions. This means that we
+ ;; can't just do the obvious thing, (eq t
+ ;; (try-completion ...)).
+ (let (comp)
+ (if (and filename-kludge-p
+ ;; #### evil evil evil evil
+ (or (and (fboundp 'ange-ftp-ftp-path)
+ (ange-ftp-ftp-path string))
+ (and (fboundp 'efs-ftp-path)
+ (efs-ftp-path string))))
+ (setq comp t)
+ (setq comp
+ (try-completion string
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
+ (or (eq comp t)
+ (and (equal comp string)
+ (or (null minibuffer-completion-predicate)
+ (stringp
+ minibuffer-completion-predicate) ; ???
+ (funcall minibuffer-completion-predicate
+ (if (vectorp
+ minibuffer-completion-table)
+ (intern-soft
+ string
+ minibuffer-completion-table)
+ string))))
+ (goto-char p))))))))))
+
+(defun minibuffer-smart-select-kludge-filename (string)
+ (save-excursion
+ (set-buffer mouse-grabbed-buffer) ; the minibuf
+ (let ((kludge-string (concat (buffer-string) string)))
+ (if (or (and (fboundp 'ange-ftp-ftp-path)
+ (ange-ftp-ftp-path kludge-string))
+ (and (fboundp 'efs-ftp-path) (efs-ftp-path kludge-string)))
+ ;; #### evil evil evil, but more so.
+ string
+ (append-expand-filename (buffer-string) string)))))
+
+(defun minibuffer-smart-select-highlighted-completion (event)
+ "Select the highlighted text under the mouse as a minibuffer response.
+When the minibuffer is being used to prompt the user for a completion,
+any valid completions which are visible on the frame will highlight
+when the mouse moves over them. Clicking \\<minibuffer-local-map>\
+\\[minibuffer-smart-select-highlighted-completion] will select the
+highlighted completion under the mouse.
+
+If the mouse is clicked while not over a highlighted completion,
+then the global binding of \\[minibuffer-smart-select-highlighted-completion] \
+will be executed instead. In this\nway you can get at the normal global \
+behavior of \\[minibuffer-smart-select-highlighted-completion] as well as
+the special minibuffer behavior."
+ (interactive "e")
+ (if minibuffer-smart-completion-tracking-behavior
+ (minibuffer-smart-select-highlighted-completion-1 event t)
+ (let ((command (lookup-key global-map
+ (vector current-mouse-event))))
+ (if command (call-interactively command)))))
+
+(defun minibuffer-smart-select-highlighted-completion-1 (event global-p)
+ (let* ((filename-kludge-p (eq minibuffer-completion-table
+ 'read-file-name-internal))
+ completion
+ command-p
+ (evpoint (event-point event))
+ (evextent (and evpoint (extent-at evpoint (event-buffer event)
+ 'list-mode-item))))
+ (if evextent
+ ;; avoid conflict with display-completion-list extents.
+ ;; if we find one, do that behavior instead.
+ (list-mode-item-selected-1 evextent event)
+ (save-excursion
+ (let* ((buffer (window-buffer (event-window event)))
+ (p (event-point event))
+ (extent (and p (extent-at p buffer 'mouse-face))))
+ (set-buffer buffer)
+ (if (not (and (extent-live-p extent)
+ (eq (extent-object extent) (current-buffer))
+ (not (extent-detached-p extent))))
+ (setq command-p t)
+ ;; ...else user has selected a highlighted completion.
+ (setq completion
+ (buffer-substring (extent-start-position extent)
+ (extent-end-position extent)))
+ (if filename-kludge-p
+ (setq completion (minibuffer-smart-select-kludge-filename
+ completion)))
+ ;; remove the extent so that it's not hanging around in
+ ;; *Completions*
+ (detach-extent extent)
+ (set-buffer mouse-grabbed-buffer)
+ (erase-buffer)
+ (insert completion))))
+ ;; we need to execute the command or do the throw outside of the
+ ;; save-excursion.
+ (cond ((and command-p global-p)
+ (let ((command (lookup-key global-map
+ (vector current-mouse-event))))
+ (if command
+ (call-interactively command)
+ (if minibuffer-completion-table
+ (error
+ "Highlighted words are valid completions. You may select one.")
+ (error "no completions")))))
+ ((not command-p)
+ ;; things get confused if the minibuffer is terminated while
+ ;; not selected.
+ (select-window (minibuffer-window))
+ (if (and filename-kludge-p (file-directory-p completion))
+ ;; if the user clicked middle on a directory name, display the
+ ;; files in that directory.
+ (progn
+ (goto-char (point-max))
+ (minibuffer-completion-help))
+ ;; otherwise, terminate input
+ (throw 'exit nil)))))))
+
+(defun minibuffer-smart-maybe-select-highlighted-completion
+ (event &optional click-count)
+ "Like `minibuffer-smart-select-highlighted-completion' but does nothing if
+there is no completion (as opposed to executing the global binding). Useful
+as the value of `mouse-track-click-hook'."
+ (interactive "e")
+ (minibuffer-smart-select-highlighted-completion-1 event nil))
+
+(define-key minibuffer-local-map 'button2
+ 'minibuffer-smart-select-highlighted-completion)
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; 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 function-history '())
+(defvar variable-history '())
+(defvar buffer-history '())
+(defvar shell-command-history '())
+(defvar file-name-history '())
+
+(defvar read-expression-history nil)
+
+(defvar minibuffer-history-sexp-flag nil ;weird FSF 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.")
+
+(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)
+ (minibuffer-max-depth (and minibuffer-max-depth
+ (1+ minibuffer-max-depth))))
+ (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): "
+ (car minibuffer-history-search-history)
+ 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)
+ (if (= pos 1) ;; rewritten for I18N3 snarfing
+ (error "No later matching history item")
+ (error "No earlier matching history item")))
+ (if (string-match regexp
+ (if minibuffer-history-sexp-flag
+ (let ((print-level nil))
+ (prin1-to-string (nth (1- pos) history)))
+ (nth (1- pos) history)))
+ (setq n (+ n (if (< n 0) 1 -1)))))
+ (setq minibuffer-history-position pos)
+ (setq current-minibuffer-contents (buffer-string)
+ current-minibuffer-point (point))
+ (erase-buffer)
+ (let ((elt (nth (1- pos) history)))
+ (insert (if minibuffer-history-sexp-flag
+ (let ((print-level nil))
+ (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)
+ (minibuffer-max-depth (and minibuffer-max-depth
+ (1+ minibuffer-max-depth))))
+ (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): "
+ (car minibuffer-history-search-history)
+ 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"))
+ (unless (zerop n)
+ (when (eq minibuffer-history-position
+ initial-minibuffer-history-position)
+ (setq current-minibuffer-contents (buffer-string)
+ current-minibuffer-point (point)))
+ (let ((narg (- minibuffer-history-position n))
+ (minimum (if minibuffer-default -1 0)))
+ ;; a weird special case here; when in repeat-complex-command, we're
+ ;; trying to edit the top command, and minibuffer-history-position
+ ;; points to 1, the next-to-top command. in this case, the top
+ ;; command in the history is suppressed in favor of the one being
+ ;; edited, and there is no more command below it, except maybe the
+ ;; default.
+ (if (and (zerop narg) (eq minibuffer-history-position
+ initial-minibuffer-history-position))
+ (setq minimum (1+ minimum)))
+ (cond ((< narg minimum)
+ (error (if minibuffer-default
+ "No following item in %s"
+ "No following item in %s; no default available")
+ minibuffer-history-variable))
+ ((> narg (length (symbol-value minibuffer-history-variable)))
+ (error "No preceding item in %s" minibuffer-history-variable)))
+ (erase-buffer)
+ (setq minibuffer-history-position narg)
+ (if (eq narg initial-minibuffer-history-position)
+ (progn
+ (insert current-minibuffer-contents)
+ (goto-char current-minibuffer-point))
+ (let ((elt (if (> narg 0)
+ (nth (1- minibuffer-history-position)
+ (symbol-value minibuffer-history-variable))
+ minibuffer-default)))
+ (insert
+ (if (not (stringp elt))
+ (let ((print-level nil))
+ (condition-case nil
+ (let ((print-readably t)
+ (print-escape-newlines t))
+ (prin1-to-string elt))
+ (error (prin1-to-string elt))))
+ elt)))
+ ;; FSF has point-min here.
+ (goto-char (point-max))))))
+
+(defun previous-history-element (n)
+ "Insert the previous element of the minibuffer history into the minibuffer."
+ (interactive "p")
+ (next-history-element (- n)))
+
+(defun next-complete-history-element (n)
+ "Get next element of history which is a completion of minibuffer contents."
+ (interactive "p")
+ (let ((point-at-start (point)))
+ (next-matching-history-element
+ (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n)
+ ;; next-matching-history-element always puts us at (point-min).
+ ;; Move to the position we were at before changing the buffer contents.
+ ;; This is still sensical, because the text before point has not changed.
+ (goto-char point-at-start)))
+
+(defun previous-complete-history-element (n)
+ "Get previous element of history which is a completion of minibuffer contents."
+ (interactive "p")
+ (next-complete-history-element (- n)))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; reading various things from a minibuffer ;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun read-expression (prompt &optional initial-contents history default-value)
+ "Return a Lisp object read using the minibuffer, prompting 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.
+Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ for history command, and as the value to return if the user enters the
+ empty string."
+ (let ((minibuffer-history-sexp-flag t)
+ ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion.
+ (minibuffer-completion-table nil))
+ (read-from-minibuffer prompt
+ initial-contents
+ read-expression-map
+ t
+ (or history 'read-expression-history)
+ lisp-mode-abbrev-table
+ default-value)))
+
+(defun read-string (prompt &optional initial-contents history default-value)
+ "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.
+Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ for history command, and as the value to return if the user enters the
+ empty string."
+ (let ((minibuffer-completion-table nil))
+ (read-from-minibuffer prompt
+ initial-contents
+ minibuffer-local-map
+ nil history nil default-value)))
+
+(defun eval-minibuffer (prompt &optional initial-contents history default-value)
+ "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.
+Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ for history command, and as the value to return if the user enters the
+ empty string."
+ (eval (read-expression prompt initial-contents history default-value)))
+
+;; The name `command-history' is already taken
+(defvar read-command-history '())
+
+(defun read-command (prompt &optional default-value)
+ "Read the name of a command and return as a symbol.
+Prompts with PROMPT. By default, return DEFAULT-VALUE."
+ (intern (completing-read prompt obarray 'commandp t nil
+ ;; 'command-history is not right here: that's a
+ ;; list of evalable forms, not a history list.
+ 'read-command-history
+ default-value)))
+
+(defun read-function (prompt &optional default-value)
+ "Read the name of a function and return as a symbol.
+Prompts with PROMPT. By default, return DEFAULT-VALUE."
+ (intern (completing-read prompt obarray 'fboundp t nil
+ 'function-history default-value)))
+
+(defun read-variable (prompt &optional default-value)
+ "Read the name of a user variable and return it as a symbol.
+Prompts with PROMPT. By default, return DEFAULT-VALUE.
+A user variable is one whose documentation starts with a `*' character."
+ (intern (completing-read prompt obarray 'user-variable-p t nil
+ 'variable-history
+ (if (symbolp default-value)
+ (symbol-name default-value)
+ default-value))))
+
+(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) "
+ (gettext prompt) (if (bufferp default)
+ (buffer-name default)
+ default))
+ prompt))
+ (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
+ (buffer-list)))
+ result)
+ (while (progn
+ (setq result (completing-read prompt alist nil require-match
+ nil 'buffer-history
+ (if (bufferp default)
+ (buffer-name default)
+ default)))
+ (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 default-value)
+ "Read a number from the minibuffer, prompting with PROMPT.
+If optional second argument INTEGERS-ONLY is non-nil, accept
+ only integer input.
+If DEFAULT-VALUE is non-nil, return that if user enters an empty
+ line."
+ (let ((pred (if integers-only 'integerp 'numberp))
+ num)
+ (while (not (funcall pred num))
+ (setq num (condition-case ()
+ (let ((minibuffer-completion-table nil))
+ (read-from-minibuffer
+ prompt (if num (prin1-to-string num)) nil t
+ nil nil default-value))
+ (input-error nil)
+ (invalid-read-syntax nil)
+ (end-of-file nil)))
+ (or (funcall pred num) (beep)))
+ num))
+
+(defun read-shell-command (prompt &optional initial-input history default-value)
+ "Just like read-string, but uses read-shell-command-map:
+\\{read-shell-command-map}"
+ (let ((minibuffer-completion-table nil))
+ (read-from-minibuffer prompt initial-input read-shell-command-map
+ nil (or history 'shell-command-history)
+ nil default-value)))
+
+\f
+;;; 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)
+ (if (not (string-match regexp string))
+ string
+ (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)))
+
+
+;; Wrapper for `directory-files' for use in generating completion lists.
+;; Generates output in the same format as `file-name-all-completions'.
+;;
+;; The EFS replacement for `directory-files' doesn't support the FILES-ONLY
+;; option, so it has to be faked. The listing cache will hopefully
+;; improve the performance of this operation.
+(defun minibuf-directory-files (dir &optional match-regexp files-only)
+ (let ((want-file (or (eq files-only nil) (eq files-only t)))
+ (want-dirs (or (eq files-only nil) (not (eq files-only t)))))
+ (delete nil
+ (mapcar (function (lambda (f)
+ (if (file-directory-p (expand-file-name f dir))
+ (and want-dirs (file-name-as-directory f))
+ (and want-file f))))
+ (delete "." (directory-files dir nil match-regexp))))))
+
+
+(defun read-file-name-2 (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 ((and (not insert-default-directory)
+ (not initial-contents))
+ "")
+ (initial-contents
+ (cons (un-substitute-in-file-name
+ (concat dir initial-contents))
+ (length dir)))
+ (t
+ (un-substitute-in-file-name dir))))
+ (val
+ ;; Hateful, broken, case-sensitive un*x
+;;; (completing-read prompt
+;;; completer
+;;; dir
+;;; must-match
+;;; insert
+;;; history)
+ ;; #### - this is essentially the guts of completing read.
+ ;; There should be an elegant way to pass a pair of keymaps to
+ ;; completing read, but this will do for now. All sins are
+ ;; relative. --Stig
+ (let ((minibuffer-completion-table completer)
+ (minibuffer-completion-predicate dir)
+ (minibuffer-completion-confirm (if (eq must-match 't)
+ nil t))
+ (last-exact-completion nil))
+ (read-from-minibuffer prompt
+ insert
+ (if (not must-match)
+ read-file-name-map
+ read-file-name-must-match-map)
+ nil
+ history
+ nil
+ default))))
+;;; ;; 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)))))
+
+;; #### this function should use minibuffer-completion-table
+;; or something. But that is sloooooow.
+;; #### all this shit needs better documentation!!!!!!!!
+(defun read-file-name-activate-callback (event extent dir-p)
+ ;; used as the activate-callback of the filename list items
+ ;; in the completion buffer, in place of default-choose-completion.
+ ;; if a regular file was selected, we call default-choose-completion
+ ;; (which just inserts the string in the minibuffer and calls
+ ;; exit-minibuffer). If a directory was selected, we display
+ ;; the contents of the directory.
+ (let* ((file (extent-string extent))
+ (completion-buf (extent-object extent))
+ (minibuf (symbol-value-in-buffer 'completion-reference-buffer
+ completion-buf))
+ (in-dir (file-name-directory (buffer-substring nil nil minibuf)))
+ (full (expand-file-name file in-dir)))
+ (if (not (file-directory-p full))
+ (default-choose-completion event extent minibuf)
+ (erase-buffer minibuf)
+ (insert-string (file-name-as-directory
+ (abbreviate-file-name full t)) minibuf)
+ (reset-buffer completion-buf)
+ (let ((standard-output completion-buf))
+ (display-completion-list
+ (minibuf-directory-files full nil (if dir-p 'directory))
+ :user-data dir-p
+ :reference-buffer minibuf
+ :activate-callback 'read-file-name-activate-callback)
+ (goto-char (point-min) completion-buf)))))
+
+(defun read-file-name-1 (type history prompt dir default
+ must-match initial-contents
+ completer)
+ (if (should-use-dialog-box-p)
+ (condition-case nil
+ (let ((file
+ (apply #'make-dialog-box
+ type `(:title ,(capitalize-string-as-title
+ ;; Kludge: Delete ": " off the end.
+ (replace-in-string prompt ": $" ""))
+ ,@(and dir (list :initial-directory
+ dir))
+ :file-must-exist ,must-match
+ ,@(and initial-contents
+ (list :initial-filename
+ initial-contents))))))
+ ;; hack -- until we implement reading a directory properly,
+ ;; allow a file as indicating the directory it's in
+ (if (and (eq completer 'read-directory-name-internal)
+ (not (file-directory-p file)))
+ (file-name-directory file)
+ file))
+ (unimplemented
+ ;; this calls read-file-name-2
+ (mouse-read-file-name-1 history prompt dir default must-match
+ initial-contents completer)
+ ))
+ (add-one-shot-hook
+ 'minibuffer-setup-hook
+ (lambda ()
+ ;; #### SCREAM! Create a `file-system-ignore-case'
+ ;; function, so this kind of stuff is generalized!
+ (and (eq system-type 'windows-nt)
+ (set (make-local-variable 'completion-ignore-case) t))
+ (set
+ (make-local-variable
+ 'completion-display-completion-list-function)
+ #'(lambda (completions)
+ (display-completion-list
+ completions
+ :user-data (not (eq completer 'read-file-name-internal))
+ :activate-callback
+ 'read-file-name-activate-callback)))))
+ (read-file-name-2 history prompt dir default must-match
+ initial-contents completer)))
+
+(defun read-file-name (prompt
+ &optional dir default must-match initial-contents
+ history)
+ "Read file name, prompting with PROMPT and completing in directory DIR.
+This will prompt with a dialog box if appropriate, according to
+ `should-use-dialog-box-p'.
+Value is not expanded---you must call `expand-file-name' yourself.
+Value is subject to interpretation 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,
+ except that if INITIAL-CONTENTS is specified, that combined with DIR 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. If this is not
+ specified, and `insert-default-directory' is non-nil, DIR or the current
+ directory will be used.
+Sixth arg HISTORY specifies the history list to use. Default is
+ `file-name-history'.
+DIR defaults to current buffer's directory default."
+ (read-file-name-1
+ 'file (or history 'file-name-history)
+ prompt dir (or default
+ (and initial-contents
+ (abbreviate-file-name (expand-file-name
+ initial-contents dir) t))
+ (and buffer-file-truename
+ (abbreviate-file-name buffer-file-name t)))
+ 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
+ history)
+ "Read directory name, prompting with PROMPT and completing in directory DIR.
+This will prompt with a dialog box if appropriate, according to
+ `should-use-dialog-box-p'.
+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 current buffer's default directory is used.)
+Fourth arg MUST-MATCH non-nil means require existing directory'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
+ `file-name-history'.
+DIR defaults to current buffer's directory default."
+ (read-file-name-1
+ 'directory (or history 'file-name-history)
+ prompt dir (or default default-directory) must-match initial-contents
+ 'read-directory-name-internal))
+
+
+;; Environment-variable and ~username 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))
+ (name (if orig (file-name-nondirectory sstring) string))
+ (direct (if specdir (expand-file-name specdir dir) dir)))
+ ;; ~username completion
+ (if (and (fboundp 'user-name-completion-1)
+ (string-match "^[~]" name))
+ (let ((user (substring name 1)))
+ (cond ((eq action 'lambda)
+ (file-directory-p name))
+ ((eq action 't)
+ ;; all completions
+ (mapcar #'(lambda (p) (concat "~" p))
+ (user-name-all-completions user)))
+ (t;; 'nil
+ ;; complete
+ (let* ((val+uniq (user-name-completion-1 user))
+ (val (car val+uniq))
+ (uniq (cdr val+uniq)))
+ (cond ((stringp val)
+ (if uniq
+ (file-name-as-directory (concat "~" val))
+ (concat "~" val)))
+ ((eq val t)
+ (file-name-as-directory name))
+ (t nil))))))
+ (funcall completer
+ action
+ orig
+ sstring
+ specdir
+ direct
+ name)))
+ ;; 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)))
+ (alist #'(lambda ()
+ (mapcar #'(lambda (x)
+ (cons (substring x 0 (string-match "=" x))
+ nil))
+ process-environment))))
+
+ (cond ((eq action 'lambda)
+ nil)
+ ((eq action 't)
+ ;; all completions
+ (mapcar #'(lambda (p)
+ (if (and (> (length p) 0)
+ ;;#### Unix-specific
+ ;;#### -- need absolute-pathname-p
+ (/= (aref p 0) ?/))
+ (concat "$" p)
+ (concat head "$" p)))
+ (all-completions env (funcall alist))))
+ (t ;; nil
+ ;; complete
+ (let* ((e (funcall alist))
+ (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
+ #'(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 #'un-substitute-in-file-name
+ (if (string= name "")
+ (delete "./" (file-name-all-completions "" dir))
+ (file-name-all-completions name dir))))
+ (t;; nil
+ ;; complete
+ (let* ((d (or dir default-directory))
+ (val (file-name-completion name d)))
+ (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 d))))
+ (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
+ #'(lambda (action orig string specdir dir name)
+ (let* ((dirs #'(lambda (fn)
+ (let ((l (if (equal name "")
+ (minibuf-directory-files
+ dir
+ ""
+ 'directories)
+ (minibuf-directory-files
+ dir
+ (concat "\\`" (regexp-quote name))
+ 'directories))))
+ (mapcar fn
+ ;; Wretched unix
+ (delete "." l))))))
+ (cond ((eq action 'lambda)
+ ;; complete?
+ (if (not orig)
+ nil
+ (file-directory-p string)))
+ ((eq action 't)
+ ;; all completions
+ (funcall dirs #'(lambda (n)
+ (un-substitute-in-file-name
+ (file-name-as-directory n)))))
+ (t
+ ;; complete
+ (let ((val (try-completion
+ name
+ (funcall dirs
+ #'(lambda (n)
+ (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))))))))))
+
+(defun append-expand-filename (file-string string)
+ "Append STRING to FILE-STRING differently depending on whether STRING
+is a username (~string), an environment variable ($string),
+or a filename (/string). The resultant string is returned with the
+environment variable or username expanded and resolved to indicate
+whether it is a file(/result) or a directory (/result/)."
+ (let ((file
+ (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string)
+ (cond ((string= (substring file-string
+ (match-beginning 1)
+ (match-end 1)) "~")
+ (concat (substring file-string 0 (match-end 1))
+ string))
+ (t (substitute-in-file-name
+ (concat (substring file-string 0 (match-end 1))
+ string)))))
+ (t (concat (file-name-directory
+ (substitute-in-file-name file-string)) string))))
+ result)
+
+ (cond ((stringp (setq result (and (file-exists-p (expand-file-name file))
+ (read-file-name-internal
+ (condition-case nil
+ (expand-file-name file)
+ (error file))
+ "" nil))))
+ result)
+ (t file))))
+
+(defun mouse-rfn-setup-vars (prompt)
+ ;; a specifier would be nice.
+ (set (make-local-variable 'frame-title-format)
+ (capitalize-string-as-title
+ ;; Kludge: Delete ": " off the end.
+ (replace-in-string prompt ": $" "")))
+ ;; ensure that killing the frame works right,
+ ;; instead of leaving us in the minibuffer.
+ (add-local-hook 'delete-frame-hook
+ #'(lambda (frame)
+ (abort-recursive-edit))))
+
+(defun mouse-file-display-completion-list (window dir minibuf user-data)
+ (let ((standard-output (window-buffer window)))
+ (condition-case nil
+ (display-completion-list
+ (minibuf-directory-files dir nil t)
+ :window-width (window-width window)
+ :window-height (window-text-area-height window)
+ :completion-string ""
+ :activate-callback
+ 'mouse-read-file-name-activate-callback
+ :user-data user-data
+ :reference-buffer minibuf
+ :help-string "")
+ (t nil))
+ ))
+
+(defun mouse-directory-display-completion-list (window dir minibuf user-data)
+ (let ((standard-output (window-buffer window)))
+ (condition-case nil
+ (display-completion-list
+ (minibuf-directory-files dir nil 1)
+ :window-width (window-width window)
+ :window-height (window-text-area-height window)
+ :completion-string ""
+ :activate-callback
+ 'mouse-read-file-name-activate-callback
+ :user-data user-data
+ :reference-buffer minibuf
+ :help-string "")
+ (t nil))
+ ))
+
+(defun mouse-read-file-name-activate-callback (event extent user-data)
+ (let* ((file (extent-string extent))
+ (minibuf (symbol-value-in-buffer 'completion-reference-buffer
+ (extent-object extent)))
+ (ministring (buffer-substring nil nil minibuf))
+ (in-dir (file-name-directory ministring))
+ (full (expand-file-name file in-dir))
+ (filebuf (nth 0 user-data))
+ (dirbuf (nth 1 user-data))
+ (filewin (nth 2 user-data))
+ (dirwin (nth 3 user-data)))
+ (if (file-regular-p full)
+ (default-choose-completion event extent minibuf)
+ (erase-buffer minibuf)
+ (insert-string (file-name-as-directory
+ (abbreviate-file-name full t)) minibuf)
+ (reset-buffer filebuf)
+ (if (not dirbuf)
+ (mouse-directory-display-completion-list filewin full minibuf
+ user-data)
+ (mouse-file-display-completion-list filewin full minibuf user-data)
+ (reset-buffer dirbuf)
+ (mouse-directory-display-completion-list dirwin full minibuf
+ user-data)))))
+
+;; our cheesy but god-awful time consuming file dialog box implementation.
+;; this will be replaced with use of the native file dialog box (when
+;; available).
+(defun mouse-read-file-name-1 (history prompt dir default
+ must-match initial-contents
+ completer)
+ ;; file-p is t if we're reading files, nil if directories.
+ (let* ((file-p (eq 'read-file-name-internal completer))
+ (filebuf (get-buffer-create "*Completions*"))
+ (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*")))
+ (butbuf (generate-new-buffer " *mouse-read-file*"))
+ (frame (make-dialog-frame))
+ filewin dirwin
+ user-data)
+ (unwind-protect
+ (progn
+ (reset-buffer filebuf)
+
+ ;; set up the frame.
+ (focus-frame frame)
+ (let ((window-min-height 1))
+ ;; #### should be 2 not 3, but that causes
+ ;; "window too small to split" errors for some
+ ;; people (but not for me ...) There's a more
+ ;; fundamental bug somewhere.
+ (split-window nil (- (frame-height frame) 3)))
+ (if file-p
+ (progn
+ (split-window-horizontally 16)
+ (setq filewin (frame-rightmost-window frame)
+ dirwin (frame-leftmost-window frame))
+ (set-window-buffer filewin filebuf)
+ (set-window-buffer dirwin dirbuf))
+ (setq filewin (frame-highest-window frame))
+ (set-window-buffer filewin filebuf))
+ (setq user-data (list filebuf dirbuf filewin dirwin))
+ (set-window-buffer (frame-lowest-window frame) butbuf)
+
+ ;; set up completion buffers.
+ (let ((rfcshookfun
+ ;; kludge!
+ ;; #### I really need to flesh out the object
+ ;; hierarchy better to avoid these kludges.
+ ;; (?? I wrote this comment above some time ago,
+ ;; and I don't understand what I'm referring to
+ ;; any more. --ben
+ (lambda ()
+ (mouse-rfn-setup-vars prompt)
+ (when (featurep 'scrollbar)
+ (set-specifier scrollbar-width 0 (current-buffer)))
+ (setq truncate-lines t))))
+
+ (set-buffer filebuf)
+ (add-local-hook 'completion-setup-hook rfcshookfun)
+ (when file-p
+ (set-buffer dirbuf)
+ (add-local-hook 'completion-setup-hook rfcshookfun)))
+
+ ;; set up minibuffer.
+ (add-one-shot-hook
+ 'minibuffer-setup-hook
+ (lambda ()
+ (if (not file-p)
+ (mouse-directory-display-completion-list
+ filewin dir (current-buffer) user-data)
+ (mouse-file-display-completion-list
+ filewin dir (current-buffer) user-data)
+ (mouse-directory-display-completion-list
+ dirwin dir (current-buffer) user-data))
+ (set
+ (make-local-variable
+ 'completion-display-completion-list-function)
+ (lambda (completions)
+ (display-completion-list
+ completions
+ :help-string ""
+ :window-width (window-width filewin)
+ :window-height (window-text-area-height filewin)
+ :completion-string ""
+ :activate-callback
+ 'mouse-read-file-name-activate-callback
+ :user-data user-data)))
+ (mouse-rfn-setup-vars prompt)
+ (save-selected-window
+ ;; kludge to ensure the frame title is correct.
+ ;; the minibuffer leaves the frame title the way
+ ;; it was before (i.e. of the selected window before
+ ;; the dialog box was opened), so to get it correct
+ ;; we have to be tricky.
+ (select-window filewin)
+ (redisplay-frame nil t)
+ ;; #### another kludge. sometimes the focus ends up
+ ;; back in the main window, not the dialog box. it
+ ;; occurs randomly and it's not possible to reliably
+ ;; reproduce. We try to fix it by draining non-user
+ ;; events and then setting the focus back on the frame.
+ (sit-for 0 t)
+ (focus-frame frame))))
+
+ ;; set up button buffer.
+ (set-buffer butbuf)
+ (mouse-rfn-setup-vars prompt)
+ (when dir
+ (setq default-directory dir))
+ (when (featurep 'scrollbar)
+ (set-specifier scrollbar-width 0 butbuf))
+ (insert " ")
+ (insert-gui-button (make-gui-button "OK"
+ (lambda (foo)
+ (exit-minibuffer))))
+ (insert " ")
+ (insert-gui-button (make-gui-button "Cancel"
+ (lambda (foo)
+ (abort-recursive-edit))))
+
+ ;; now start reading filename.
+ (read-file-name-2 history prompt dir default
+ must-match initial-contents
+ completer))
+
+ ;; always clean up.
+ ;; get rid of our hook that calls abort-recursive-edit -- not a good
+ ;; idea here.
+ (kill-local-variable 'delete-frame-hook)
+ (delete-frame frame)
+ (kill-buffer filebuf)
+ (kill-buffer butbuf)
+ (and dirbuf (kill-buffer dirbuf)))))
+
+(defun read-face (prompt &optional must-match)
+ "Read the name of a face from the minibuffer and return it as a symbol."
+ (intern (completing-read prompt obarray 'find-face must-match)))
+
+;; #### - wrong place for this variable? Exactly. We probably want
+;; `color-list' to be a console method, so `tty-color-list' becomes
+;; obsolete, and `read-color-completion-table' conses (mapcar #'list
+;; (color-list)), optionally caching the results.
+
+;; Ben wanted all of the possibilities from the `configure' script used
+;; here, but I think this is way too many. I already trimmed the R4 variants
+;; and a few obvious losers from the list. --Stig
+(defvar x-library-search-path '("/usr/X11R6/lib/X11/"
+ "/usr/X11R5/lib/X11/"
+ "/usr/lib/X11R6/X11/"
+ "/usr/lib/X11R5/X11/"
+ "/usr/local/X11R6/lib/X11/"
+ "/usr/local/X11R5/lib/X11/"
+ "/usr/local/lib/X11R6/X11/"
+ "/usr/local/lib/X11R5/X11/"
+ "/usr/X11/lib/X11/"
+ "/usr/lib/X11/"
+ "/usr/local/lib/X11/"
+ "/usr/X386/lib/X11/"
+ "/usr/x386/lib/X11/"
+ "/usr/XFree86/lib/X11/"
+ "/usr/unsupported/lib/X11/"
+ "/usr/athena/lib/X11/"
+ "/usr/local/x11r5/lib/X11/"
+ "/usr/lpp/Xamples/lib/X11/"
+ "/usr/openwin/lib/X11/"
+ "/usr/openwin/share/lib/X11/")
+ "Search path used by `read-color' to find rgb.txt.")
+
+(defvar x-read-color-completion-table)
+
+(defun read-color-completion-table ()
+ (case (device-type)
+ ;; #### Evil device-type dependency
+ ((x gtk)
+ (if (boundp 'x-read-color-completion-table)
+ x-read-color-completion-table
+ (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
+ clist color p)
+ (if (not rgb-file)
+ ;; prevents multiple searches for rgb.txt if we can't find it
+ (setq x-read-color-completion-table nil)
+ (with-current-buffer (get-buffer-create " *colors*")
+ (reset-buffer (current-buffer))
+ (insert-file-contents rgb-file)
+ (while (not (eobp))
+ ;; skip over comments
+ (while (looking-at "^!")
+ (end-of-line)
+ (forward-char 1))
+ (skip-chars-forward "0-9 \t")
+ (setq p (point))
+ (end-of-line)
+ (setq color (buffer-substring p (point))
+ clist (cons (list color) clist))
+ ;; Ugh. If we want to be able to complete the lowercase form
+ ;; of the color name, we need to add it twice! Yuck.
+ (let ((dcase (downcase color)))
+ (or (string= dcase color)
+ (push (list dcase) clist)))
+ (forward-char 1))
+ (kill-buffer (current-buffer))))
+ (setq x-read-color-completion-table clist)
+ x-read-color-completion-table)))
+ (mswindows
+ (mapcar #'list (mswindows-color-list)))
+ (tty
+ (mapcar #'list (tty-color-list)))))
+
+(defun read-color (prompt &optional must-match initial-contents)
+ "Read the name of a color from the minibuffer.
+On X devices, this uses `x-library-search-path' to find rgb.txt in order
+ to build a completion table.
+On TTY devices, this uses `tty-color-list'.
+On mswindows devices, this uses `mswindows-color-list'."
+ (let ((table (read-color-completion-table)))
+ (completing-read prompt table nil (and table must-match)
+ initial-contents)))
+
+\f
+;; #### The doc string for read-non-nil-coding system gets lost if we
+;; only include these if the mule feature is present. Strangely,
+;; read-coding-system doesn't.
+
+;;(if (featurep 'mule)
+
+(defun read-coding-system (prompt &optional default-coding-system)
+ "Read a coding-system (or nil) from the minibuffer.
+Prompting with string PROMPT.
+If the user enters null input, return second argument DEFAULT-CODING-SYSTEM.
+DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object."
+ (intern (completing-read prompt obarray 'find-coding-system t nil nil
+ (cond ((symbolp default-coding-system)
+ (symbol-name default-coding-system))
+ ((coding-system-p default-coding-system)
+ (symbol-name (coding-system-name default-coding-system)))
+ (t
+ default-coding-system)))))
+
+(defun read-non-nil-coding-system (prompt)
+ "Read a non-nil coding-system from the minibuffer.
+Prompt with string PROMPT."
+ (let ((retval (intern "")))
+ (while (= 0 (length (symbol-name retval)))
+ (setq retval (intern (completing-read prompt obarray
+ 'find-coding-system
+ t))))
+ retval))
+
+;;) ;; end of (featurep 'mule)
+
+\f
+
+(defcustom force-dialog-box-use nil
+ "*If non-nil, always use a dialog box for asking questions, if possible.
+You should *bind* this, not set it. This is useful if you're doing
+something mousy but which wasn't actually invoked using the mouse."
+ :type 'boolean
+ :group 'minibuffer)
+
+;; We include this here rather than dialog.el so it is defined
+;; even when dialog boxes are not present.
+(defun should-use-dialog-box-p ()
+ "If non-nil, questions should be asked with a dialog box instead of the
+minibuffer. This looks at `last-command-event' to see if it was a mouse
+event, and checks whether dialog-support exists and the current device
+supports dialog boxes.
+
+The dialog box is totally disabled if the variable `use-dialog-box'
+is set to nil."
+ (and (featurep 'dialog)
+ (device-on-window-system-p)
+ use-dialog-box
+ (or force-dialog-box-use
+ (button-press-event-p last-command-event)
+ (button-release-event-p last-command-event)
+ (misc-user-event-p last-command-event))))
+
+;;; minibuf.el ends here
projects / chise / xemacs-chise.git- / blobdiff