git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/minibuf.el

   1 ;;; minibuf.el --- Minibuffer functions for XEmacs
   2
   3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Tinker Systems
   5 ;; Copyright (C) 1995, 1996 Ben Wing
   6
   7 ;; Author: Richard Mlynarik
   8 ;; Created: 2-Oct-92
   9 ;; Maintainer: XEmacs Development Team
  10 ;; Keywords: internal, dumped
  11
  12 ;; This file is part of XEmacs.
  13
  14 ;; XEmacs is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; XEmacs is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with XEmacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Synched up with: all the minibuffer history stuff is synched with
  30 ;;; 19.30.  Not sure about the rest.
  31
  32 ;;; Commentary:
  33
  34 ;; This file is dumped with XEmacs.
  35
  36 ;; Written by Richard Mlynarik 2-Oct-92
  37
  38 ;; 06/11/1997 -  Use char-(after|before) instead of
  39 ;;  (following|preceding)-char. -slb
  40
  41 ;;; Code:
  42
  43 (defgroup minibuffer nil
  44   "Controling the behavior of the minibuffer."
  45   :group 'environment)
  46
  47
  48 (defcustom insert-default-directory t
  49  "*Non-nil means when reading a filename start with default dir in minibuffer."
  50  :type 'boolean
  51  :group 'minibuffer)
  52
  53 (defcustom minibuffer-history-uniquify t
  54   "*Non-nil means when adding an item to a minibuffer history, remove
  55 previous occurances of the same item from the history list first,
  56 rather than just consing the new element onto the front of the list."
  57   :type 'boolean
  58   :group 'minibuffer)
  59
  60 (defvar minibuffer-completion-table nil
  61   "Alist or obarray used for completion in the minibuffer.
  62 This becomes the ALIST argument to `try-completion' and `all-completions'.
  63
  64 The value may alternatively be a function, which is given three arguments:
  65   STRING, the current buffer contents;
  66   PREDICATE, the predicate for filtering possible matches;
  67   CODE, which says what kind of things to do.
  68 CODE can be nil, t or `lambda'.
  69 nil means to return the best completion of STRING, nil if there is none,
  70   or t if it is already a unique completion.
  71 t means to return a list of all possible completions of STRING.
  72 `lambda' means to return t if STRING is a valid completion as it stands.")
  73
  74 (defvar minibuffer-completion-predicate nil
  75   "Within call to `completing-read', this holds the PREDICATE argument.")
  76
  77 (defvar minibuffer-completion-confirm nil
  78   "Non-nil => demand confirmation of completion before exiting minibuffer.")
  79
  80 (defvar minibuffer-confirm-incomplete nil
  81   "If true, then in contexts where completing-read allows answers which
  82 are not valid completions, an extra RET must be typed to confirm the
  83 response.  This is helpful for catching typos, etc.")
  84
  85 (defcustom completion-auto-help t
  86   "*Non-nil means automatically provide help for invalid completion input."
  87   :type 'boolean
  88   :group 'minibuffer)
  89
  90 (defcustom enable-recursive-minibuffers nil
  91   "*Non-nil means to allow minibuffer commands while in the minibuffer.
  92 More precisely, this variable makes a difference when the minibuffer window
  93 is the selected window.  If you are in some other window, minibuffer commands
  94 are allowed even if a minibuffer is active."
  95   :type 'boolean
  96   :group 'minibuffer)
  97
  98 (defcustom minibuffer-max-depth 1
  99   ;; See comment in #'minibuffer-max-depth-exceeded
 100   "*Global maximum number of minibuffers allowed;
 101 compare to enable-recursive-minibuffers, which is only consulted when the
 102 minibuffer is reinvoked while it is the selected window."
 103   :type '(choice integer
 104                  (const :tag "Indefinite" nil))
 105   :group 'minibuffer)
 106
 107 ;; Moved to C.  The minibuffer prompt must be setup before this is run
 108 ;; and that can only be done from the C side.
 109 ;(defvar minibuffer-setup-hook nil
 110 ;  "Normal hook run just after entry to minibuffer.")
 111
 112 (defvar minibuffer-exit-hook nil
 113   "Normal hook run just after exit from minibuffer.")
 114
 115 (defvar minibuffer-help-form nil
 116   "Value that `help-form' takes on inside the minibuffer.")
 117
 118 (defvar minibuffer-default nil
 119   "Default value for minibuffer input.")
 120
 121 (defvar minibuffer-local-map
 122   (let ((map (make-sparse-keymap 'minibuffer-local-map)))
 123     map)
 124   "Default keymap to use when reading from the minibuffer.")
 125
 126 (defvar minibuffer-local-completion-map
 127   (let ((map (make-sparse-keymap 'minibuffer-local-completion-map)))
 128     (set-keymap-parents map (list minibuffer-local-map))
 129     map)
 130   "Local keymap for minibuffer input with completion.")
 131
 132 (defvar minibuffer-local-must-match-map
 133   (let ((map (make-sparse-keymap 'minibuffer-must-match-map)))
 134     (set-keymap-parents map (list minibuffer-local-completion-map))
 135     map)
 136   "Local keymap for minibuffer input with completion, for exact match.")
 137
 138 ;; (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit)
 139 (define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el
 140 (define-key minibuffer-local-map "\r" 'exit-minibuffer)
 141 (define-key minibuffer-local-map "\n" 'exit-minibuffer)
 142
 143 ;; Historical crock.  Unused by anything but user code, if even that
 144 ;(defvar minibuffer-local-ns-map
 145 ;  (let ((map (make-sparse-keymap 'minibuffer-local-ns-map)))
 146 ;    (set-keymap-parents map (list minibuffer-local-map))
 147 ;    map)
 148 ;  "Local keymap for the minibuffer when spaces are not allowed.")
 149 ;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer)
 150 ;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer)
 151 ;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit)
 152
 153 (define-key minibuffer-local-completion-map "\t" 'minibuffer-complete)
 154 (define-key minibuffer-local-completion-map " " 'minibuffer-complete-word)
 155 (define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help)
 156 (define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit)
 157 (define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit)
 158
 159 (define-key minibuffer-local-map "\M-n" 'next-history-element)
 160 (define-key minibuffer-local-map "\M-p" 'previous-history-element)
 161 (define-key minibuffer-local-map '[next]  "\M-n")
 162 (define-key minibuffer-local-map '[prior] "\M-p")
 163 (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
 164 (define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
 165 (define-key minibuffer-local-must-match-map [next]
 166   'next-complete-history-element)
 167 (define-key minibuffer-local-must-match-map [prior]
 168   'previous-complete-history-element)
 169
 170 ;; This is an experiment--make up and down arrows do history.
 171 (define-key minibuffer-local-map [up] 'previous-history-element)
 172 (define-key minibuffer-local-map [down] 'next-history-element)
 173 (define-key minibuffer-local-completion-map [up] 'previous-history-element)
 174 (define-key minibuffer-local-completion-map [down] 'next-history-element)
 175 (define-key minibuffer-local-must-match-map [up] 'previous-history-element)
 176 (define-key minibuffer-local-must-match-map [down] 'next-history-element)
 177
 178 (defvar read-expression-map (let ((map (make-sparse-keymap
 179                                         'read-expression-map)))
 180                               (set-keymap-parents map
 181                                                   (list minibuffer-local-map))
 182                               (define-key map "\M-\t" 'lisp-complete-symbol)
 183                               map)
 184   "Minibuffer keymap used for reading Lisp expressions.")
 185
 186 (defvar read-shell-command-map
 187   (let ((map (make-sparse-keymap 'read-shell-command-map)))
 188     (set-keymap-parents map (list minibuffer-local-map))
 189     (define-key map "\t" 'comint-dynamic-complete)
 190     (define-key map "\M-\t" 'comint-dynamic-complete)
 191     (define-key map "\M-?" 'comint-dynamic-list-completions)
 192     map)
 193   "Minibuffer keymap used by shell-command and related commands.")
 194
 195 (defcustom use-dialog-box t
 196   "*Variable controlling usage of the dialog box.
 197 If nil, the dialog box will never be used, even in response to mouse events."
 198   :type 'boolean
 199   :group 'minibuffer)
 200 \f
 201 (defcustom minibuffer-electric-file-name-behavior t
 202   "*If non-nil, slash and tilde in certain places cause immediate deletion.
 203 These are the same places where this behavior would occur later on anyway,
 204 in `substitute-in-file-name'."
 205   :type 'boolean
 206   :group 'minibuffer)
 207
 208 ;; originally by Stig@hackvan.com
 209 (defun minibuffer-electric-separator ()
 210   (interactive)
 211   (let ((c last-command-char))
 212     (and minibuffer-electric-file-name-behavior
 213          (eq c directory-sep-char)
 214          (eq c (char-before (point)))
 215          (not (save-excursion
 216               (goto-char (point-min))
 217               (and (looking-at "/.+:~?[^/]*/.+")
 218                    (re-search-forward "^/.+:~?[^/]*" nil t)
 219                    (progn
 220                      (delete-region (point) (point-max))
 221                      t))))
 222          (not (save-excursion
 223                 (goto-char (point-min))
 224                 (and (looking-at ".+://[^/]*/.+")
 225                      (re-search-forward "^.+:/" nil t)
 226                      (progn
 227                        (delete-region (point) (point-max))
 228                        t))))
 229          ;; permit `//hostname/path/to/file'
 230          (not (eq (point) (1+ (point-min))))
 231          ;; permit `http://url/goes/here'
 232          (or (not (eq ?: (char-after (- (point) 2))))
 233              (eq ?/ (char-after (point-min))))
 234        (delete-region (point-min) (point)))
 235     (insert c)))
 236
 237 (defun minibuffer-electric-tilde ()
 238   (interactive)
 239   (and minibuffer-electric-file-name-behavior
 240        (eq directory-sep-char (char-before (point)))
 241        ;; permit URL's with //, for e.g. http://hostname/~user
 242        (not (save-excursion (search-backward "//" nil t)))
 243        (delete-region (point-min) (point)))
 244   (insert ?~))
 245
 246
 247 (defvar read-file-name-map
 248   (let ((map (make-sparse-keymap 'read-file-name-map)))
 249     (set-keymap-parents map (list minibuffer-local-completion-map))
 250     (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
 251     (define-key map "~" 'minibuffer-electric-tilde)
 252     map
 253     ))
 254
 255 (defvar read-file-name-must-match-map
 256   (let ((map (make-sparse-keymap 'read-file-name-map)))
 257     (set-keymap-parents map (list minibuffer-local-must-match-map))
 258     (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
 259     (define-key map "~" 'minibuffer-electric-tilde)
 260     map
 261     ))
 262 \f
 263 (defun minibuffer-keyboard-quit ()
 264   "Abort recursive edit.
 265 If `zmacs-regions' is true, and the zmacs region is active in this buffer,
 266 then this key deactivates the region without beeping."
 267   (interactive)
 268   (if (and (region-active-p)
 269            (eq (current-buffer) (zmacs-region-buffer)))
 270       ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
 271       ;; deactivating the region.  If it is inactive, beep.
 272       nil
 273     (abort-recursive-edit)))
 274 \f
 275 ;;;; Guts of minibuffer invocation
 276
 277 ;;#### The only things remaining in C are
 278 ;; "Vminibuf_prompt" and the display junk
 279 ;;  "minibuf_prompt_width" and "minibuf_prompt_pix_width"
 280 ;; Also "active_frame", though I suspect I could already
 281 ;;   hack that in Lisp if I could make any sense of the
 282 ;;   complete mess of frame/frame code in XEmacs.
 283 ;; Vminibuf_prompt could easily be made Lisp-bindable.
 284 ;;  I suspect that minibuf_prompt*_width are actually recomputed
 285 ;;  by redisplay as needed -- or could be arranged to be so --
 286 ;;  and that there could be need for read-minibuffer-internal to
 287 ;;  save and restore them.
 288 ;;#### The only other thing which read-from-minibuffer-internal does
 289 ;;  which we can't presently do in Lisp is move the frame cursor
 290 ;;  to the start of the minibuffer line as it returns.  This is
 291 ;;  a rather nice touch and should be preserved -- probably by
 292 ;;  providing some Lisp-level mechanism (extension to cursor-in-echo-area ?)
 293 ;;  to effect it.
 294
 295
 296 ;; Like reset_buffer in FSF's buffer.c
 297 ;;  (Except that kill-all-local-variables doesn't nuke 'permanent-local
 298 ;;   variables -- we preserve them, reset_buffer doesn't.)
 299 (defun reset-buffer (buffer)
 300   (with-current-buffer buffer
 301     ;(if (fboundp 'unlock-buffer) (unlock-buffer))
 302     (kill-all-local-variables)
 303     (setq buffer-read-only nil)
 304     ;; don't let read only text yanked into the minibuffer
 305     ;; permanently wedge it.
 306     (make-local-variable 'inhibit-read-only)
 307     (setq inhibit-read-only t)
 308     (erase-buffer)
 309     ;(setq default-directory nil)
 310     (setq buffer-file-name nil)
 311     (setq buffer-file-truename nil)
 312     (set-buffer-modified-p nil)
 313     (setq buffer-backed-up nil)
 314     (setq buffer-auto-save-file-name nil)
 315     (set-buffer-dedicated-frame buffer nil)
 316     buffer))
 317
 318 (defvar minibuffer-history-variable 'minibuffer-history
 319   "History list symbol to add minibuffer values to.
 320 Each minibuffer output is added with
 321   (set minibuffer-history-variable
 322        (cons STRING (symbol-value minibuffer-history-variable)))")
 323 (defvar minibuffer-history-position)
 324
 325 ;; Added by hniksic:
 326 (defvar initial-minibuffer-history-position)
 327 (defvar current-minibuffer-contents)
 328 (defvar current-minibuffer-point)
 329
 330 (defcustom minibuffer-history-minimum-string-length nil
 331   "*If this variable is non-nil, a string will not be added to the
 332 minibuffer history if its length is less than that value."
 333   :type '(choice (const :tag "Any" nil)
 334                  integer)
 335   :group 'minibuffer)
 336
 337 (define-error 'input-error "Keyboard input error")
 338
 339 (put 'input-error 'display-error
 340      #'(lambda (error-object stream)
 341          (princ (cadr error-object) stream)))
 342
 343 (defun read-from-minibuffer (prompt &optional initial-contents
 344                                     keymap
 345                                     readp
 346                                     history
 347                                     abbrev-table
 348                                     default)
 349   "Read a string from the minibuffer, prompting with string PROMPT.
 350 If optional second arg INITIAL-CONTENTS is non-nil, it is a string
 351   to be inserted into the minibuffer before reading input.
 352   If INITIAL-CONTENTS is (STRING . POSITION), the initial input
 353   is STRING, but point is placed POSITION characters into the string.
 354 Third arg KEYMAP is a keymap to use while reading;
 355   if omitted or nil, the default is `minibuffer-local-map'.
 356 If fourth arg READ is non-nil, then interpret the result as a lisp object
 357   and return that object:
 358   in other words, do `(car (read-from-string INPUT-STRING))'
 359 Fifth arg HISTORY, if non-nil, specifies a history list
 360   and optionally the initial position in the list.
 361   It can be a symbol, which is the history list variable to use,
 362   or it can be a cons cell (HISTVAR . HISTPOS).
 363   In that case, HISTVAR is the history list variable to use,
 364   and HISTPOS is the initial position (the position in the list
 365   which INITIAL-CONTENTS corresponds to).
 366   If HISTORY is `t', no history will be recorded.
 367   Positions are counted starting from 1 at the beginning of the list.
 368 Sixth arg ABBREV-TABLE, if non-nil, becomes the value of `local-abbrev-table'
 369   in the minibuffer.
 370 Seventh arg DEFAULT, if non-nil, will be returned when user enters
 371   an empty string.
 372
 373 See also the variable completion-highlight-first-word-only for control over
 374   completion display."
 375   (if (and (not enable-recursive-minibuffers)
 376            (> (minibuffer-depth) 0)
 377            (eq (selected-window) (minibuffer-window)))
 378       (error "Command attempted to use minibuffer while in minibuffer"))
 379
 380   (if (and minibuffer-max-depth
 381            (> minibuffer-max-depth 0)
 382            (>= (minibuffer-depth) minibuffer-max-depth))
 383       (minibuffer-max-depth-exceeded))
 384
 385   ;; catch this error before the poor user has typed something...
 386   (if history
 387       (if (symbolp history)
 388           (or (boundp history)
 389               (error "History list %S is unbound" history))
 390         (or (boundp (car history))
 391             (error "History list %S is unbound" (car history)))))
 392
 393   (if (noninteractive)
 394       (progn
 395         ;; XEmacs in -batch mode calls minibuffer: print the prompt.
 396         (message "%s" (gettext prompt))
 397         ;;#### force-output
 398
 399         ;;#### Should this even be falling though to the code below?
 400         ;;#### How does this stuff work now, anyway?
 401         ))
 402   (let* ((dir default-directory)
 403          (owindow (selected-window))
 404          (oframe (selected-frame))
 405          (window (minibuffer-window))
 406          (buffer (if (eq (minibuffer-depth) 0)
 407                      (window-buffer window)
 408                    (get-buffer-create (format " *Minibuf-%d"
 409                                               (minibuffer-depth)))))
 410          (frame (window-frame window))
 411          (mconfig (if (eq frame (selected-frame))
 412                       nil (current-window-configuration frame)))
 413          (oconfig (current-window-configuration))
 414          ;; dynamic scope sucks sucks sucks sucks sucks sucks.
 415          ;; `M-x doctor' makes history a local variable, and thus
 416          ;; our binding above is buffer-local and doesn't apply
 417          ;; once we switch buffers!!!!  We demand better scope!
 418          (_history_ history)
 419          (minibuffer-default default))
 420     (unwind-protect
 421          (progn
 422            (set-buffer (reset-buffer buffer))
 423            (setq default-directory dir)
 424            (make-local-variable 'print-escape-newlines)
 425            (setq print-escape-newlines t)
 426            (make-local-variable 'current-minibuffer-contents)
 427            (make-local-variable 'current-minibuffer-point)
 428            (make-local-variable 'initial-minibuffer-history-position)
 429            (setq current-minibuffer-contents ""
 430                  current-minibuffer-point 1)
 431            (if (not minibuffer-smart-completion-tracking-behavior)
 432                nil
 433              (make-local-variable 'mode-motion-hook)
 434              (or mode-motion-hook
 435                  ;;####disgusting
 436                  (setq mode-motion-hook 'minibuffer-smart-mouse-tracker))
 437              (make-local-variable 'mouse-track-click-hook)
 438              (add-hook 'mouse-track-click-hook
 439                        'minibuffer-smart-maybe-select-highlighted-completion))
 440            (set-window-buffer window buffer)
 441            (select-window window)
 442            (set-window-hscroll window 0)
 443            (buffer-enable-undo buffer)
 444            (message nil)
 445            (if initial-contents
 446                (if (consp initial-contents)
 447                    (progn
 448                      (insert (car initial-contents))
 449                      (goto-char (1+ (cdr initial-contents)))
 450                      (setq current-minibuffer-contents (car initial-contents)
 451                            current-minibuffer-point (cdr initial-contents)))
 452                  (insert initial-contents)
 453                  (setq current-minibuffer-contents initial-contents
 454                        current-minibuffer-point (point))))
 455            (use-local-map (help-keymap-with-help-key
 456                            (or keymap minibuffer-local-map)
 457                            minibuffer-help-form))
 458            (let ((mouse-grabbed-buffer
 459                   (and minibuffer-smart-completion-tracking-behavior
 460                        (current-buffer)))
 461                  (current-prefix-arg current-prefix-arg)
 462 ;;                 (help-form minibuffer-help-form)
 463                  (minibuffer-history-variable (cond ((not _history_)
 464                                                      'minibuffer-history)
 465                                                     ((consp _history_)
 466                                                      (car _history_))
 467                                                     (t
 468                                                      _history_)))
 469                  (minibuffer-history-position (cond ((consp _history_)
 470                                                      (cdr _history_))
 471                                                     (t
 472                                                      0)))
 473                  (minibuffer-scroll-window owindow))
 474              (setq initial-minibuffer-history-position
 475                    minibuffer-history-position)
 476              (if abbrev-table
 477                  (setq local-abbrev-table abbrev-table
 478                        abbrev-mode t))
 479              ;; This is now run from read-minibuffer-internal
 480              ;(if minibuffer-setup-hook
 481              ;    (run-hooks 'minibuffer-setup-hook))
 482              ;(message nil)
 483              (if (eq 't
 484                      (catch 'exit
 485                        (if (> (recursion-depth) (minibuffer-depth))
 486                            (let ((standard-output t)
 487                                  (standard-input t))
 488                              (read-minibuffer-internal prompt))
 489                            (read-minibuffer-internal prompt))))
 490                  ;; Translate an "abort" (throw 'exit 't)
 491                  ;;  into a real quit
 492                  (signal 'quit '())
 493                ;; return value
 494                (let* ((val (progn (set-buffer buffer)
 495                                   (if minibuffer-exit-hook
 496                                       (run-hooks 'minibuffer-exit-hook))
 497                                   (if (and (eq (char-after (point-min)) nil)
 498                                            default)
 499                                       default
 500                                     (buffer-string))))
 501                       (histval (if (and default (string= val ""))
 502                                    default
 503                                  val))
 504                       (err nil))
 505                  (if readp
 506                      (condition-case e
 507                          (let ((v (read-from-string val)))
 508                            (if (< (cdr v) (length val))
 509                                (save-match-data
 510                                  (or (string-match "[ \t\n]*\\'" val (cdr v))
 511                                      (error "Trailing garbage following expression"))))
 512                            (setq v (car v))
 513                            ;; total total kludge
 514                            (if (stringp v) (setq v (list 'quote v)))
 515                            (setq val v))
 516                        (end-of-file
 517                         (setq err
 518                               '(input-error "End of input before end of expression")))
 519                        (error (setq err e))))
 520                  ;; Add the value to the appropriate history list unless
 521                  ;; it's already the most recent element, or it's only
 522                  ;; two characters long.
 523                  (if (and (symbolp minibuffer-history-variable)
 524                           (boundp minibuffer-history-variable))
 525                      (let ((list (symbol-value minibuffer-history-variable)))
 526                        (or (eq list t)
 527                            (null val)
 528                            (and list (equal histval (car list)))
 529                            (and (stringp val)
 530                                 minibuffer-history-minimum-string-length
 531                                 (< (length val)
 532                                    minibuffer-history-minimum-string-length))
 533                            (set minibuffer-history-variable
 534                                 (if minibuffer-history-uniquify
 535                                     (cons histval (remove histval list))
 536                                   (cons histval list))))))
 537                  (if err (signal (car err) (cdr err)))
 538                  val))))
 539       ;; stupid display code requires this for some reason
 540       (set-buffer buffer)
 541       (buffer-disable-undo buffer)
 542       (setq buffer-read-only nil)
 543       (erase-buffer)
 544
 545       ;; restore frame configurations
 546       (if (and mconfig (frame-live-p oframe)
 547                (eq frame (selected-frame)))
 548           ;; if we changed frames (due to surrogate minibuffer),
 549           ;; and we're still on the new frame, go back to the old one.
 550           (select-frame oframe))
 551       (if mconfig (set-window-configuration mconfig))
 552       (set-window-configuration oconfig))))
 553
 554
 555 (defun minibuffer-max-depth-exceeded ()
 556   ;;
 557   ;; This signals an error if an Nth minibuffer is invoked while N-1 are
 558   ;; already active, whether the minibuffer window is selected or not.
 559   ;; Since, under X, it's easy to jump out of the minibuffer (by doing M-x,
 560   ;; getting distracted, and clicking elsewhere) many many novice users have
 561   ;; had the problem of having multiple minibuffers build up, even to the
 562   ;; point of exceeding max-lisp-eval-depth.  Since the variable
 563   ;; enable-recursive-minibuffers historically/crockishly is only consulted
 564   ;; when the minibuffer is currently active (like typing M-x M-x) it doesn't
 565   ;; help in this situation.
 566   ;;
 567   ;; This routine also offers to edit .emacs for you to get rid of this
 568   ;; complaint, like `disabled' commands do, since it's likely that non-novice
 569   ;; users will be annoyed by this change, so we give them an easy way to get
 570   ;; rid of it forever.
 571   ;;
 572   (beep t 'minibuffer-limit-exceeded)
 573   (message
 574    "Minibuffer already active: abort it with `^]', enable new one with `n': ")
 575   (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work??
 576                 (read-char))))
 577     (cond
 578      ((eq char ?n)
 579       (cond
 580        ((y-or-n-p "Enable recursive minibuffers for other sessions too? ")
 581         ;; This is completely disgusting, but it's basically what novice.el
 582         ;; does.  This kind of thing should be generalized.
 583         (setq minibuffer-max-depth nil)
 584         (save-excursion
 585           (set-buffer
 586            (find-file-noselect
 587             (substitute-in-file-name custom-file)))
 588           (goto-char (point-min))
 589           (if (re-search-forward
 590                "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n"
 591                nil t)
 592               (delete-region (match-beginning 0 ) (match-end 0))
 593             ;; Must have been disabled by default.
 594             (goto-char (point-max)))
 595           (insert"\n(setq minibuffer-max-depth nil)\n")
 596           (save-buffer))
 597         (message "Multiple minibuffers enabled")
 598         (sit-for 1))))
 599      ((eq char ?\1d)
 600       (abort-recursive-edit))
 601      (t
 602       (error "Minibuffer already active")))))
 603
 604 \f
 605 ;;;; Guts of minibuffer completion
 606
 607
 608 ;; Used by minibuffer-do-completion
 609 (defvar last-exact-completion)
 610
 611 (defun temp-minibuffer-message (m)
 612   (let ((savemax (point-max)))
 613     (save-excursion
 614       (goto-char (point-max))
 615       (message nil)
 616       (insert m))
 617     (let ((inhibit-quit t))
 618       (sit-for 2)
 619       (delete-region savemax (point-max))
 620       ;;  If the user types a ^G while we're in sit-for, then quit-flag
 621       ;;  gets set. In this case, we want that ^G to be interpreted
 622       ;;  as a normal character, and act just like typeahead.
 623       (if (and quit-flag (not unread-command-event))
 624           (setq unread-command-event (character-to-event (quit-char))
 625                 quit-flag nil)))))
 626
 627
 628 ;; Determines whether buffer-string is an exact completion
 629 (defun exact-minibuffer-completion-p (buffer-string)
 630   (cond ((not minibuffer-completion-table)
 631          ;; Empty alist
 632          nil)
 633         ((vectorp minibuffer-completion-table)
 634          (let ((tem (intern-soft buffer-string
 635                                  minibuffer-completion-table)))
 636            (if (or tem
 637                    (and (string-equal buffer-string "nil")
 638                         ;; intern-soft loses for 'nil
 639                         (catch 'found
 640                           (mapatoms #'(lambda (s)
 641                                         (if (string-equal
 642                                              (symbol-name s)
 643                                              buffer-string)
 644                                             (throw 'found t)))
 645                                     minibuffer-completion-table)
 646                           nil)))
 647                (if minibuffer-completion-predicate
 648                    (funcall minibuffer-completion-predicate
 649                             tem)
 650                    t)
 651                nil)))
 652         ((and (consp minibuffer-completion-table)
 653               ;;#### Emacs-Lisp truly sucks!
 654               ;; lambda, autoload, etc
 655               (not (symbolp (car minibuffer-completion-table))))
 656          (if (not completion-ignore-case)
 657              (assoc buffer-string minibuffer-completion-table)
 658              (let ((s (upcase buffer-string))
 659                    (tail minibuffer-completion-table)
 660                    tem)
 661                (while tail
 662                  (setq tem (car (car tail)))
 663                  (if (or (equal tem buffer-string)
 664                          (equal tem s)
 665                         (if tem (equal (upcase tem) s)))
 666                      (setq s 'win
 667                            tail nil)    ;exit
 668                      (setq tail (cdr tail))))
 669                (eq s 'win))))
 670         (t
 671          (funcall minibuffer-completion-table
 672                   buffer-string
 673                   minibuffer-completion-predicate
 674                   'lambda)))
 675   )
 676
 677 ;; 0 'none                 no possible completion
 678 ;; 1 'unique               was already an exact and unique completion
 679 ;; 3 'exact                was already an exact (but nonunique) completion
 680 ;; NOT USED 'completed-exact-unique completed to an exact and completion
 681 ;; 4 'completed-exact      completed to an exact (but nonunique) completion
 682 ;; 5 'completed            some completion happened
 683 ;; 6 'uncompleted          no completion happened
 684 (defun minibuffer-do-completion-1 (buffer-string completion)
 685   (cond ((not completion)
 686          'none)
 687         ((eq completion t)
 688          ;; exact and unique match
 689          'unique)
 690         (t
 691          ;; It did find a match.  Do we match some possibility exactly now?
 692          (let ((completedp (not (string-equal completion buffer-string))))
 693            (if completedp
 694                (progn
 695                  ;; Some completion happened
 696                  (erase-buffer)
 697                  (insert completion)
 698                  (setq buffer-string completion)))
 699            (if (exact-minibuffer-completion-p buffer-string)
 700                ;; An exact completion was possible
 701                (if completedp
 702 ;; Since no callers need to know the difference, don't bother
 703 ;;  with this (potentially expensive) discrimination.
 704 ;;                 (if (eq (try-completion completion
 705 ;;                                         minibuffer-completion-table
 706 ;;                                         minibuffer-completion-predicate)
 707 ;;                         't)
 708 ;;                     'completed-exact-unique
 709                        'completed-exact
 710 ;;                     )
 711                    'exact)
 712                ;; Not an exact match
 713                (if completedp
 714                    'completed
 715                    'uncompleted))))))
 716
 717
 718 (defun minibuffer-do-completion (buffer-string)
 719   (let* ((completion (try-completion buffer-string
 720                                      minibuffer-completion-table
 721                                      minibuffer-completion-predicate))
 722          (status (minibuffer-do-completion-1 buffer-string completion))
 723          (last last-exact-completion))
 724     (setq last-exact-completion nil)
 725     (cond ((eq status 'none)
 726            ;; No completions
 727            (ding nil 'no-completion)
 728            (temp-minibuffer-message " [No match]"))
 729           ((eq status 'unique)
 730            )
 731           (t
 732            ;; It did find a match.  Do we match some possibility exactly now?
 733            (if (not (string-equal completion buffer-string))
 734                (progn
 735                  ;; Some completion happened
 736                  (erase-buffer)
 737                  (insert completion)
 738                  (setq buffer-string completion)))
 739            (cond ((eq status 'exact)
 740                   ;; If the last exact completion and this one were
 741                   ;;  the same, it means we've already given a
 742                   ;;  "Complete but not unique" message and that the
 743                   ;;  user's hit TAB again, so now we give help.
 744                   (setq last-exact-completion completion)
 745                   (if (equal buffer-string last)
 746                       (minibuffer-completion-help)))
 747                  ((eq status 'uncompleted)
 748                   (if completion-auto-help
 749                       (minibuffer-completion-help)
 750                       (temp-minibuffer-message " [Next char not unique]")))
 751                  (t
 752                   nil))))
 753     status))
 754
 755 \f
 756 ;;;; completing-read
 757
 758 (defun completing-read (prompt table
 759                         &optional predicate require-match
 760                                   initial-contents history default)
 761   "Read a string in the minibuffer, with completion.
 762 Args: PROMPT, TABLE, PREDICATE, REQUIRE-MATCH, INITIAL-CONTENTS, HISTORY.
 763 PROMPT is a string to prompt with; normally it ends in a colon and a space.
 764 TABLE is an alist whose elements' cars are strings, or an obarray.
 765 PREDICATE limits completion to a subset of TABLE.
 766 See `try-completion' for more details on completion, TABLE, and PREDICATE.
 767 If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless
 768  the input is (or completes to) an element of TABLE or is null.
 769  If it is also not t, Return does not exit if it does non-null completion.
 770 If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially.
 771   If it is (STRING . POSITION), the initial input
 772   is STRING, but point is placed POSITION characters into the string.
 773 HISTORY, if non-nil, specifies a history list
 774   and optionally the initial position in the list.
 775   It can be a symbol, which is the history list variable to use,
 776   or it can be a cons cell (HISTVAR . HISTPOS).
 777   In that case, HISTVAR is the history list variable to use,
 778   and HISTPOS is the initial position (the position in the list
 779   which INITIAL-CONTENTS corresponds to).
 780   If HISTORY is `t', no history will be recorded.
 781   Positions are counted starting from 1 at the beginning of the list.
 782 DEFAULT, if non-nil, is the default value.
 783 Completion ignores case if the ambient value of
 784   `completion-ignore-case' is non-nil."
 785   (let ((minibuffer-completion-table table)
 786         (minibuffer-completion-predicate predicate)
 787         (minibuffer-completion-confirm (if (eq require-match 't) nil t))
 788         (last-exact-completion nil)
 789         ret)
 790     (setq ret (read-from-minibuffer prompt
 791                                     initial-contents
 792                                     (if (not require-match)
 793                                         minibuffer-local-completion-map
 794                                       minibuffer-local-must-match-map)
 795                                     nil
 796                                     history
 797                                     nil
 798                                     default))
 799     (if (and (string= ret "")
 800              default)
 801         default
 802       ret)))
 803
 804 \f
 805 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 806 ;;;;                   Minibuffer completion commands                   ;;;;
 807 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 808
 809
 810 (defun minibuffer-complete ()
 811   "Complete the minibuffer contents as far as possible.
 812 Return nil if there is no valid completion, else t.
 813 If no characters can be completed, display a list of possible completions.
 814 If you repeat this command after it displayed such a list,
 815 scroll the window of possible completions."
 816   (interactive)
 817   ;; If the previous command was not this, then mark the completion
 818   ;;  buffer obsolete.
 819   (or (eq last-command this-command)
 820       (setq minibuffer-scroll-window nil))
 821   (let ((window minibuffer-scroll-window))
 822     (if (and window (windowp window) (window-buffer window)
 823              (buffer-name (window-buffer window)))
 824         ;; If there's a fresh completion window with a live buffer
 825         ;;  and this command is repeated, scroll that window.
 826         (let ((obuf (current-buffer)))
 827           (unwind-protect
 828               (progn
 829                 (set-buffer (window-buffer window))
 830                 (if (pos-visible-in-window-p (point-max) window)
 831                     ;; If end is in view, scroll up to the beginning.
 832                     (set-window-start window (point-min))
 833                   ;; Else scroll down one frame.
 834                   (scroll-other-window)))
 835             (set-buffer obuf))
 836           nil)
 837       (let ((status (minibuffer-do-completion (buffer-string))))
 838         (if (eq status 'none)
 839             nil
 840           (progn
 841             (cond ((eq status 'unique)
 842                    (temp-minibuffer-message
 843                     " [Sole completion]"))
 844                   ((eq status 'exact)
 845                    (temp-minibuffer-message
 846                     " [Complete, but not unique]")))
 847             t))))))
 848
 849
 850 (defun minibuffer-complete-and-exit ()
 851   "Complete the minibuffer contents, and maybe exit.
 852 Exit if the name is valid with no completion needed.
 853 If name was completed to a valid match,
 854 a repetition of this command will exit."
 855   (interactive)
 856   (if (= (point-min) (point-max))
 857       ;; Crockishly allow user to specify null string
 858       (throw 'exit nil))
 859   (let ((buffer-string (buffer-string)))
 860     ;; Short-cut -- don't call minibuffer-do-completion if we already
 861     ;;  have an (possibly nonunique) exact completion.
 862     (if (exact-minibuffer-completion-p buffer-string)
 863         (throw 'exit nil))
 864     (let ((status (minibuffer-do-completion buffer-string)))
 865       (if (or (eq status 'unique)
 866               (eq status 'exact)
 867               (if (or (eq status 'completed-exact)
 868                       (eq status 'completed-exact-unique))
 869                   (if minibuffer-completion-confirm
 870                       (progn (temp-minibuffer-message " [Confirm]")
 871                              nil)
 872                       t)))
 873           (throw 'exit nil)))))
 874
 875
 876 (defun self-insert-and-exit ()
 877   "Terminate minibuffer input."
 878   (interactive)
 879   (self-insert-command 1)
 880   (throw 'exit nil))
 881
 882 (defun exit-minibuffer ()
 883   "Terminate this minibuffer argument.
 884 If minibuffer-confirm-incomplete is true, and we are in a completing-read
 885 of some kind, and the contents of the minibuffer is not an existing
 886 completion, requires an additional RET before the minibuffer will be exited
 887 \(assuming that RET was the character that invoked this command:
 888 the character in question must be typed again)."
 889   (interactive)
 890   (if (not minibuffer-confirm-incomplete)
 891       (throw 'exit nil))
 892   (let ((buffer-string (buffer-string)))
 893     (if (exact-minibuffer-completion-p buffer-string)
 894         (throw 'exit nil))
 895     (let ((completion (if (not minibuffer-completion-table)
 896                           t
 897                           (try-completion buffer-string
 898                                           minibuffer-completion-table
 899                                           minibuffer-completion-predicate))))
 900       (if (or (eq completion 't)
 901               ;; Crockishly allow user to specify null string
 902               (string-equal buffer-string ""))
 903           (throw 'exit nil))
 904       (if completion ;; rewritten for I18N3 snarfing
 905           (temp-minibuffer-message " [incomplete; confirm]")
 906         (temp-minibuffer-message " [no completions; confirm]"))
 907       (let ((event (let ((inhibit-quit t))
 908                      (prog1
 909                          (next-command-event)
 910                        (setq quit-flag nil)))))
 911         (cond ((equal event last-command-event)
 912                (throw 'exit nil))
 913               ((equal (quit-char) (event-to-character event))
 914                ;; Minibuffer abort.
 915                (throw 'exit t)))
 916         (dispatch-event event)))))
 917 \f
 918 ;;;; minibuffer-complete-word
 919
 920
 921 ;;;#### I think I have done this correctly; it certainly is simpler
 922 ;;;#### than what the C code seemed to be trying to do.
 923 (defun minibuffer-complete-word ()
 924   "Complete the minibuffer contents at most a single word.
 925 After one word is completed as much as possible, a space or hyphen
 926 is added, provided that matches some possible completion.
 927 Return nil if there is no valid completion, else t."
 928   (interactive)
 929   (let* ((buffer-string (buffer-string))
 930          (completion (try-completion buffer-string
 931                                      minibuffer-completion-table
 932                                      minibuffer-completion-predicate))
 933          (status (minibuffer-do-completion-1 buffer-string completion)))
 934     (cond ((eq status 'none)
 935            (ding nil 'no-completion)
 936            (temp-minibuffer-message " [No match]")
 937            nil)
 938           ((eq status 'unique)
 939            ;; New message, only in this new Lisp code
 940            (temp-minibuffer-message " [Sole completion]")
 941            t)
 942           (t
 943            (cond ((or (eq status 'uncompleted)
 944                       (eq status 'exact))
 945                   (let ((foo #'(lambda (s)
 946                                  (condition-case nil
 947                                      (if (try-completion
 948                                           (concat buffer-string s)
 949                                           minibuffer-completion-table
 950                                           minibuffer-completion-predicate)
 951                                          (progn
 952                                            (goto-char (point-max))
 953                                            (insert s)
 954                                            t)
 955                                        nil)
 956                                    (error nil))))
 957                         (char last-command-char))
 958                     ;; Try to complete by adding a word-delimiter
 959                     (or (and (characterp char) (> char 0)
 960                              (funcall foo (char-to-string char)))
 961                         (and (not (eq char ?\ ))
 962                              (funcall foo " "))
 963                         (and (not (eq char ?\-))
 964                              (funcall foo "-"))
 965                         (progn
 966                           (if completion-auto-help
 967                               (minibuffer-completion-help)
 968                               ;; New message, only in this new Lisp code
 969                             ;; rewritten for I18N3 snarfing
 970                             (if (eq status 'exact)
 971                                 (temp-minibuffer-message
 972                                  " [Complete, but not unique]")
 973                               (temp-minibuffer-message " [Ambiguous]")))
 974                           nil))))
 975                  (t
 976                   (erase-buffer)
 977                   (insert completion)
 978                   ;; First word-break in stuff found by completion
 979                   (goto-char (point-min))
 980                   (let ((len (length buffer-string))
 981                         n)
 982                     (if (and (< len (length completion))
 983                              (catch 'match
 984                                (setq n 0)
 985                                (while (< n len)
 986                                  (if (char-equal
 987                                        (upcase (aref buffer-string n))
 988                                        (upcase (aref completion n)))
 989                                      (setq n (1+ n))
 990                                      (throw 'match nil)))
 991                                t)
 992                              (progn
 993                                (goto-char (point-min))
 994                                (forward-char len)
 995                                (re-search-forward "\\W" nil t)))
 996                         (delete-region (point) (point-max))
 997                         (goto-char (point-max))))
 998                   t))))))
 999 \f
1000 \f
1001 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1002 ;;;;                      "Smart minibuffer" hackery                    ;;;;
1003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1004
1005 ;;; ("Kludgy minibuffer hackery" is perhaps a better name)
1006
1007 ;; This works by setting `mouse-grabbed-buffer' to the minibuffer,
1008 ;; defining button2 in the minibuffer keymap to
1009 ;; `minibuffer-smart-select-highlighted-completion', and setting the
1010 ;; mode-motion-hook of the minibuffer to `minibuffer-mouse-tracker'.
1011 ;; By setting `mouse-grabbed-buffer', the minibuffer's keymap and
1012 ;; mode-motion-hook apply (for mouse motion and presses) no matter
1013 ;; what buffer the mouse is over.  Then, `minibuffer-mouse-tracker'
1014 ;; examines the text under the mouse looking for something that looks
1015 ;; like a completion, and causes it to be highlighted, and
1016 ;; `minibuffer-smart-select-highlighted-completion' looks for a
1017 ;; flagged completion under the mouse and inserts it.  This has the
1018 ;; following advantages:
1019 ;;
1020 ;; -- filenames and such in any buffer can be inserted by clicking,
1021 ;;    not just completions
1022 ;;
1023 ;; but the following disadvantages:
1024 ;;
1025 ;; -- unless you're aware of the "filename in any buffer" feature,
1026 ;;    the fact that strings in arbitrary buffers get highlighted appears
1027 ;;    as a bug
1028 ;; -- mouse motion can cause ange-ftp actions -- bad bad bad.
1029 ;;
1030 ;; There's some hackery in minibuffer-mouse-tracker to try to avoid the
1031 ;; ange-ftp stuff, but it doesn't work.
1032 ;;
1033
1034 (defcustom minibuffer-smart-completion-tracking-behavior nil
1035   "*If non-nil, look for completions under mouse in all buffers.
1036 This allows you to click on something that looks like a completion
1037 and have it selected, regardless of what buffer it is in.
1038
1039 This is not enabled by default because
1040
1041 -- The \"mysterious\" highlighting in normal buffers is confusing to
1042    people not expecting it, and looks like a bug
1043 -- If ange-ftp is enabled, this tracking sometimes causes ange-ftp
1044    action as a result of mouse motion, which is *bad bad bad*.
1045    Hopefully this bug will be fixed at some point."
1046   :type 'boolean
1047   :group 'minibuffer)
1048
1049 (defun minibuffer-smart-mouse-tracker (event)
1050   ;; Used as the mode-motion-hook of the minibuffer window, which is the
1051   ;; value of `mouse-grabbed-buffer' while the minibuffer is active.  If
1052   ;; the word under the mouse is a valid minibuffer completion, then it
1053   ;; is highlighted.
1054   ;;
1055   ;; We do some special voodoo when we're reading a pathname, because
1056   ;; the way filename completion works is funny.  Possibly there's some
1057   ;; more general way this could be dealt with...
1058   ;;
1059   ;; We do some further voodoo when reading a pathname that is an
1060   ;; ange-ftp or efs path, because causing FTP activity as a result of
1061   ;; mouse motion is a really bad time.
1062   ;;
1063   (and minibuffer-smart-completion-tracking-behavior
1064        (event-point event)
1065        ;; avoid conflict with display-completion-list extents
1066        (not (extent-at (event-point event)
1067                        (event-buffer event)
1068                        'list-mode-item))
1069        (let ((filename-kludge-p (eq minibuffer-completion-table
1070                                     'read-file-name-internal)))
1071          (mode-motion-highlight-internal
1072           event
1073           #'(lambda () (default-mouse-track-beginning-of-word
1074                          (if filename-kludge-p 'nonwhite t)))
1075           #'(lambda ()
1076               (let ((p (point))
1077                     (string ""))
1078                 (default-mouse-track-end-of-word
1079                   (if filename-kludge-p 'nonwhite t))
1080                 (if (and (/= p (point)) minibuffer-completion-table)
1081                     (setq string (buffer-substring p (point))))
1082                 (if (string-match "\\`[ \t\n]*\\'" string)
1083                     (goto-char p)
1084                   (if filename-kludge-p
1085                       (setq string (minibuffer-smart-select-kludge-filename
1086                                     string)))
1087                   ;; try-completion bogusly returns a string even when
1088                   ;; that string is complete if that string is also a
1089                   ;; prefix for other completions.  This means that we
1090                   ;; can't just do the obvious thing, (eq t
1091                   ;; (try-completion ...)).
1092                   (let (comp)
1093                     (if (and filename-kludge-p
1094                              ;; #### evil evil evil evil
1095                              (or (and (fboundp 'ange-ftp-ftp-path)
1096                                       (ange-ftp-ftp-path string))
1097                                  (and (fboundp 'efs-ftp-path)
1098                                       (efs-ftp-path string))))
1099                         (setq comp t)
1100                       (setq comp
1101                             (try-completion string
1102                                             minibuffer-completion-table
1103                                             minibuffer-completion-predicate)))
1104                     (or (eq comp t)
1105                         (and (equal comp string)
1106                              (or (null minibuffer-completion-predicate)
1107                                  (stringp
1108                                   minibuffer-completion-predicate) ; ???
1109                                  (funcall minibuffer-completion-predicate
1110                                           (if (vectorp
1111                                                minibuffer-completion-table)
1112                                               (intern-soft
1113                                                string
1114                                                minibuffer-completion-table)
1115                                             string))))
1116                         (goto-char p))))))))))
1117
1118 (defun minibuffer-smart-select-kludge-filename (string)
1119   (save-excursion
1120     (set-buffer mouse-grabbed-buffer) ; the minibuf
1121     (let ((kludge-string (concat (buffer-string) string)))
1122       (if (or (and (fboundp 'ange-ftp-ftp-path)
1123                    (ange-ftp-ftp-path kludge-string))
1124                (and (fboundp 'efs-ftp-path) (efs-ftp-path kludge-string)))
1125            ;; #### evil evil evil, but more so.
1126            string
1127          (append-expand-filename (buffer-string) string)))))
1128
1129 (defun minibuffer-smart-select-highlighted-completion (event)
1130   "Select the highlighted text under the mouse as a minibuffer response.
1131 When the minibuffer is being used to prompt the user for a completion,
1132 any valid completions which are visible on the frame will highlight
1133 when the mouse moves over them.  Clicking \\<minibuffer-local-map>\
1134 \\[minibuffer-smart-select-highlighted-completion] will select the
1135 highlighted completion under the mouse.
1136
1137 If the mouse is clicked while not over a highlighted completion,
1138 then the global binding of \\[minibuffer-smart-select-highlighted-completion] \
1139 will be executed instead.  In this\nway you can get at the normal global \
1140 behavior of \\[minibuffer-smart-select-highlighted-completion] as well as
1141 the special minibuffer behavior."
1142   (interactive "e")
1143   (if minibuffer-smart-completion-tracking-behavior
1144       (minibuffer-smart-select-highlighted-completion-1 event t)
1145     (let ((command (lookup-key global-map
1146                                (vector current-mouse-event))))
1147       (if command (call-interactively command)))))
1148
1149 (defun minibuffer-smart-select-highlighted-completion-1 (event global-p)
1150   (let* ((filename-kludge-p (eq minibuffer-completion-table
1151                                 'read-file-name-internal))
1152          completion
1153          command-p
1154          (evpoint (event-point event))
1155          (evextent (and evpoint (extent-at evpoint (event-buffer event)
1156                                            'list-mode-item))))
1157     (if evextent
1158         ;; avoid conflict with display-completion-list extents.
1159         ;; if we find one, do that behavior instead.
1160         (list-mode-item-selected-1 evextent event)
1161       (save-excursion
1162         (let* ((buffer (window-buffer (event-window event)))
1163                (p (event-point event))
1164                (extent (and p (extent-at p buffer 'mouse-face))))
1165           (set-buffer buffer)
1166           (if (not (and (extent-live-p extent)
1167                         (eq (extent-object extent) (current-buffer))
1168                         (not (extent-detached-p extent))))
1169               (setq command-p t)
1170             ;; ...else user has selected a highlighted completion.
1171             (setq completion
1172                   (buffer-substring (extent-start-position extent)
1173                                     (extent-end-position extent)))
1174             (if filename-kludge-p
1175                 (setq completion (minibuffer-smart-select-kludge-filename
1176                                   completion)))
1177             ;; remove the extent so that it's not hanging around in
1178             ;; *Completions*
1179             (detach-extent extent)
1180             (set-buffer mouse-grabbed-buffer)
1181             (erase-buffer)
1182             (insert completion))))
1183       ;; we need to execute the command or do the throw outside of the
1184       ;; save-excursion.
1185       (cond ((and command-p global-p)
1186              (let ((command (lookup-key global-map
1187                                         (vector current-mouse-event))))
1188                (if command
1189                    (call-interactively command)
1190                  (if minibuffer-completion-table
1191                      (error
1192                       "Highlighted words are valid completions.  You may select one.")
1193                    (error "no completions")))))
1194             ((not command-p)
1195              ;; things get confused if the minibuffer is terminated while
1196              ;; not selected.
1197              (select-window (minibuffer-window))
1198              (if (and filename-kludge-p (file-directory-p completion))
1199                  ;; if the user clicked middle on a directory name, display the
1200                  ;; files in that directory.
1201                  (progn
1202                    (goto-char (point-max))
1203                    (minibuffer-completion-help))
1204                ;; otherwise, terminate input
1205                (throw 'exit nil)))))))
1206
1207 (defun minibuffer-smart-maybe-select-highlighted-completion
1208   (event &optional click-count)
1209   "Like minibuffer-smart-select-highlighted-completion but does nothing if
1210 there is no completion (as opposed to executing the global binding).  Useful
1211 as the value of `mouse-track-click-hook'."
1212   (interactive "e")
1213   (minibuffer-smart-select-highlighted-completion-1 event nil))
1214
1215 (define-key minibuffer-local-map 'button2
1216   'minibuffer-smart-select-highlighted-completion)
1217
1218 \f
1219 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1220 ;;;;                         Minibuffer History                         ;;;;
1221 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1222
1223 (defvar minibuffer-history '()
1224   "Default minibuffer history list.
1225 This is used for all minibuffer input except when an alternate history
1226 list is specified.")
1227
1228 ;; Some other history lists:
1229 ;;
1230 (defvar minibuffer-history-search-history '())
1231 (defvar function-history '())
1232 (defvar variable-history '())
1233 (defvar buffer-history '())
1234 (defvar shell-command-history '())
1235 (defvar file-name-history '())
1236
1237 (defvar read-expression-history nil)
1238
1239 (defvar minibuffer-history-sexp-flag nil ;weird FSF Emacs kludge
1240   "Non-nil when doing history operations on `command-history'.
1241 More generally, indicates that the history list being acted on
1242 contains expressions rather than strings.")
1243
1244 (defun previous-matching-history-element (regexp n)
1245   "Find the previous history element that matches REGEXP.
1246 \(Previous history elements refer to earlier actions.)
1247 With prefix argument N, search for Nth previous match.
1248 If N is negative, find the next or Nth next match."
1249   (interactive
1250    (let ((enable-recursive-minibuffers t)
1251          (minibuffer-history-sexp-flag nil))
1252      (if (eq 't (symbol-value minibuffer-history-variable))
1253          (error "History is not being recorded in this context"))
1254      (list (read-from-minibuffer "Previous element matching (regexp): "
1255                                  (car minibuffer-history-search-history)
1256                                  minibuffer-local-map
1257                                  nil
1258                                  'minibuffer-history-search-history)
1259            (prefix-numeric-value current-prefix-arg))))
1260   (let ((history (symbol-value minibuffer-history-variable))
1261         prevpos
1262         (pos minibuffer-history-position))
1263     (if (eq history t)
1264         (error "History is not being recorded in this context"))
1265     (while (/= n 0)
1266       (setq prevpos pos)
1267       (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
1268       (if (= pos prevpos)
1269           (if (= pos 1) ;; rewritten for I18N3 snarfing
1270               (error "No later matching history item")
1271             (error "No earlier matching history item")))
1272       (if (string-match regexp
1273                         (if minibuffer-history-sexp-flag
1274                             (let ((print-level nil))
1275                               (prin1-to-string (nth (1- pos) history)))
1276                             (nth (1- pos) history)))
1277           (setq n (+ n (if (< n 0) 1 -1)))))
1278     (setq minibuffer-history-position pos)
1279     (setq current-minibuffer-contents (buffer-string)
1280           current-minibuffer-point (point))
1281     (erase-buffer)
1282     (let ((elt (nth (1- pos) history)))
1283       (insert (if minibuffer-history-sexp-flag
1284                   (let ((print-level nil))
1285                     (prin1-to-string elt))
1286                   elt)))
1287       (goto-char (point-min)))
1288   (if (or (eq (car (car command-history)) 'previous-matching-history-element)
1289           (eq (car (car command-history)) 'next-matching-history-element))
1290       (setq command-history (cdr command-history))))
1291
1292 (defun next-matching-history-element (regexp n)
1293   "Find the next history element that matches REGEXP.
1294 \(The next history element refers to a more recent action.)
1295 With prefix argument N, search for Nth next match.
1296 If N is negative, find the previous or Nth previous match."
1297   (interactive
1298    (let ((enable-recursive-minibuffers t)
1299          (minibuffer-history-sexp-flag nil))
1300      (if (eq t (symbol-value minibuffer-history-variable))
1301          (error "History is not being recorded in this context"))
1302      (list (read-from-minibuffer "Next element matching (regexp): "
1303                                  (car minibuffer-history-search-history)
1304                                  minibuffer-local-map
1305                                  nil
1306                                  'minibuffer-history-search-history)
1307            (prefix-numeric-value current-prefix-arg))))
1308   (previous-matching-history-element regexp (- n)))
1309
1310 (defun next-history-element (n)
1311   "Insert the next element of the minibuffer history into the minibuffer."
1312   (interactive "p")
1313   (if (eq 't (symbol-value minibuffer-history-variable))
1314       (error "History is not being recorded in this context"))
1315   (unless (zerop n)
1316     (when (eq minibuffer-history-position
1317               initial-minibuffer-history-position)
1318       (setq current-minibuffer-contents (buffer-string)
1319             current-minibuffer-point (point)))
1320     (let ((narg (- minibuffer-history-position n))
1321           (minimum (if minibuffer-default -1 0)))
1322       (cond ((< narg minimum)
1323              (error "No following item in %s" minibuffer-history-variable))
1324             ((> narg (length (symbol-value minibuffer-history-variable)))
1325              (error "No preceding item in %s" minibuffer-history-variable)))
1326       (erase-buffer)
1327       (setq minibuffer-history-position narg)
1328       (if (eq narg initial-minibuffer-history-position)
1329           (progn
1330             (insert current-minibuffer-contents)
1331             (goto-char current-minibuffer-point))
1332         (let ((elt (if (>= narg 0)
1333                        (nth (1- minibuffer-history-position)
1334                             (symbol-value minibuffer-history-variable))
1335                      minibuffer-default)))
1336           (insert
1337            (if (not (stringp elt))
1338                (let ((print-level nil))
1339                  (condition-case nil
1340                      (let ((print-readably t)
1341                            (print-escape-newlines t))
1342                        (prin1-to-string elt))
1343                    (error (prin1-to-string elt))))
1344              elt)))
1345         ;; FSF has point-min here.
1346         (goto-char (point-max))))))
1347
1348 (defun previous-history-element (n)
1349   "Insert the previous element of the minibuffer history into the minibuffer."
1350   (interactive "p")
1351   (next-history-element (- n)))
1352
1353 (defun next-complete-history-element (n)
1354   "Get next element of history which is a completion of minibuffer contents."
1355   (interactive "p")
1356   (let ((point-at-start (point)))
1357     (next-matching-history-element
1358      (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n)
1359     ;; next-matching-history-element always puts us at (point-min).
1360     ;; Move to the position we were at before changing the buffer contents.
1361     ;; This is still sensical, because the text before point has not changed.
1362     (goto-char point-at-start)))
1363
1364 (defun previous-complete-history-element (n)
1365   "Get previous element of history which is a completion of minibuffer contents."
1366   (interactive "p")
1367   (next-complete-history-element (- n)))
1368
1369 \f
1370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1371 ;;;;                reading various things from a minibuffer            ;;;;
1372 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1373
1374 (defun read-expression (prompt &optional initial-contents history)
1375   "Return a Lisp object read using the minibuffer.
1376 Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
1377 is a string to insert in the minibuffer before reading.
1378 Third arg HISTORY, if non-nil, specifies a history list."
1379   (let ((minibuffer-history-sexp-flag t)
1380         ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion.
1381         (minibuffer-completion-table nil))
1382     (read-from-minibuffer prompt
1383                           initial-contents
1384                           read-expression-map
1385                           t
1386                           (or history 'read-expression-history)
1387                           lisp-mode-abbrev-table)))
1388
1389 (defun read-string (prompt &optional initial-contents history)
1390   "Return a string from the minibuffer, prompting with string PROMPT.
1391 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
1392 in the minibuffer before reading.
1393 Third arg HISTORY, if non-nil, specifies a history list."
1394   (let ((minibuffer-completion-table nil))
1395     (read-from-minibuffer prompt
1396                           initial-contents
1397                           minibuffer-local-map
1398                           nil history)))
1399
1400 (defun eval-minibuffer (prompt &optional initial-contents history)
1401   "Return value of Lisp expression read using the minibuffer.
1402 Prompt with PROMPT.  If non-nil, optional second arg INITIAL-CONTENTS
1403 is a string to insert in the minibuffer before reading.
1404 Third arg HISTORY, if non-nil, specifies a history list."
1405   (eval (read-expression prompt initial-contents history)))
1406
1407 ;; The name `command-history' is already taken
1408 (defvar read-command-history '())
1409
1410 (defun read-command (prompt)
1411   "Read the name of a command and return as a symbol.
1412 Prompts with PROMPT."
1413   (intern (completing-read prompt obarray 'commandp t nil
1414                            ;; 'command-history is not right here: that's a
1415                            ;; list of evalable forms, not a history list.
1416                            'read-command-history
1417                            )))
1418
1419 (defun read-function (prompt)
1420   "Read the name of a function and return as a symbol.
1421 Prompts with PROMPT."
1422   (intern (completing-read prompt obarray 'fboundp t nil
1423                            'function-history)))
1424
1425 (defun read-variable (prompt)
1426   "Read the name of a user variable and return it as a symbol.
1427 Prompts with PROMPT.
1428 A user variable is one whose documentation starts with a `*' character."
1429   (intern (completing-read prompt obarray 'user-variable-p t nil
1430                            'variable-history)))
1431
1432 (defun read-buffer (prompt &optional default require-match)
1433   "Read the name of a buffer and return as a string.
1434 Prompts with PROMPT.  Optional second arg DEFAULT is value to return if user
1435 enters an empty line.  If optional third arg REQUIRE-MATCH is non-nil,
1436 only existing buffer names are allowed."
1437   (let ((prompt (if default
1438                     (format "%s(default %s) "
1439                             (gettext prompt) (if (bufferp default)
1440                                                  (buffer-name default)
1441                                                default))
1442                     prompt))
1443         (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
1444                        (buffer-list)))
1445         result)
1446     (while (progn
1447              (setq result (completing-read prompt alist nil require-match
1448                                            nil 'buffer-history
1449                                            (if (bufferp default)
1450                                                (buffer-name default)
1451                                              default)))
1452              (cond ((not (equal result ""))
1453                     nil)
1454                    ((not require-match)
1455                     (setq result default)
1456                     nil)
1457                    ((not default)
1458                     t)
1459                    ((not (get-buffer default))
1460                     t)
1461                    (t
1462                     (setq result default)
1463                     nil))))
1464     (if (bufferp result)
1465         (buffer-name result)
1466       result)))
1467
1468 (defun read-number (prompt &optional integers-only)
1469   "Read a number from the minibuffer."
1470   (let ((pred (if integers-only 'integerp 'numberp))
1471         num)
1472     (while (not (funcall pred num))
1473       (setq num (condition-case ()
1474                     (let ((minibuffer-completion-table nil))
1475                       (read-from-minibuffer
1476                        prompt (if num (prin1-to-string num)) nil t
1477                        t)) ;no history
1478                   (input-error nil)
1479                   (invalid-read-syntax nil)
1480                   (end-of-file nil)))
1481       (or (funcall pred num) (beep)))
1482     num))
1483
1484 (defun read-shell-command (prompt &optional initial-input history)
1485   "Just like read-string, but uses read-shell-command-map:
1486 \\{read-shell-command-map}"
1487   (let ((minibuffer-completion-table nil))
1488     (read-from-minibuffer prompt initial-input read-shell-command-map
1489                           nil (or history 'shell-command-history))))
1490
1491 \f
1492 ;;; This read-file-name stuff probably belongs in files.el
1493
1494 ;; Quote "$" as "$$" to get it past substitute-in-file-name
1495 (defun un-substitute-in-file-name (string)
1496   (let ((regexp "\\$")
1497         (olen (length string))
1498         new
1499         n o ch)
1500     (if (not (string-match regexp string))
1501         string
1502       (setq n 1)
1503       (while (string-match regexp string (match-end 0))
1504         (setq n (1+ n)))
1505       (setq new (make-string (+ olen n) ?$))
1506       (setq n 0 o 0)
1507       (while (< o olen)
1508         (setq ch (aref string o))
1509         (aset new n ch)
1510         (setq o (1+ o) n (1+ n))
1511         (if (eq ch ?$)
1512             ;; already aset by make-string initial-value
1513             (setq n (1+ n))))
1514       new)))
1515
1516 (defun read-file-name-2 (history prompt dir default
1517                                  must-match initial-contents
1518                                  completer)
1519   (if (not dir)
1520       (setq dir default-directory))
1521   (setq dir (abbreviate-file-name dir t))
1522   (let* ((insert (cond ((and (not insert-default-directory)
1523                              (not initial-contents))
1524                         "")
1525                        (initial-contents
1526                         (cons (un-substitute-in-file-name
1527                                (concat dir initial-contents))
1528                               (length dir)))
1529                        (t
1530                         (un-substitute-in-file-name dir))))
1531          (val
1532                 ;;  Hateful, broken, case-sensitive un*x
1533 ;;;                 (completing-read prompt
1534 ;;;                                  completer
1535 ;;;                                  dir
1536 ;;;                                  must-match
1537 ;;;                                  insert
1538 ;;;                                  history)
1539           ;; #### - this is essentially the guts of completing read.
1540           ;; There should be an elegant way to pass a pair of keymaps to
1541           ;; completing read, but this will do for now.  All sins are
1542           ;; relative.  --Stig
1543           (let ((minibuffer-completion-table completer)
1544                 (minibuffer-completion-predicate dir)
1545                 (minibuffer-completion-confirm (if (eq must-match 't)
1546                                                    nil t))
1547                 (last-exact-completion nil))
1548             (read-from-minibuffer prompt
1549                                   insert
1550                                   (if (not must-match)
1551                                       read-file-name-map
1552                                     read-file-name-must-match-map)
1553                                   nil
1554                                   history
1555                                   nil
1556                                   default))))
1557 ;;;     ;; Kludge!  Put "/foo/bar" on history rather than "/default//foo/bar"
1558 ;;;     (let ((hist (cond ((not history) 'minibuffer-history)
1559 ;;;                       ((consp history) (car history))
1560 ;;;                       (t history))))
1561 ;;;       (if (and val
1562 ;;;                hist
1563 ;;;                (not (eq hist 't))
1564 ;;;                (boundp hist)
1565 ;;;                (equal (car-safe (symbol-value hist)) val))
1566 ;;;           (let ((e (condition-case nil
1567 ;;;                        (expand-file-name val)
1568 ;;;                      (error nil))))
1569 ;;;             (if (and e (not (equal e val)))
1570 ;;;                 (set hist (cons e (cdr (symbol-value hist))))))))
1571
1572     (cond ((not val)
1573            (error "No file name specified"))
1574           ((and default
1575                 (equal val (if (consp insert) (car insert) insert)))
1576            default)
1577           (t
1578            (substitute-in-file-name val)))))
1579
1580 ;; #### this function should use minibuffer-completion-table
1581 ;; or something.  But that is sloooooow.
1582 ;; #### all this shit needs better documentation!!!!!!!!
1583 (defun read-file-name-activate-callback (event extent dir-p)
1584   ;; used as the activate-callback of the filename list items
1585   ;; in the completion buffer, in place of default-choose-completion.
1586   ;; if a regular file was selected, we call default-choose-completion
1587   ;; (which just inserts the string in the minibuffer and calls
1588   ;; exit-minibuffer).  If a directory was selected, we display
1589   ;; the contents of the directory.
1590   (let* ((file (extent-string extent))
1591          (completion-buf (extent-object extent))
1592          (minibuf (symbol-value-in-buffer 'completion-reference-buffer
1593                                           completion-buf))
1594          (in-dir (file-name-directory (buffer-substring nil nil minibuf)))
1595          (full (expand-file-name file in-dir)))
1596     (if (not (file-directory-p full))
1597         (default-choose-completion event extent minibuf)
1598       (erase-buffer minibuf)
1599       (insert-string (file-name-as-directory
1600                       (abbreviate-file-name full t)) minibuf)
1601       (reset-buffer completion-buf)
1602       (let ((standard-output completion-buf))
1603         (display-completion-list
1604          (delete "." (directory-files full nil nil nil (if dir-p 'directory)))
1605          :user-data dir-p
1606          :reference-buffer minibuf
1607          :activate-callback 'read-file-name-activate-callback)
1608         (goto-char (point-min) completion-buf)))))
1609
1610 (defun read-file-name-1 (history prompt dir default
1611                                  must-match initial-contents
1612                                  completer)
1613   (if (should-use-dialog-box-p)
1614       ;; this calls read-file-name-2
1615       (mouse-read-file-name-1 history prompt dir default must-match
1616                               initial-contents completer)
1617     (let ((rfhookfun
1618            (lambda ()
1619              ;; #### SCREAM!  Create a `file-system-ignore-case'
1620              ;; function, so this kind of stuff is generalized!
1621              (and (eq system-type 'windows-nt)
1622                   (set (make-local-variable 'completion-ignore-case) t))
1623              (set
1624               (make-local-variable
1625                'completion-display-completion-list-function)
1626               #'(lambda (completions)
1627                   (display-completion-list
1628                    completions
1629                    :user-data (not (eq completer 'read-file-name-internal))
1630                    :activate-callback
1631                    'read-file-name-activate-callback)))
1632              ;; kludge!
1633              (remove-hook 'minibuffer-setup-hook rfhookfun)
1634              )))
1635       (unwind-protect
1636           (progn
1637             (add-hook 'minibuffer-setup-hook rfhookfun)
1638             (read-file-name-2 history prompt dir default must-match
1639                               initial-contents completer))
1640         (remove-hook 'minibuffer-setup-hook rfhookfun)))))
1641
1642 (defun read-file-name (prompt
1643                        &optional dir default must-match initial-contents
1644                        history)
1645   "Read file name, prompting with PROMPT and completing in directory DIR.
1646 This will prompt with a dialog box if appropriate, according to
1647  `should-use-dialog-box-p'.
1648 Value is not expanded---you must call `expand-file-name' yourself.
1649 Value is subject to interpreted by substitute-in-file-name however.
1650 Default name to DEFAULT if user enters a null string.
1651  (If DEFAULT is omitted, the visited file name is used,
1652   except that if INITIAL-CONTENTS is specified, that combined with DIR is
1653   used.)
1654 Fourth arg MUST-MATCH non-nil means require existing file's name.
1655  Non-nil and non-t means also require confirmation after completion.
1656 Fifth arg INITIAL-CONTENTS specifies text to start with.
1657 Sixth arg HISTORY specifies the history list to use.  Default is
1658  `file-name-history'.
1659 DIR defaults to current buffer's directory default."
1660   (read-file-name-1
1661    (or history 'file-name-history)
1662    prompt dir (or default
1663                   (if initial-contents (expand-file-name initial-contents dir)
1664                     buffer-file-name))
1665    must-match initial-contents
1666    ;; A separate function (not an anonymous lambda-expression)
1667    ;; and passed as a symbol because of disgusting kludges in various
1668    ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...)
1669    'read-file-name-internal))
1670
1671 (defun read-directory-name (prompt
1672                             &optional dir default must-match initial-contents
1673                             history)
1674   "Read directory name, prompting with PROMPT and completing in directory DIR.
1675 This will prompt with a dialog box if appropriate, according to
1676  `should-use-dialog-box-p'.
1677 Value is not expanded---you must call `expand-file-name' yourself.
1678 Value is subject to interpreted by substitute-in-file-name however.
1679 Default name to DEFAULT if user enters a null string.
1680  (If DEFAULT is omitted, the current buffer's default directory is used.)
1681 Fourth arg MUST-MATCH non-nil means require existing directory's name.
1682  Non-nil and non-t means also require confirmation after completion.
1683 Fifth arg INITIAL-CONTENTS specifies text to start with.
1684 Sixth arg HISTORY specifies the history list to use.  Default is
1685  `file-name-history'.
1686 DIR defaults to current buffer's directory default."
1687   (read-file-name-1
1688     (or history 'file-name-history)
1689     prompt dir (or default default-directory) must-match initial-contents
1690     'read-directory-name-internal))
1691
1692
1693 ;; Environment-variable and ~username completion hack
1694 (defun read-file-name-internal-1 (string dir action completer)
1695   (if (not (string-match
1696             "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'"
1697             string))
1698       ;; Not doing environment-variable completion hack
1699       (let* ((orig (if (equal string "") nil string))
1700              (sstring (if orig (substitute-in-file-name string) string))
1701              (specdir (if orig (file-name-directory sstring) nil))
1702              (name    (if orig (file-name-nondirectory sstring) string))
1703              (direct  (if specdir (expand-file-name specdir dir) dir)))
1704         ;; ~username completion
1705         (if (and (fboundp 'user-name-completion-1)
1706                  (string-match "^[~]" name))
1707             (let ((user (substring name 1)))
1708               (cond ((eq action 'lambda)
1709                      (file-directory-p name))
1710                     ((eq action 't)
1711                      ;; all completions
1712                      (mapcar #'(lambda (p) (concat "~" p))
1713                              (user-name-all-completions user)))
1714                     (t;; 'nil
1715                      ;; complete
1716                      (let* ((val+uniq (user-name-completion-1 user))
1717                             (val  (car val+uniq))
1718                             (uniq (cdr val+uniq)))
1719                        (cond ((stringp val)
1720                               (if uniq
1721                                   (file-name-as-directory (concat "~" val))
1722                                 (concat "~" val)))
1723                              ((eq val t)
1724                               (file-name-as-directory name))
1725                              (t nil))))))
1726           (funcall completer
1727                    action
1728                    orig
1729                    sstring
1730                    specdir
1731                    direct
1732                    name)))
1733       ;; An odd number of trailing $'s
1734       (let* ((start (match-beginning 3))
1735              (env (substring string
1736                              (cond ((= start (length string))
1737                                     ;; "...$"
1738                                     start)
1739                                    ((= (aref string start) ?{)
1740                                     ;; "...${..."
1741                                     (1+ start))
1742                                    (t
1743                                     start))))
1744              (head (substring string 0 (1- start)))
1745              (alist #'(lambda ()
1746                         (mapcar #'(lambda (x)
1747                                     (cons (substring x 0 (string-match "=" x))
1748                                           nil))
1749                                 process-environment))))
1750
1751         (cond ((eq action 'lambda)
1752                nil)
1753               ((eq action 't)
1754                ;; all completions
1755                (mapcar #'(lambda (p)
1756                            (if (and (> (length p) 0)
1757                                     ;;#### Unix-specific
1758                                     ;;####  -- need absolute-pathname-p
1759                                     (/= (aref p 0) ?/))
1760                                (concat "$" p)
1761                              (concat head "$" p)))
1762                        (all-completions env (funcall alist))))
1763               (t ;; nil
1764                ;; complete
1765                (let* ((e (funcall alist))
1766                       (val (try-completion env e)))
1767                  (cond ((stringp val)
1768                         (if (string-match "[^A-Za-z0-9_]" val)
1769                             (concat head
1770                                     "${" val
1771                                     ;; completed uniquely?
1772                                     (if (eq (try-completion val e) 't)
1773                                         "}" ""))
1774                             (concat head "$" val)))
1775                        ((eql val 't)
1776                         (concat head
1777                                 (un-substitute-in-file-name (getenv env))))
1778                        (t nil))))))))
1779
1780
1781 (defun read-file-name-internal (string dir action)
1782   (read-file-name-internal-1
1783    string dir action
1784    #'(lambda (action orig string specdir dir name)
1785       (cond ((eq action 'lambda)
1786              (if (not orig)
1787                  nil
1788                (let ((sstring (condition-case nil
1789                                   (expand-file-name string)
1790                                 (error nil))))
1791                  (if (not sstring)
1792                      ;; Some pathname syntax error in string
1793                      nil
1794                      (file-exists-p sstring)))))
1795             ((eq action 't)
1796              ;; all completions
1797              (mapcar #'un-substitute-in-file-name
1798                      (file-name-all-completions name dir)))
1799             (t;; nil
1800              ;; complete
1801              (let* ((d (or dir default-directory))
1802                     (val (file-name-completion name d)))
1803                (if (and (eq val 't)
1804                         (not (null completion-ignored-extensions)))
1805                    ;;#### (file-name-completion "foo") returns 't
1806                    ;;   when both "foo" and "foo~" exist and the latter
1807                    ;;   is "pruned" by completion-ignored-extensions.
1808                    ;; I think this is a bug in file-name-completion.
1809                    (setq val (let ((completion-ignored-extensions '()))
1810                                (file-name-completion name d))))
1811                (if (stringp val)
1812                    (un-substitute-in-file-name (if specdir
1813                                                    (concat specdir val)
1814                                                    val))
1815                    (let ((tem (un-substitute-in-file-name string)))
1816                      (if (not (equal tem orig))
1817                          ;; substitute-in-file-name did something
1818                          tem
1819                          val)))))))))
1820
1821 (defun read-directory-name-internal (string dir action)
1822   (read-file-name-internal-1
1823    string dir action
1824    #'(lambda (action orig string specdir dir name)
1825       (let* ((dirs #'(lambda (fn)
1826                        (let ((l (if (equal name "")
1827                                     (directory-files
1828                                      dir
1829                                      nil
1830                                      ""
1831                                      nil
1832                                      'directories)
1833                                   (directory-files
1834                                    dir
1835                                    nil
1836                                    (concat "\\`" (regexp-quote name))
1837                                    nil
1838                                    'directories))))
1839                          (mapcar fn
1840                                  ;; Wretched unix
1841                                  (delete "." l))))))
1842         (cond ((eq action 'lambda)
1843                ;; complete?
1844                (if (not orig)
1845                    nil
1846                  (file-directory-p string)))
1847               ((eq action 't)
1848                ;; all completions
1849                (funcall dirs #'(lambda (n)
1850                                  (un-substitute-in-file-name
1851                                   (file-name-as-directory n)))))
1852               (t
1853                ;; complete
1854                (let ((val (try-completion
1855                            name
1856                            (funcall dirs
1857                                     #'(lambda (n)
1858                                         (list (file-name-as-directory
1859                                                n)))))))
1860                  (if (stringp val)
1861                      (un-substitute-in-file-name (if specdir
1862                                                      (concat specdir val)
1863                                                    val))
1864                    (let ((tem (un-substitute-in-file-name string)))
1865                      (if (not (equal tem orig))
1866                          ;; substitute-in-file-name did something
1867                          tem
1868                        val))))))))))
1869
1870 (defun append-expand-filename (file-string string)
1871   "Append STRING to FILE-STRING differently depending on whether STRING
1872 is a username (~string), an environment variable ($string),
1873 or a filename (/string).  The resultant string is returned with the
1874 environment variable or username expanded and resolved to indicate
1875 whether it is a file(/result) or a directory (/result/)."
1876   (let ((file
1877          (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string)
1878                 (cond ((string= (substring file-string
1879                                            (match-beginning 1)
1880                                            (match-end 1)) "~")
1881                        (concat (substring file-string 0 (match-end 1))
1882                                string))
1883                       (t (substitute-in-file-name
1884                           (concat (substring file-string 0 (match-end 1))
1885                                   string)))))
1886                (t (concat (file-name-directory
1887                            (substitute-in-file-name file-string)) string))))
1888         result)
1889
1890     (cond ((stringp (setq result (and (file-exists-p (expand-file-name file))
1891                                       (read-file-name-internal
1892                                        (condition-case nil
1893                                            (expand-file-name file)
1894                                          (error file))
1895                                        "" nil))))
1896            result)
1897           (t file))))
1898
1899 (defun mouse-file-display-completion-list (window dir minibuf user-data)
1900   (let ((standard-output (window-buffer window)))
1901     (condition-case nil
1902         (display-completion-list
1903          (directory-files dir nil nil nil t)
1904          :window-width (* 2 (window-width window))
1905          :activate-callback
1906          'mouse-read-file-name-activate-callback
1907          :user-data user-data
1908          :reference-buffer minibuf
1909          :help-string "")
1910       (t nil))))
1911
1912 (defun mouse-directory-display-completion-list (window dir minibuf user-data)
1913   (let ((standard-output (window-buffer window)))
1914     (condition-case nil
1915         (display-completion-list
1916          (delete "." (directory-files dir nil nil nil 1))
1917          :window-width (window-width window)
1918          :activate-callback
1919          'mouse-read-file-name-activate-callback
1920          :user-data user-data
1921          :reference-buffer minibuf
1922          :help-string "")
1923       (t nil))))
1924
1925 (defun mouse-read-file-name-activate-callback (event extent user-data)
1926   (let* ((file (extent-string extent))
1927          (minibuf (symbol-value-in-buffer 'completion-reference-buffer
1928                                           (extent-object extent)))
1929          (in-dir (buffer-substring nil nil minibuf))
1930          (full (expand-file-name file in-dir))
1931          (filebuf (nth 0 user-data))
1932          (dirbuff (nth 1 user-data))
1933          (filewin (nth 2 user-data))
1934          (dirwin (nth 3 user-data)))
1935     (if (file-regular-p full)
1936         (default-choose-completion event extent minibuf)
1937       (erase-buffer minibuf)
1938       (insert-string (file-name-as-directory
1939                       (abbreviate-file-name full t)) minibuf)
1940       (reset-buffer filebuf)
1941       (if (not dirbuff)
1942           (mouse-directory-display-completion-list filewin full minibuf
1943                                                    user-data)
1944         (mouse-file-display-completion-list filewin full minibuf user-data)
1945         (reset-buffer dirbuff)
1946         (mouse-directory-display-completion-list dirwin full minibuf
1947                                                  user-data)))))
1948
1949 ;; this is rather cheesified but gets the job done.
1950 (defun mouse-read-file-name-1 (history prompt dir default
1951                                  must-match initial-contents
1952                                  completer)
1953   (let* ((file-p (eq 'read-file-name-internal completer))
1954          (filebuf (get-buffer-create "*Completions*"))
1955          (dirbuff (and file-p (generate-new-buffer " *mouse-read-file*")))
1956          (butbuff (generate-new-buffer " *mouse-read-file*"))
1957          (frame (make-dialog-frame))
1958          filewin dirwin
1959          user-data)
1960     (unwind-protect
1961         (progn
1962           (reset-buffer filebuf)
1963           (select-frame frame)
1964           (let ((window-min-height 1))
1965             ;; #### should be 2 not 3, but that causes
1966             ;; "window too small to split" errors for some
1967             ;; people (but not for me ...) There's a more
1968             ;; fundamental bug somewhere.
1969             (split-window nil (- (frame-height frame) 3)))
1970           (if file-p
1971               (progn
1972                 (split-window-horizontally 16)
1973                 (setq filewin (frame-rightmost-window frame)
1974                       dirwin (frame-leftmost-window frame))
1975                 (set-window-buffer filewin filebuf)
1976                 (set-window-buffer dirwin dirbuff))
1977             (setq filewin (frame-highest-window frame))
1978             (set-window-buffer filewin filebuf))
1979           (setq user-data (list filebuf dirbuff filewin dirwin))
1980           (set-window-buffer (frame-lowest-window frame) butbuff)
1981           (set-buffer butbuff)
1982           (when dir
1983             (setq default-directory dir))
1984           (when (featurep 'scrollbar)
1985             (set-specifier scrollbar-width 0 butbuff))
1986           (insert "                 ")
1987           (insert-gui-button (make-gui-button "OK"
1988                                               (lambda (foo)
1989                                                 (exit-minibuffer))))
1990           (insert "                 ")
1991           (insert-gui-button (make-gui-button "Cancel"
1992                                               (lambda (foo)
1993                                                 (abort-recursive-edit))))
1994           (let ((rfhookfun
1995                  (lambda ()
1996                    (if (not file-p)
1997                        (mouse-directory-display-completion-list
1998                         filewin dir (current-buffer) user-data)
1999                      (mouse-file-display-completion-list filewin dir
2000                                                          (current-buffer)
2001                                                          user-data)
2002                      (mouse-directory-display-completion-list dirwin dir
2003                                                               (current-buffer)
2004                                                               user-data))
2005                    (set
2006                     (make-local-variable
2007                      'completion-display-completion-list-function)
2008                     #'(lambda (completions)
2009                         (display-completion-list
2010                          completions
2011                          :help-string ""
2012                          :activate-callback
2013                          'mouse-read-file-name-activate-callback
2014                          :user-data user-data)))
2015                    ;; kludge!
2016                    (remove-hook 'minibuffer-setup-hook rfhookfun)
2017                    ))
2018                 (rfcshookfun
2019                  ;; kludge!
2020                  ;; #### I really need to flesh out the object
2021                  ;; hierarchy better to avoid these kludges.
2022                  (lambda ()
2023                    (save-excursion
2024                      (set-buffer standard-output)
2025                      (setq truncate-lines t)))))
2026             (unwind-protect
2027                 (progn
2028                   (add-hook 'minibuffer-setup-hook rfhookfun)
2029                   (add-hook 'completion-setup-hook rfcshookfun)
2030                   (read-file-name-2 history prompt dir default
2031                                     must-match initial-contents
2032                                     completer))
2033               (remove-hook 'minibuffer-setup-hook rfhookfun)
2034               (remove-hook 'completion-setup-hook rfcshookfun))))
2035       (delete-frame frame)
2036       (kill-buffer filebuf)
2037       (kill-buffer butbuff)
2038       (and dirbuff (kill-buffer dirbuff)))))
2039
2040 (defun read-face (prompt &optional must-match)
2041   "Read the name of a face from the minibuffer and return it as a symbol."
2042   (intern (completing-read prompt obarray 'find-face must-match)))
2043
2044 ;; #### - wrong place for this variable?  Exactly.  We probably want
2045 ;; `color-list' to be a console method, so `tty-color-list' becomes
2046 ;; obsolete, and `read-color-completion-table' conses (mapcar #'list
2047 ;; (color-list)), optionally caching the results.
2048
2049 ;; Ben wanted all of the possibilities from the `configure' script used
2050 ;; here, but I think this is way too many.  I already trimmed the R4 variants
2051 ;; and a few obvious losers from the list.  --Stig
2052 (defvar x-library-search-path '("/usr/X11R6/lib/X11/"
2053                                 "/usr/X11R5/lib/X11/"
2054                                 "/usr/lib/X11R6/X11/"
2055                                 "/usr/lib/X11R5/X11/"
2056                                 "/usr/local/X11R6/lib/X11/"
2057                                 "/usr/local/X11R5/lib/X11/"
2058                                 "/usr/local/lib/X11R6/X11/"
2059                                 "/usr/local/lib/X11R5/X11/"
2060                                 "/usr/X11/lib/X11/"
2061                                 "/usr/lib/X11/"
2062                                 "/usr/local/lib/X11/"
2063                                 "/usr/X386/lib/X11/"
2064                                 "/usr/x386/lib/X11/"
2065                                 "/usr/XFree86/lib/X11/"
2066                                 "/usr/unsupported/lib/X11/"
2067                                 "/usr/athena/lib/X11/"
2068                                 "/usr/local/x11r5/lib/X11/"
2069                                 "/usr/lpp/Xamples/lib/X11/"
2070                                 "/usr/openwin/lib/X11/"
2071                                 "/usr/openwin/share/lib/X11/")
2072   "Search path used by `read-color' to find rgb.txt.")
2073
2074 (defvar x-read-color-completion-table)
2075
2076 (defun read-color-completion-table ()
2077   (case (device-type)
2078     ;; #### Evil device-type dependency
2079     (x
2080      (if (boundp 'x-read-color-completion-table)
2081          x-read-color-completion-table
2082        (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
2083              clist color p)
2084          (if (not rgb-file)
2085              ;; prevents multiple searches for rgb.txt if we can't find it
2086              (setq x-read-color-completion-table nil)
2087            (with-current-buffer (get-buffer-create " *colors*")
2088              (reset-buffer (current-buffer))
2089              (insert-file-contents rgb-file)
2090              (while (not (eobp))
2091                ;; skip over comments
2092                (while (looking-at "^!")
2093                  (end-of-line)
2094                  (forward-char 1))
2095                (skip-chars-forward "0-9 \t")
2096                (setq p (point))
2097                (end-of-line)
2098                (setq color (buffer-substring p (point))
2099                      clist (cons (list color) clist))
2100                ;; Ugh.  If we want to be able to complete the lowercase form
2101                ;; of the color name, we need to add it twice!  Yuck.
2102                (let ((dcase (downcase color)))
2103                  (or (string= dcase color)
2104                      (push (list dcase) clist)))
2105                (forward-char 1))
2106              (kill-buffer (current-buffer))))
2107          (setq x-read-color-completion-table clist)
2108          x-read-color-completion-table)))
2109     (mswindows
2110      (mapcar #'list (mswindows-color-list)))
2111     (tty
2112      (mapcar #'list (tty-color-list)))))
2113
2114 (defun read-color (prompt &optional must-match initial-contents)
2115   "Read the name of a color from the minibuffer.
2116 On X devices, this uses `x-library-search-path' to find rgb.txt in order
2117  to build a completion table.
2118 On TTY devices, this uses `tty-color-list'.
2119 On mswindows devices, this uses `mswindows-color-list'."
2120   (let ((table (read-color-completion-table)))
2121     (completing-read prompt table nil (and table must-match)
2122                      initial-contents)))
2123
2124 \f
2125 ;; #### The doc string for read-non-nil-coding system gets lost if we
2126 ;; only include these if the mule feature is present.  Strangely,
2127 ;; read-coding-system doesn't.
2128
2129 ;;(if (featurep 'mule)
2130
2131 (defun read-coding-system (prompt &optional default-coding-system)
2132   "Read a coding-system (or nil) from the minibuffer.
2133 Prompting with string PROMPT.
2134 If the user enters null input, return second argument DEFAULT-CODING-SYSTEM.
2135 DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object."
2136   (intern (completing-read prompt obarray 'find-coding-system t nil nil
2137                            (cond ((symbolp default-coding-system)
2138                                   (symbol-name default-coding-system))
2139                                  ((coding-system-p default-coding-system)
2140                                   (symbol-name (coding-system-name default-coding-system)))
2141                                  (t
2142                                   default-coding-system)))))
2143
2144 (defun read-non-nil-coding-system (prompt)
2145   "Read a non-nil coding-system from the minibuffer.
2146 Prompt with string PROMPT."
2147   (let ((retval (intern "")))
2148     (while (= 0 (length (symbol-name retval)))
2149       (setq retval (intern (completing-read prompt obarray
2150                                             'find-coding-system
2151                                             t))))
2152     retval))
2153
2154 ;;) ;; end of (featurep 'mule)
2155
2156 \f
2157
2158 (defcustom force-dialog-box-use nil
2159   "*If non-nil, always use a dialog box for asking questions, if possible.
2160 You should *bind* this, not set it.  This is useful if you're doing
2161 something mousy but which wasn't actually invoked using the mouse."
2162   :type 'boolean
2163   :group 'minibuffer)
2164
2165 ;; We include this here rather than dialog.el so it is defined
2166 ;; even when dialog boxes are not present.
2167 (defun should-use-dialog-box-p ()
2168   "If non-nil, questions should be asked with a dialog box instead of the
2169 minibuffer.  This looks at `last-command-event' to see if it was a mouse
2170 event, and checks whether dialog-support exists and the current device
2171 supports dialog boxes.
2172
2173 The dialog box is totally disabled if the variable `use-dialog-box'
2174 is set to nil."
2175   (and (featurep 'dialog)
2176        (device-on-window-system-p)
2177        use-dialog-box
2178        (or force-dialog-box-use
2179            (button-press-event-p last-command-event)
2180            (button-release-event-p last-command-event)
2181            (misc-user-event-p last-command-event))))
2182
2183 ;;; minibuf.el ends here