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