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