428
+ − 1 ;;; minibuf.el --- Minibuffer functions for XEmacs
+ − 2
+ − 3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc.
442
+ − 4 ;; Copyright (C) 1995 Tinker Systems.
+ − 5 ;; Copyright (C) 1995, 1996, 2000 Ben Wing.
428
+ − 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
442
+ − 55 previous occurrences of the same item from the history list first,
428
+ − 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
438
+ − 80 (defcustom minibuffer-confirm-incomplete nil
428
+ − 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
438
+ − 83 response. This is helpful for catching typos, etc."
+ − 84 :type 'boolean
+ − 85 :group 'minibuffer)
428
+ − 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
442
+ − 114 ;; see comment at list-mode-hook.
+ − 115 (put 'minibuffer-setup-hook 'permanent-local t)
+ − 116
428
+ − 117 (defvar minibuffer-exit-hook nil
+ − 118 "Normal hook run just after exit from minibuffer.")
442
+ − 119 (put 'minibuffer-exit-hook 'permanent-local t)
428
+ − 120
+ − 121 (defvar minibuffer-help-form nil
+ − 122 "Value that `help-form' takes on inside the minibuffer.")
+ − 123
+ − 124 (defvar minibuffer-default nil
+ − 125 "Default value for minibuffer input.")
+ − 126
+ − 127 (defvar minibuffer-local-map
+ − 128 (let ((map (make-sparse-keymap 'minibuffer-local-map)))
+ − 129 map)
+ − 130 "Default keymap to use when reading from the minibuffer.")
+ − 131
+ − 132 (defvar minibuffer-local-completion-map
+ − 133 (let ((map (make-sparse-keymap 'minibuffer-local-completion-map)))
+ − 134 (set-keymap-parents map (list minibuffer-local-map))
+ − 135 map)
+ − 136 "Local keymap for minibuffer input with completion.")
+ − 137
+ − 138 (defvar minibuffer-local-must-match-map
+ − 139 (let ((map (make-sparse-keymap 'minibuffer-must-match-map)))
+ − 140 (set-keymap-parents map (list minibuffer-local-completion-map))
+ − 141 map)
+ − 142 "Local keymap for minibuffer input with completion, for exact match.")
+ − 143
+ − 144 ;; (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit)
+ − 145 (define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el
+ − 146 (define-key minibuffer-local-map "\r" 'exit-minibuffer)
+ − 147 (define-key minibuffer-local-map "\n" 'exit-minibuffer)
+ − 148
+ − 149 ;; Historical crock. Unused by anything but user code, if even that
+ − 150 ;(defvar minibuffer-local-ns-map
+ − 151 ; (let ((map (make-sparse-keymap 'minibuffer-local-ns-map)))
+ − 152 ; (set-keymap-parents map (list minibuffer-local-map))
+ − 153 ; map)
+ − 154 ; "Local keymap for the minibuffer when spaces are not allowed.")
+ − 155 ;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer)
+ − 156 ;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer)
+ − 157 ;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit)
+ − 158
+ − 159 (define-key minibuffer-local-completion-map "\t" 'minibuffer-complete)
+ − 160 (define-key minibuffer-local-completion-map " " 'minibuffer-complete-word)
+ − 161 (define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help)
+ − 162 (define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit)
+ − 163 (define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit)
+ − 164
+ − 165 (define-key minibuffer-local-map "\M-n" 'next-history-element)
+ − 166 (define-key minibuffer-local-map "\M-p" 'previous-history-element)
+ − 167 (define-key minibuffer-local-map '[next] "\M-n")
+ − 168 (define-key minibuffer-local-map '[prior] "\M-p")
+ − 169 (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element)
+ − 170 (define-key minibuffer-local-map "\M-s" 'next-matching-history-element)
+ − 171 (define-key minibuffer-local-must-match-map [next]
+ − 172 'next-complete-history-element)
+ − 173 (define-key minibuffer-local-must-match-map [prior]
+ − 174 'previous-complete-history-element)
+ − 175
+ − 176 ;; This is an experiment--make up and down arrows do history.
+ − 177 (define-key minibuffer-local-map [up] 'previous-history-element)
+ − 178 (define-key minibuffer-local-map [down] 'next-history-element)
+ − 179 (define-key minibuffer-local-completion-map [up] 'previous-history-element)
+ − 180 (define-key minibuffer-local-completion-map [down] 'next-history-element)
+ − 181 (define-key minibuffer-local-must-match-map [up] 'previous-history-element)
+ − 182 (define-key minibuffer-local-must-match-map [down] 'next-history-element)
+ − 183
+ − 184 (defvar read-expression-map (let ((map (make-sparse-keymap
+ − 185 'read-expression-map)))
+ − 186 (set-keymap-parents map
+ − 187 (list minibuffer-local-map))
+ − 188 (define-key map "\M-\t" 'lisp-complete-symbol)
+ − 189 map)
+ − 190 "Minibuffer keymap used for reading Lisp expressions.")
+ − 191
+ − 192 (defvar read-shell-command-map
+ − 193 (let ((map (make-sparse-keymap 'read-shell-command-map)))
+ − 194 (set-keymap-parents map (list minibuffer-local-map))
+ − 195 (define-key map "\t" 'comint-dynamic-complete)
+ − 196 (define-key map "\M-\t" 'comint-dynamic-complete)
+ − 197 (define-key map "\M-?" 'comint-dynamic-list-completions)
+ − 198 map)
444
+ − 199 "Minibuffer keymap used by `shell-command' and related commands.")
428
+ − 200
+ − 201 (defcustom use-dialog-box t
+ − 202 "*Variable controlling usage of the dialog box.
+ − 203 If nil, the dialog box will never be used, even in response to mouse events."
+ − 204 :type 'boolean
+ − 205 :group 'minibuffer)
+ − 206
+ − 207 (defcustom minibuffer-electric-file-name-behavior t
+ − 208 "*If non-nil, slash and tilde in certain places cause immediate deletion.
+ − 209 These are the same places where this behavior would occur later on anyway,
+ − 210 in `substitute-in-file-name'."
+ − 211 :type 'boolean
+ − 212 :group 'minibuffer)
+ − 213
+ − 214 ;; originally by Stig@hackvan.com
+ − 215 (defun minibuffer-electric-separator ()
+ − 216 (interactive)
+ − 217 (let ((c last-command-char))
+ − 218 (and minibuffer-electric-file-name-behavior
+ − 219 (eq c directory-sep-char)
+ − 220 (eq c (char-before (point)))
+ − 221 (not (save-excursion
+ − 222 (goto-char (point-min))
+ − 223 (and (looking-at "/.+:~?[^/]*/.+")
+ − 224 (re-search-forward "^/.+:~?[^/]*" nil t)
+ − 225 (progn
+ − 226 (delete-region (point) (point-max))
+ − 227 t))))
+ − 228 (not (save-excursion
+ − 229 (goto-char (point-min))
+ − 230 (and (looking-at ".+://[^/]*/.+")
+ − 231 (re-search-forward "^.+:/" nil t)
+ − 232 (progn
+ − 233 (delete-region (point) (point-max))
+ − 234 t))))
+ − 235 ;; permit `//hostname/path/to/file'
+ − 236 (not (eq (point) (1+ (point-min))))
+ − 237 ;; permit `http://url/goes/here'
+ − 238 (or (not (eq ?: (char-after (- (point) 2))))
+ − 239 (eq ?/ (char-after (point-min))))
+ − 240 (delete-region (point-min) (point)))
+ − 241 (insert c)))
+ − 242
+ − 243 (defun minibuffer-electric-tilde ()
+ − 244 (interactive)
+ − 245 (and minibuffer-electric-file-name-behavior
+ − 246 (eq directory-sep-char (char-before (point)))
+ − 247 ;; permit URL's with //, for e.g. http://hostname/~user
+ − 248 (not (save-excursion (search-backward "//" nil t)))
+ − 249 (delete-region (point-min) (point)))
+ − 250 (insert ?~))
+ − 251
+ − 252
+ − 253 (defvar read-file-name-map
+ − 254 (let ((map (make-sparse-keymap 'read-file-name-map)))
+ − 255 (set-keymap-parents map (list minibuffer-local-completion-map))
+ − 256 (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
+ − 257 (define-key map "~" 'minibuffer-electric-tilde)
+ − 258 map
+ − 259 ))
+ − 260
+ − 261 (defvar read-file-name-must-match-map
+ − 262 (let ((map (make-sparse-keymap 'read-file-name-map)))
+ − 263 (set-keymap-parents map (list minibuffer-local-must-match-map))
+ − 264 (define-key map (vector directory-sep-char) 'minibuffer-electric-separator)
+ − 265 (define-key map "~" 'minibuffer-electric-tilde)
+ − 266 map
+ − 267 ))
+ − 268
+ − 269 (defun minibuffer-keyboard-quit ()
+ − 270 "Abort recursive edit.
+ − 271 If `zmacs-regions' is true, and the zmacs region is active in this buffer,
+ − 272 then this key deactivates the region without beeping."
+ − 273 (interactive)
+ − 274 (if (and (region-active-p)
+ − 275 (eq (current-buffer) (zmacs-region-buffer)))
+ − 276 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
+ − 277 ;; deactivating the region. If it is inactive, beep.
+ − 278 nil
+ − 279 (abort-recursive-edit)))
+ − 280
+ − 281 ;;;; Guts of minibuffer invocation
+ − 282
+ − 283 ;;#### The only things remaining in C are
+ − 284 ;; "Vminibuf_prompt" and the display junk
+ − 285 ;; "minibuf_prompt_width" and "minibuf_prompt_pix_width"
+ − 286 ;; Also "active_frame", though I suspect I could already
+ − 287 ;; hack that in Lisp if I could make any sense of the
+ − 288 ;; complete mess of frame/frame code in XEmacs.
+ − 289 ;; Vminibuf_prompt could easily be made Lisp-bindable.
+ − 290 ;; I suspect that minibuf_prompt*_width are actually recomputed
+ − 291 ;; by redisplay as needed -- or could be arranged to be so --
+ − 292 ;; and that there could be need for read-minibuffer-internal to
+ − 293 ;; save and restore them.
+ − 294 ;;#### The only other thing which read-from-minibuffer-internal does
+ − 295 ;; which we can't presently do in Lisp is move the frame cursor
+ − 296 ;; to the start of the minibuffer line as it returns. This is
+ − 297 ;; a rather nice touch and should be preserved -- probably by
+ − 298 ;; providing some Lisp-level mechanism (extension to cursor-in-echo-area ?)
+ − 299 ;; to effect it.
+ − 300
+ − 301
+ − 302 ;; Like reset_buffer in FSF's buffer.c
+ − 303 ;; (Except that kill-all-local-variables doesn't nuke 'permanent-local
+ − 304 ;; variables -- we preserve them, reset_buffer doesn't.)
+ − 305 (defun reset-buffer (buffer)
+ − 306 (with-current-buffer buffer
+ − 307 ;(if (fboundp 'unlock-buffer) (unlock-buffer))
+ − 308 (kill-all-local-variables)
+ − 309 (setq buffer-read-only nil)
+ − 310 ;; don't let read only text yanked into the minibuffer
+ − 311 ;; permanently wedge it.
+ − 312 (make-local-variable 'inhibit-read-only)
+ − 313 (setq inhibit-read-only t)
+ − 314 (erase-buffer)
+ − 315 ;(setq default-directory nil)
+ − 316 (setq buffer-file-name nil)
+ − 317 (setq buffer-file-truename nil)
+ − 318 (set-buffer-modified-p nil)
+ − 319 (setq buffer-backed-up nil)
+ − 320 (setq buffer-auto-save-file-name nil)
+ − 321 (set-buffer-dedicated-frame buffer nil)
+ − 322 buffer))
+ − 323
+ − 324 (defvar minibuffer-history-variable 'minibuffer-history
+ − 325 "History list symbol to add minibuffer values to.
+ − 326 Each minibuffer output is added with
+ − 327 (set minibuffer-history-variable
+ − 328 (cons STRING (symbol-value minibuffer-history-variable)))")
+ − 329 (defvar minibuffer-history-position)
+ − 330
+ − 331 ;; Added by hniksic:
+ − 332 (defvar initial-minibuffer-history-position)
+ − 333 (defvar current-minibuffer-contents)
+ − 334 (defvar current-minibuffer-point)
+ − 335
+ − 336 (defcustom minibuffer-history-minimum-string-length nil
+ − 337 "*If this variable is non-nil, a string will not be added to the
+ − 338 minibuffer history if its length is less than that value."
+ − 339 :type '(choice (const :tag "Any" nil)
+ − 340 integer)
+ − 341 :group 'minibuffer)
+ − 342
510
+ − 343 (define-error 'input-error "Keyboard input error" 'io-error)
428
+ − 344
+ − 345 (defun read-from-minibuffer (prompt &optional initial-contents
+ − 346 keymap
+ − 347 readp
+ − 348 history
430
+ − 349 abbrev-table
+ − 350 default)
428
+ − 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.
430
+ − 372 Seventh arg DEFAULT, if non-nil, will be returned when user enters
+ − 373 an empty string.
428
+ − 374
444
+ − 375 See also the variable `completion-highlight-first-word-only' for
+ − 376 control over completion display."
428
+ − 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!
434
+ − 420 (_history_ history)
+ − 421 (minibuffer-default default))
428
+ − 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))
430
+ − 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))
428
+ − 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 ? )
+ − 602 (abort-recursive-edit))
+ − 603 (t
+ − 604 (error "Minibuffer already active")))))
+ − 605
+ − 606
+ − 607 ;;;; Guts of minibuffer completion
+ − 608
+ − 609
+ − 610 ;; Used by minibuffer-do-completion
442
+ − 611 (defvar last-exact-completion nil)
428
+ − 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
+ − 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
430
+ − 798 history
+ − 799 nil
+ − 800 default))
428
+ − 801 (if (and (string= ret "")
+ − 802 default)
+ − 803 default
+ − 804 ret)))
+ − 805
+ − 806
+ − 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
+ − 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
+ − 1002
+ − 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)
502
+ − 1098 (declare-fboundp
+ − 1099 (ange-ftp-ftp-path string)))
428
+ − 1100 (and (fboundp 'efs-ftp-path)
502
+ − 1101 (declare-fboundp
+ − 1102 (efs-ftp-path string)))))
428
+ − 1103 (setq comp t)
+ − 1104 (setq comp
+ − 1105 (try-completion string
+ − 1106 minibuffer-completion-table
+ − 1107 minibuffer-completion-predicate)))
+ − 1108 (or (eq comp t)
+ − 1109 (and (equal comp string)
+ − 1110 (or (null minibuffer-completion-predicate)
+ − 1111 (stringp
+ − 1112 minibuffer-completion-predicate) ; ???
+ − 1113 (funcall minibuffer-completion-predicate
+ − 1114 (if (vectorp
+ − 1115 minibuffer-completion-table)
+ − 1116 (intern-soft
+ − 1117 string
+ − 1118 minibuffer-completion-table)
+ − 1119 string))))
+ − 1120 (goto-char p))))))))))
+ − 1121
+ − 1122 (defun minibuffer-smart-select-kludge-filename (string)
+ − 1123 (save-excursion
+ − 1124 (set-buffer mouse-grabbed-buffer) ; the minibuf
+ − 1125 (let ((kludge-string (concat (buffer-string) string)))
+ − 1126 (if (or (and (fboundp 'ange-ftp-ftp-path)
502
+ − 1127 (declare-fboundp (ange-ftp-ftp-path kludge-string)))
+ − 1128 (and (fboundp 'efs-ftp-path)
+ − 1129 (declare-fboundp (efs-ftp-path kludge-string))))
+ − 1130 ;; #### evil evil evil, but more so.
+ − 1131 string
+ − 1132 (append-expand-filename (buffer-string) string)))))
428
+ − 1133
+ − 1134 (defun minibuffer-smart-select-highlighted-completion (event)
+ − 1135 "Select the highlighted text under the mouse as a minibuffer response.
+ − 1136 When the minibuffer is being used to prompt the user for a completion,
+ − 1137 any valid completions which are visible on the frame will highlight
+ − 1138 when the mouse moves over them. Clicking \\<minibuffer-local-map>\
+ − 1139 \\[minibuffer-smart-select-highlighted-completion] will select the
+ − 1140 highlighted completion under the mouse.
+ − 1141
+ − 1142 If the mouse is clicked while not over a highlighted completion,
+ − 1143 then the global binding of \\[minibuffer-smart-select-highlighted-completion] \
+ − 1144 will be executed instead. In this\nway you can get at the normal global \
+ − 1145 behavior of \\[minibuffer-smart-select-highlighted-completion] as well as
+ − 1146 the special minibuffer behavior."
+ − 1147 (interactive "e")
+ − 1148 (if minibuffer-smart-completion-tracking-behavior
+ − 1149 (minibuffer-smart-select-highlighted-completion-1 event t)
+ − 1150 (let ((command (lookup-key global-map
+ − 1151 (vector current-mouse-event))))
+ − 1152 (if command (call-interactively command)))))
+ − 1153
+ − 1154 (defun minibuffer-smart-select-highlighted-completion-1 (event global-p)
+ − 1155 (let* ((filename-kludge-p (eq minibuffer-completion-table
+ − 1156 'read-file-name-internal))
+ − 1157 completion
+ − 1158 command-p
+ − 1159 (evpoint (event-point event))
+ − 1160 (evextent (and evpoint (extent-at evpoint (event-buffer event)
+ − 1161 'list-mode-item))))
+ − 1162 (if evextent
+ − 1163 ;; avoid conflict with display-completion-list extents.
+ − 1164 ;; if we find one, do that behavior instead.
+ − 1165 (list-mode-item-selected-1 evextent event)
+ − 1166 (save-excursion
+ − 1167 (let* ((buffer (window-buffer (event-window event)))
+ − 1168 (p (event-point event))
+ − 1169 (extent (and p (extent-at p buffer 'mouse-face))))
+ − 1170 (set-buffer buffer)
+ − 1171 (if (not (and (extent-live-p extent)
+ − 1172 (eq (extent-object extent) (current-buffer))
+ − 1173 (not (extent-detached-p extent))))
+ − 1174 (setq command-p t)
+ − 1175 ;; ...else user has selected a highlighted completion.
+ − 1176 (setq completion
+ − 1177 (buffer-substring (extent-start-position extent)
+ − 1178 (extent-end-position extent)))
+ − 1179 (if filename-kludge-p
+ − 1180 (setq completion (minibuffer-smart-select-kludge-filename
+ − 1181 completion)))
+ − 1182 ;; remove the extent so that it's not hanging around in
+ − 1183 ;; *Completions*
+ − 1184 (detach-extent extent)
+ − 1185 (set-buffer mouse-grabbed-buffer)
+ − 1186 (erase-buffer)
+ − 1187 (insert completion))))
+ − 1188 ;; we need to execute the command or do the throw outside of the
+ − 1189 ;; save-excursion.
+ − 1190 (cond ((and command-p global-p)
+ − 1191 (let ((command (lookup-key global-map
+ − 1192 (vector current-mouse-event))))
+ − 1193 (if command
+ − 1194 (call-interactively command)
+ − 1195 (if minibuffer-completion-table
+ − 1196 (error
+ − 1197 "Highlighted words are valid completions. You may select one.")
+ − 1198 (error "no completions")))))
+ − 1199 ((not command-p)
+ − 1200 ;; things get confused if the minibuffer is terminated while
+ − 1201 ;; not selected.
+ − 1202 (select-window (minibuffer-window))
+ − 1203 (if (and filename-kludge-p (file-directory-p completion))
+ − 1204 ;; if the user clicked middle on a directory name, display the
+ − 1205 ;; files in that directory.
+ − 1206 (progn
+ − 1207 (goto-char (point-max))
+ − 1208 (minibuffer-completion-help))
+ − 1209 ;; otherwise, terminate input
+ − 1210 (throw 'exit nil)))))))
+ − 1211
+ − 1212 (defun minibuffer-smart-maybe-select-highlighted-completion
+ − 1213 (event &optional click-count)
444
+ − 1214 "Like `minibuffer-smart-select-highlighted-completion' but does nothing if
428
+ − 1215 there is no completion (as opposed to executing the global binding). Useful
+ − 1216 as the value of `mouse-track-click-hook'."
+ − 1217 (interactive "e")
+ − 1218 (minibuffer-smart-select-highlighted-completion-1 event nil))
+ − 1219
+ − 1220 (define-key minibuffer-local-map 'button2
+ − 1221 'minibuffer-smart-select-highlighted-completion)
+ − 1222
+ − 1223
+ − 1224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1225 ;;;; Minibuffer History ;;;;
+ − 1226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1227
+ − 1228 (defvar minibuffer-history '()
+ − 1229 "Default minibuffer history list.
+ − 1230 This is used for all minibuffer input except when an alternate history
+ − 1231 list is specified.")
+ − 1232
+ − 1233 ;; Some other history lists:
+ − 1234 ;;
+ − 1235 (defvar minibuffer-history-search-history '())
+ − 1236 (defvar function-history '())
+ − 1237 (defvar variable-history '())
+ − 1238 (defvar buffer-history '())
+ − 1239 (defvar shell-command-history '())
+ − 1240 (defvar file-name-history '())
+ − 1241
+ − 1242 (defvar read-expression-history nil)
+ − 1243
+ − 1244 (defvar minibuffer-history-sexp-flag nil ;weird FSF Emacs kludge
+ − 1245 "Non-nil when doing history operations on `command-history'.
+ − 1246 More generally, indicates that the history list being acted on
+ − 1247 contains expressions rather than strings.")
+ − 1248
+ − 1249 (defun previous-matching-history-element (regexp n)
+ − 1250 "Find the previous history element that matches REGEXP.
+ − 1251 \(Previous history elements refer to earlier actions.)
+ − 1252 With prefix argument N, search for Nth previous match.
+ − 1253 If N is negative, find the next or Nth next match."
+ − 1254 (interactive
+ − 1255 (let ((enable-recursive-minibuffers t)
438
+ − 1256 (minibuffer-history-sexp-flag nil)
+ − 1257 (minibuffer-max-depth (and minibuffer-max-depth
+ − 1258 (1+ minibuffer-max-depth))))
428
+ − 1259 (if (eq 't (symbol-value minibuffer-history-variable))
+ − 1260 (error "History is not being recorded in this context"))
+ − 1261 (list (read-from-minibuffer "Previous element matching (regexp): "
+ − 1262 (car minibuffer-history-search-history)
+ − 1263 minibuffer-local-map
+ − 1264 nil
+ − 1265 'minibuffer-history-search-history)
+ − 1266 (prefix-numeric-value current-prefix-arg))))
+ − 1267 (let ((history (symbol-value minibuffer-history-variable))
+ − 1268 prevpos
+ − 1269 (pos minibuffer-history-position))
+ − 1270 (if (eq history t)
+ − 1271 (error "History is not being recorded in this context"))
+ − 1272 (while (/= n 0)
+ − 1273 (setq prevpos pos)
+ − 1274 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history)))
+ − 1275 (if (= pos prevpos)
+ − 1276 (if (= pos 1) ;; rewritten for I18N3 snarfing
+ − 1277 (error "No later matching history item")
+ − 1278 (error "No earlier matching history item")))
+ − 1279 (if (string-match regexp
+ − 1280 (if minibuffer-history-sexp-flag
+ − 1281 (let ((print-level nil))
+ − 1282 (prin1-to-string (nth (1- pos) history)))
+ − 1283 (nth (1- pos) history)))
+ − 1284 (setq n (+ n (if (< n 0) 1 -1)))))
+ − 1285 (setq minibuffer-history-position pos)
+ − 1286 (setq current-minibuffer-contents (buffer-string)
+ − 1287 current-minibuffer-point (point))
+ − 1288 (erase-buffer)
+ − 1289 (let ((elt (nth (1- pos) history)))
+ − 1290 (insert (if minibuffer-history-sexp-flag
+ − 1291 (let ((print-level nil))
+ − 1292 (prin1-to-string elt))
+ − 1293 elt)))
+ − 1294 (goto-char (point-min)))
+ − 1295 (if (or (eq (car (car command-history)) 'previous-matching-history-element)
+ − 1296 (eq (car (car command-history)) 'next-matching-history-element))
+ − 1297 (setq command-history (cdr command-history))))
+ − 1298
+ − 1299 (defun next-matching-history-element (regexp n)
+ − 1300 "Find the next history element that matches REGEXP.
+ − 1301 \(The next history element refers to a more recent action.)
+ − 1302 With prefix argument N, search for Nth next match.
+ − 1303 If N is negative, find the previous or Nth previous match."
+ − 1304 (interactive
+ − 1305 (let ((enable-recursive-minibuffers t)
438
+ − 1306 (minibuffer-history-sexp-flag nil)
+ − 1307 (minibuffer-max-depth (and minibuffer-max-depth
+ − 1308 (1+ minibuffer-max-depth))))
428
+ − 1309 (if (eq t (symbol-value minibuffer-history-variable))
+ − 1310 (error "History is not being recorded in this context"))
+ − 1311 (list (read-from-minibuffer "Next element matching (regexp): "
+ − 1312 (car minibuffer-history-search-history)
+ − 1313 minibuffer-local-map
+ − 1314 nil
+ − 1315 'minibuffer-history-search-history)
+ − 1316 (prefix-numeric-value current-prefix-arg))))
+ − 1317 (previous-matching-history-element regexp (- n)))
+ − 1318
+ − 1319 (defun next-history-element (n)
+ − 1320 "Insert the next element of the minibuffer history into the minibuffer."
+ − 1321 (interactive "p")
+ − 1322 (if (eq 't (symbol-value minibuffer-history-variable))
+ − 1323 (error "History is not being recorded in this context"))
+ − 1324 (unless (zerop n)
+ − 1325 (when (eq minibuffer-history-position
+ − 1326 initial-minibuffer-history-position)
+ − 1327 (setq current-minibuffer-contents (buffer-string)
+ − 1328 current-minibuffer-point (point)))
+ − 1329 (let ((narg (- minibuffer-history-position n))
+ − 1330 (minimum (if minibuffer-default -1 0)))
442
+ − 1331 ;; a weird special case here; when in repeat-complex-command, we're
+ − 1332 ;; trying to edit the top command, and minibuffer-history-position
+ − 1333 ;; points to 1, the next-to-top command. in this case, the top
+ − 1334 ;; command in the history is suppressed in favor of the one being
+ − 1335 ;; edited, and there is no more command below it, except maybe the
+ − 1336 ;; default.
+ − 1337 (if (and (zerop narg) (eq minibuffer-history-position
+ − 1338 initial-minibuffer-history-position))
+ − 1339 (setq minimum (1+ minimum)))
428
+ − 1340 (cond ((< narg minimum)
440
+ − 1341 (error (if minibuffer-default
+ − 1342 "No following item in %s"
+ − 1343 "No following item in %s; no default available")
+ − 1344 minibuffer-history-variable))
428
+ − 1345 ((> narg (length (symbol-value minibuffer-history-variable)))
+ − 1346 (error "No preceding item in %s" minibuffer-history-variable)))
+ − 1347 (erase-buffer)
+ − 1348 (setq minibuffer-history-position narg)
+ − 1349 (if (eq narg initial-minibuffer-history-position)
+ − 1350 (progn
+ − 1351 (insert current-minibuffer-contents)
+ − 1352 (goto-char current-minibuffer-point))
442
+ − 1353 (let ((elt (if (> narg 0)
428
+ − 1354 (nth (1- minibuffer-history-position)
+ − 1355 (symbol-value minibuffer-history-variable))
+ − 1356 minibuffer-default)))
+ − 1357 (insert
+ − 1358 (if (not (stringp elt))
+ − 1359 (let ((print-level nil))
+ − 1360 (condition-case nil
+ − 1361 (let ((print-readably t)
+ − 1362 (print-escape-newlines t))
+ − 1363 (prin1-to-string elt))
+ − 1364 (error (prin1-to-string elt))))
+ − 1365 elt)))
+ − 1366 ;; FSF has point-min here.
+ − 1367 (goto-char (point-max))))))
+ − 1368
+ − 1369 (defun previous-history-element (n)
+ − 1370 "Insert the previous element of the minibuffer history into the minibuffer."
+ − 1371 (interactive "p")
+ − 1372 (next-history-element (- n)))
+ − 1373
+ − 1374 (defun next-complete-history-element (n)
+ − 1375 "Get next element of history which is a completion of minibuffer contents."
+ − 1376 (interactive "p")
+ − 1377 (let ((point-at-start (point)))
+ − 1378 (next-matching-history-element
+ − 1379 (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n)
+ − 1380 ;; next-matching-history-element always puts us at (point-min).
+ − 1381 ;; Move to the position we were at before changing the buffer contents.
+ − 1382 ;; This is still sensical, because the text before point has not changed.
+ − 1383 (goto-char point-at-start)))
+ − 1384
+ − 1385 (defun previous-complete-history-element (n)
+ − 1386 "Get previous element of history which is a completion of minibuffer contents."
+ − 1387 (interactive "p")
+ − 1388 (next-complete-history-element (- n)))
+ − 1389
+ − 1390
+ − 1391 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1392 ;;;; reading various things from a minibuffer ;;;;
+ − 1393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ − 1394
440
+ − 1395 (defun read-expression (prompt &optional initial-contents history default-value)
+ − 1396 "Return a Lisp object read using the minibuffer, prompting with 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 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ − 1401 for history command, and as the value to return if the user enters the
+ − 1402 empty string."
428
+ − 1403 (let ((minibuffer-history-sexp-flag t)
+ − 1404 ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion.
+ − 1405 (minibuffer-completion-table nil))
+ − 1406 (read-from-minibuffer prompt
+ − 1407 initial-contents
+ − 1408 read-expression-map
+ − 1409 t
+ − 1410 (or history 'read-expression-history)
440
+ − 1411 lisp-mode-abbrev-table
+ − 1412 default-value)))
428
+ − 1413
440
+ − 1414 (defun read-string (prompt &optional initial-contents history default-value)
428
+ − 1415 "Return a string from the minibuffer, prompting with string PROMPT.
+ − 1416 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
440
+ − 1417 in the minibuffer before reading.
+ − 1418 Third arg HISTORY, if non-nil, specifies a history list.
+ − 1419 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ − 1420 for history command, and as the value to return if the user enters the
+ − 1421 empty string."
428
+ − 1422 (let ((minibuffer-completion-table nil))
+ − 1423 (read-from-minibuffer prompt
+ − 1424 initial-contents
+ − 1425 minibuffer-local-map
440
+ − 1426 nil history nil default-value)))
428
+ − 1427
440
+ − 1428 (defun eval-minibuffer (prompt &optional initial-contents history default-value)
428
+ − 1429 "Return value of Lisp expression read using the minibuffer.
+ − 1430 Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS
+ − 1431 is a string to insert in the minibuffer before reading.
440
+ − 1432 Third arg HISTORY, if non-nil, specifies a history list.
+ − 1433 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used
+ − 1434 for history command, and as the value to return if the user enters the
+ − 1435 empty string."
+ − 1436 (eval (read-expression prompt initial-contents history default-value)))
428
+ − 1437
+ − 1438 ;; The name `command-history' is already taken
+ − 1439 (defvar read-command-history '())
+ − 1440
440
+ − 1441 (defun read-command (prompt &optional default-value)
428
+ − 1442 "Read the name of a command and return as a symbol.
440
+ − 1443 Prompts with PROMPT. By default, return DEFAULT-VALUE."
428
+ − 1444 (intern (completing-read prompt obarray 'commandp t nil
+ − 1445 ;; 'command-history is not right here: that's a
+ − 1446 ;; list of evalable forms, not a history list.
+ − 1447 'read-command-history
440
+ − 1448 default-value)))
428
+ − 1449
440
+ − 1450 (defun read-function (prompt &optional default-value)
428
+ − 1451 "Read the name of a function and return as a symbol.
440
+ − 1452 Prompts with PROMPT. By default, return DEFAULT-VALUE."
428
+ − 1453 (intern (completing-read prompt obarray 'fboundp t nil
440
+ − 1454 'function-history default-value)))
428
+ − 1455
440
+ − 1456 (defun read-variable (prompt &optional default-value)
428
+ − 1457 "Read the name of a user variable and return it as a symbol.
440
+ − 1458 Prompts with PROMPT. By default, return DEFAULT-VALUE.
428
+ − 1459 A user variable is one whose documentation starts with a `*' character."
+ − 1460 (intern (completing-read prompt obarray 'user-variable-p t nil
442
+ − 1461 'variable-history
+ − 1462 (if (symbolp default-value)
+ − 1463 (symbol-name default-value)
+ − 1464 default-value))))
428
+ − 1465
+ − 1466 (defun read-buffer (prompt &optional default require-match)
+ − 1467 "Read the name of a buffer and return as a string.
+ − 1468 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user
+ − 1469 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil,
+ − 1470 only existing buffer names are allowed."
+ − 1471 (let ((prompt (if default
+ − 1472 (format "%s(default %s) "
+ − 1473 (gettext prompt) (if (bufferp default)
+ − 1474 (buffer-name default)
+ − 1475 default))
+ − 1476 prompt))
+ − 1477 (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
+ − 1478 (buffer-list)))
+ − 1479 result)
+ − 1480 (while (progn
+ − 1481 (setq result (completing-read prompt alist nil require-match
430
+ − 1482 nil 'buffer-history
434
+ − 1483 (if (bufferp default)
+ − 1484 (buffer-name default)
+ − 1485 default)))
428
+ − 1486 (cond ((not (equal result ""))
+ − 1487 nil)
+ − 1488 ((not require-match)
+ − 1489 (setq result default)
+ − 1490 nil)
+ − 1491 ((not default)
+ − 1492 t)
+ − 1493 ((not (get-buffer default))
+ − 1494 t)
+ − 1495 (t
+ − 1496 (setq result default)
+ − 1497 nil))))
+ − 1498 (if (bufferp result)
+ − 1499 (buffer-name result)
+ − 1500 result)))
+ − 1501
440
+ − 1502 (defun read-number (prompt &optional integers-only default-value)
+ − 1503 "Read a number from the minibuffer, prompting with PROMPT.
+ − 1504 If optional second argument INTEGERS-ONLY is non-nil, accept
+ − 1505 only integer input.
+ − 1506 If DEFAULT-VALUE is non-nil, return that if user enters an empty
+ − 1507 line."
428
+ − 1508 (let ((pred (if integers-only 'integerp 'numberp))
+ − 1509 num)
+ − 1510 (while (not (funcall pred num))
+ − 1511 (setq num (condition-case ()
+ − 1512 (let ((minibuffer-completion-table nil))
+ − 1513 (read-from-minibuffer
+ − 1514 prompt (if num (prin1-to-string num)) nil t
440
+ − 1515 nil nil default-value))
428
+ − 1516 (input-error nil)
+ − 1517 (invalid-read-syntax nil)
+ − 1518 (end-of-file nil)))
+ − 1519 (or (funcall pred num) (beep)))
+ − 1520 num))
+ − 1521
440
+ − 1522 (defun read-shell-command (prompt &optional initial-input history default-value)
428
+ − 1523 "Just like read-string, but uses read-shell-command-map:
+ − 1524 \\{read-shell-command-map}"
+ − 1525 (let ((minibuffer-completion-table nil))
+ − 1526 (read-from-minibuffer prompt initial-input read-shell-command-map
440
+ − 1527 nil (or history 'shell-command-history)
+ − 1528 nil default-value)))
428
+ − 1529
+ − 1530
+ − 1531 ;;; This read-file-name stuff probably belongs in files.el
+ − 1532
+ − 1533 ;; Quote "$" as "$$" to get it past substitute-in-file-name
+ − 1534 (defun un-substitute-in-file-name (string)
+ − 1535 (let ((regexp "\\$")
+ − 1536 (olen (length string))
+ − 1537 new
+ − 1538 n o ch)
+ − 1539 (if (not (string-match regexp string))
+ − 1540 string
+ − 1541 (setq n 1)
+ − 1542 (while (string-match regexp string (match-end 0))
+ − 1543 (setq n (1+ n)))
+ − 1544 (setq new (make-string (+ olen n) ?$))
+ − 1545 (setq n 0 o 0)
+ − 1546 (while (< o olen)
+ − 1547 (setq ch (aref string o))
+ − 1548 (aset new n ch)
+ − 1549 (setq o (1+ o) n (1+ n))
+ − 1550 (if (eq ch ?$)
+ − 1551 ;; already aset by make-string initial-value
+ − 1552 (setq n (1+ n))))
+ − 1553 new)))
+ − 1554
442
+ − 1555
+ − 1556 ;; Wrapper for `directory-files' for use in generating completion lists.
+ − 1557 ;; Generates output in the same format as `file-name-all-completions'.
+ − 1558 ;;
+ − 1559 ;; The EFS replacement for `directory-files' doesn't support the FILES-ONLY
+ − 1560 ;; option, so it has to be faked. The listing cache will hopefully
+ − 1561 ;; improve the performance of this operation.
+ − 1562 (defun minibuf-directory-files (dir &optional match-regexp files-only)
+ − 1563 (let ((want-file (or (eq files-only nil) (eq files-only t)))
+ − 1564 (want-dirs (or (eq files-only nil) (not (eq files-only t)))))
+ − 1565 (delete nil
+ − 1566 (mapcar (function (lambda (f)
+ − 1567 (if (file-directory-p (expand-file-name f dir))
+ − 1568 (and want-dirs (file-name-as-directory f))
+ − 1569 (and want-file f))))
+ − 1570 (delete "." (directory-files dir nil match-regexp))))))
+ − 1571
+ − 1572
428
+ − 1573 (defun read-file-name-2 (history prompt dir default
+ − 1574 must-match initial-contents
+ − 1575 completer)
+ − 1576 (if (not dir)
+ − 1577 (setq dir default-directory))
+ − 1578 (setq dir (abbreviate-file-name dir t))
+ − 1579 (let* ((insert (cond ((and (not insert-default-directory)
+ − 1580 (not initial-contents))
+ − 1581 "")
+ − 1582 (initial-contents
+ − 1583 (cons (un-substitute-in-file-name
+ − 1584 (concat dir initial-contents))
+ − 1585 (length dir)))
+ − 1586 (t
+ − 1587 (un-substitute-in-file-name dir))))
+ − 1588 (val
+ − 1589 ;; Hateful, broken, case-sensitive un*x
+ − 1590 ;;; (completing-read prompt
+ − 1591 ;;; completer
+ − 1592 ;;; dir
+ − 1593 ;;; must-match
+ − 1594 ;;; insert
+ − 1595 ;;; history)
+ − 1596 ;; #### - this is essentially the guts of completing read.
+ − 1597 ;; There should be an elegant way to pass a pair of keymaps to
+ − 1598 ;; completing read, but this will do for now. All sins are
+ − 1599 ;; relative. --Stig
+ − 1600 (let ((minibuffer-completion-table completer)
+ − 1601 (minibuffer-completion-predicate dir)
+ − 1602 (minibuffer-completion-confirm (if (eq must-match 't)
+ − 1603 nil t))
+ − 1604 (last-exact-completion nil))
+ − 1605 (read-from-minibuffer prompt
+ − 1606 insert
+ − 1607 (if (not must-match)
+ − 1608 read-file-name-map
+ − 1609 read-file-name-must-match-map)
+ − 1610 nil
434
+ − 1611 history
+ − 1612 nil
+ − 1613 default))))
428
+ − 1614 ;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar"
+ − 1615 ;;; (let ((hist (cond ((not history) 'minibuffer-history)
+ − 1616 ;;; ((consp history) (car history))
+ − 1617 ;;; (t history))))
+ − 1618 ;;; (if (and val
+ − 1619 ;;; hist
+ − 1620 ;;; (not (eq hist 't))
+ − 1621 ;;; (boundp hist)
+ − 1622 ;;; (equal (car-safe (symbol-value hist)) val))
+ − 1623 ;;; (let ((e (condition-case nil
+ − 1624 ;;; (expand-file-name val)
+ − 1625 ;;; (error nil))))
+ − 1626 ;;; (if (and e (not (equal e val)))
+ − 1627 ;;; (set hist (cons e (cdr (symbol-value hist))))))))
+ − 1628
+ − 1629 (cond ((not val)
+ − 1630 (error "No file name specified"))
+ − 1631 ((and default
+ − 1632 (equal val (if (consp insert) (car insert) insert)))
+ − 1633 default)
+ − 1634 (t
+ − 1635 (substitute-in-file-name val)))))
+ − 1636
+ − 1637 ;; #### this function should use minibuffer-completion-table
+ − 1638 ;; or something. But that is sloooooow.
+ − 1639 ;; #### all this shit needs better documentation!!!!!!!!
+ − 1640 (defun read-file-name-activate-callback (event extent dir-p)
+ − 1641 ;; used as the activate-callback of the filename list items
+ − 1642 ;; in the completion buffer, in place of default-choose-completion.
+ − 1643 ;; if a regular file was selected, we call default-choose-completion
+ − 1644 ;; (which just inserts the string in the minibuffer and calls
+ − 1645 ;; exit-minibuffer). If a directory was selected, we display
+ − 1646 ;; the contents of the directory.
+ − 1647 (let* ((file (extent-string extent))
+ − 1648 (completion-buf (extent-object extent))
+ − 1649 (minibuf (symbol-value-in-buffer 'completion-reference-buffer
+ − 1650 completion-buf))
+ − 1651 (in-dir (file-name-directory (buffer-substring nil nil minibuf)))
+ − 1652 (full (expand-file-name file in-dir)))
+ − 1653 (if (not (file-directory-p full))
+ − 1654 (default-choose-completion event extent minibuf)
+ − 1655 (erase-buffer minibuf)
+ − 1656 (insert-string (file-name-as-directory
+ − 1657 (abbreviate-file-name full t)) minibuf)
+ − 1658 (reset-buffer completion-buf)
+ − 1659 (let ((standard-output completion-buf))
+ − 1660 (display-completion-list
442
+ − 1661 (minibuf-directory-files full nil (if dir-p 'directory))
428
+ − 1662 :user-data dir-p
+ − 1663 :reference-buffer minibuf
+ − 1664 :activate-callback 'read-file-name-activate-callback)
+ − 1665 (goto-char (point-min) completion-buf)))))
+ − 1666
+ − 1667 (defun read-file-name-1 (history prompt dir default
+ − 1668 must-match initial-contents
+ − 1669 completer)
+ − 1670 (if (should-use-dialog-box-p)
442
+ − 1671 (condition-case nil
+ − 1672 (let ((file
+ − 1673 (apply #'make-dialog-box
+ − 1674 'file `(:title ,(capitalize-string-as-title
+ − 1675 ;; Kludge: Delete ": " off the end.
+ − 1676 (replace-in-string prompt ": $" ""))
+ − 1677 ,@(and dir (list :initial-directory
+ − 1678 dir))
+ − 1679 :file-must-exist ,must-match
+ − 1680 ,@(and initial-contents
+ − 1681 (list :initial-filename
+ − 1682 initial-contents))))))
+ − 1683 ;; hack -- until we implement reading a directory properly,
+ − 1684 ;; allow a file as indicating the directory it's in
+ − 1685 (if (and (eq completer 'read-directory-name-internal)
+ − 1686 (not (file-directory-p file)))
+ − 1687 (file-name-directory file)
+ − 1688 file))
+ − 1689 (unimplemented
+ − 1690 ;; this calls read-file-name-2
+ − 1691 (mouse-read-file-name-1 history prompt dir default must-match
+ − 1692 initial-contents completer)
+ − 1693 ))
+ − 1694 (add-one-shot-hook
+ − 1695 'minibuffer-setup-hook
+ − 1696 (lambda ()
+ − 1697 ;; #### SCREAM! Create a `file-system-ignore-case'
+ − 1698 ;; function, so this kind of stuff is generalized!
+ − 1699 (and (eq system-type 'windows-nt)
+ − 1700 (set (make-local-variable 'completion-ignore-case) t))
+ − 1701 (set
+ − 1702 (make-local-variable
+ − 1703 'completion-display-completion-list-function)
+ − 1704 #'(lambda (completions)
+ − 1705 (display-completion-list
+ − 1706 completions
+ − 1707 :user-data (not (eq completer 'read-file-name-internal))
+ − 1708 :activate-callback
+ − 1709 'read-file-name-activate-callback)))))
+ − 1710 (read-file-name-2 history prompt dir default must-match
+ − 1711 initial-contents completer)))
428
+ − 1712
+ − 1713 (defun read-file-name (prompt
+ − 1714 &optional dir default must-match initial-contents
+ − 1715 history)
+ − 1716 "Read file name, prompting with PROMPT and completing in directory DIR.
+ − 1717 This will prompt with a dialog box if appropriate, according to
+ − 1718 `should-use-dialog-box-p'.
+ − 1719 Value is not expanded---you must call `expand-file-name' yourself.
438
+ − 1720 Value is subject to interpretation by `substitute-in-file-name' however.
428
+ − 1721 Default name to DEFAULT if user enters a null string.
+ − 1722 (If DEFAULT is omitted, the visited file name is used,
+ − 1723 except that if INITIAL-CONTENTS is specified, that combined with DIR is
+ − 1724 used.)
+ − 1725 Fourth arg MUST-MATCH non-nil means require existing file's name.
+ − 1726 Non-nil and non-t means also require confirmation after completion.
440
+ − 1727 Fifth arg INITIAL-CONTENTS specifies text to start with. If this is not
+ − 1728 specified, and `insert-default-directory' is non-nil, DIR or the current
+ − 1729 directory will be used.
428
+ − 1730 Sixth arg HISTORY specifies the history list to use. Default is
+ − 1731 `file-name-history'.
+ − 1732 DIR defaults to current buffer's directory default."
+ − 1733 (read-file-name-1
+ − 1734 (or history 'file-name-history)
+ − 1735 prompt dir (or default
440
+ − 1736 (and initial-contents
+ − 1737 (abbreviate-file-name (expand-file-name
+ − 1738 initial-contents dir) t))
+ − 1739 (and buffer-file-truename
+ − 1740 (abbreviate-file-name buffer-file-name t)))
428
+ − 1741 must-match initial-contents
+ − 1742 ;; A separate function (not an anonymous lambda-expression)
+ − 1743 ;; and passed as a symbol because of disgusting kludges in various
+ − 1744 ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...)
+ − 1745 'read-file-name-internal))
+ − 1746
+ − 1747 (defun read-directory-name (prompt
+ − 1748 &optional dir default must-match initial-contents
+ − 1749 history)
+ − 1750 "Read directory name, prompting with PROMPT and completing in directory DIR.
+ − 1751 This will prompt with a dialog box if appropriate, according to
+ − 1752 `should-use-dialog-box-p'.
+ − 1753 Value is not expanded---you must call `expand-file-name' yourself.
+ − 1754 Value is subject to interpreted by substitute-in-file-name however.
+ − 1755 Default name to DEFAULT if user enters a null string.
+ − 1756 (If DEFAULT is omitted, the current buffer's default directory is used.)
+ − 1757 Fourth arg MUST-MATCH non-nil means require existing directory's name.
+ − 1758 Non-nil and non-t means also require confirmation after completion.
+ − 1759 Fifth arg INITIAL-CONTENTS specifies text to start with.
+ − 1760 Sixth arg HISTORY specifies the history list to use. Default is
+ − 1761 `file-name-history'.
+ − 1762 DIR defaults to current buffer's directory default."
+ − 1763 (read-file-name-1
+ − 1764 (or history 'file-name-history)
+ − 1765 prompt dir (or default default-directory) must-match initial-contents
+ − 1766 'read-directory-name-internal))
+ − 1767
+ − 1768
+ − 1769 ;; Environment-variable and ~username completion hack
+ − 1770 (defun read-file-name-internal-1 (string dir action completer)
+ − 1771 (if (not (string-match
+ − 1772 "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'"
+ − 1773 string))
+ − 1774 ;; Not doing environment-variable completion hack
+ − 1775 (let* ((orig (if (equal string "") nil string))
+ − 1776 (sstring (if orig (substitute-in-file-name string) string))
+ − 1777 (specdir (if orig (file-name-directory sstring) nil))
+ − 1778 (name (if orig (file-name-nondirectory sstring) string))
+ − 1779 (direct (if specdir (expand-file-name specdir dir) dir)))
+ − 1780 ;; ~username completion
+ − 1781 (if (and (fboundp 'user-name-completion-1)
+ − 1782 (string-match "^[~]" name))
+ − 1783 (let ((user (substring name 1)))
+ − 1784 (cond ((eq action 'lambda)
+ − 1785 (file-directory-p name))
+ − 1786 ((eq action 't)
+ − 1787 ;; all completions
+ − 1788 (mapcar #'(lambda (p) (concat "~" p))
502
+ − 1789 (declare-fboundp
+ − 1790 (user-name-all-completions user))))
428
+ − 1791 (t;; 'nil
+ − 1792 ;; complete
502
+ − 1793 (let* ((val+uniq (declare-fboundp
+ − 1794 (user-name-completion-1 user)))
428
+ − 1795 (val (car val+uniq))
+ − 1796 (uniq (cdr val+uniq)))
+ − 1797 (cond ((stringp val)
+ − 1798 (if uniq
+ − 1799 (file-name-as-directory (concat "~" val))
+ − 1800 (concat "~" val)))
+ − 1801 ((eq val t)
+ − 1802 (file-name-as-directory name))
+ − 1803 (t nil))))))
+ − 1804 (funcall completer
+ − 1805 action
+ − 1806 orig
+ − 1807 sstring
+ − 1808 specdir
+ − 1809 direct
+ − 1810 name)))
+ − 1811 ;; An odd number of trailing $'s
+ − 1812 (let* ((start (match-beginning 3))
+ − 1813 (env (substring string
+ − 1814 (cond ((= start (length string))
+ − 1815 ;; "...$"
+ − 1816 start)
+ − 1817 ((= (aref string start) ?{)
+ − 1818 ;; "...${..."
+ − 1819 (1+ start))
+ − 1820 (t
+ − 1821 start))))
+ − 1822 (head (substring string 0 (1- start)))
+ − 1823 (alist #'(lambda ()
+ − 1824 (mapcar #'(lambda (x)
+ − 1825 (cons (substring x 0 (string-match "=" x))
+ − 1826 nil))
+ − 1827 process-environment))))
+ − 1828
+ − 1829 (cond ((eq action 'lambda)
+ − 1830 nil)
+ − 1831 ((eq action 't)
+ − 1832 ;; all completions
+ − 1833 (mapcar #'(lambda (p)
+ − 1834 (if (and (> (length p) 0)
+ − 1835 ;;#### Unix-specific
+ − 1836 ;;#### -- need absolute-pathname-p
+ − 1837 (/= (aref p 0) ?/))
+ − 1838 (concat "$" p)
+ − 1839 (concat head "$" p)))
+ − 1840 (all-completions env (funcall alist))))
+ − 1841 (t ;; nil
+ − 1842 ;; complete
+ − 1843 (let* ((e (funcall alist))
+ − 1844 (val (try-completion env e)))
+ − 1845 (cond ((stringp val)
+ − 1846 (if (string-match "[^A-Za-z0-9_]" val)
+ − 1847 (concat head
+ − 1848 "${" val
+ − 1849 ;; completed uniquely?
+ − 1850 (if (eq (try-completion val e) 't)
+ − 1851 "}" ""))
+ − 1852 (concat head "$" val)))
+ − 1853 ((eql val 't)
+ − 1854 (concat head
+ − 1855 (un-substitute-in-file-name (getenv env))))
+ − 1856 (t nil))))))))
+ − 1857
+ − 1858
+ − 1859 (defun read-file-name-internal (string dir action)
+ − 1860 (read-file-name-internal-1
+ − 1861 string dir action
+ − 1862 #'(lambda (action orig string specdir dir name)
+ − 1863 (cond ((eq action 'lambda)
+ − 1864 (if (not orig)
+ − 1865 nil
+ − 1866 (let ((sstring (condition-case nil
+ − 1867 (expand-file-name string)
+ − 1868 (error nil))))
+ − 1869 (if (not sstring)
+ − 1870 ;; Some pathname syntax error in string
+ − 1871 nil
+ − 1872 (file-exists-p sstring)))))
+ − 1873 ((eq action 't)
+ − 1874 ;; all completions
+ − 1875 (mapcar #'un-substitute-in-file-name
442
+ − 1876 (if (string= name "")
+ − 1877 (delete "./" (file-name-all-completions "" dir))
+ − 1878 (file-name-all-completions name dir))))
428
+ − 1879 (t;; nil
+ − 1880 ;; complete
+ − 1881 (let* ((d (or dir default-directory))
+ − 1882 (val (file-name-completion name d)))
+ − 1883 (if (and (eq val 't)
+ − 1884 (not (null completion-ignored-extensions)))
+ − 1885 ;;#### (file-name-completion "foo") returns 't
+ − 1886 ;; when both "foo" and "foo~" exist and the latter
+ − 1887 ;; is "pruned" by completion-ignored-extensions.
+ − 1888 ;; I think this is a bug in file-name-completion.
+ − 1889 (setq val (let ((completion-ignored-extensions '()))
+ − 1890 (file-name-completion name d))))
+ − 1891 (if (stringp val)
+ − 1892 (un-substitute-in-file-name (if specdir
+ − 1893 (concat specdir val)
+ − 1894 val))
+ − 1895 (let ((tem (un-substitute-in-file-name string)))
+ − 1896 (if (not (equal tem orig))
+ − 1897 ;; substitute-in-file-name did something
+ − 1898 tem
+ − 1899 val)))))))))
+ − 1900
+ − 1901 (defun read-directory-name-internal (string dir action)
+ − 1902 (read-file-name-internal-1
+ − 1903 string dir action
+ − 1904 #'(lambda (action orig string specdir dir name)
+ − 1905 (let* ((dirs #'(lambda (fn)
+ − 1906 (let ((l (if (equal name "")
442
+ − 1907 (minibuf-directory-files
428
+ − 1908 dir
+ − 1909 ""
+ − 1910 'directories)
442
+ − 1911 (minibuf-directory-files
428
+ − 1912 dir
+ − 1913 (concat "\\`" (regexp-quote name))
+ − 1914 'directories))))
+ − 1915 (mapcar fn
+ − 1916 ;; Wretched unix
+ − 1917 (delete "." l))))))
+ − 1918 (cond ((eq action 'lambda)
+ − 1919 ;; complete?
+ − 1920 (if (not orig)
+ − 1921 nil
+ − 1922 (file-directory-p string)))
+ − 1923 ((eq action 't)
+ − 1924 ;; all completions
+ − 1925 (funcall dirs #'(lambda (n)
+ − 1926 (un-substitute-in-file-name
+ − 1927 (file-name-as-directory n)))))
+ − 1928 (t
+ − 1929 ;; complete
+ − 1930 (let ((val (try-completion
+ − 1931 name
+ − 1932 (funcall dirs
+ − 1933 #'(lambda (n)
+ − 1934 (list (file-name-as-directory
+ − 1935 n)))))))
+ − 1936 (if (stringp val)
+ − 1937 (un-substitute-in-file-name (if specdir
+ − 1938 (concat specdir val)
+ − 1939 val))
+ − 1940 (let ((tem (un-substitute-in-file-name string)))
+ − 1941 (if (not (equal tem orig))
+ − 1942 ;; substitute-in-file-name did something
+ − 1943 tem
+ − 1944 val))))))))))
+ − 1945
+ − 1946 (defun append-expand-filename (file-string string)
+ − 1947 "Append STRING to FILE-STRING differently depending on whether STRING
+ − 1948 is a username (~string), an environment variable ($string),
+ − 1949 or a filename (/string). The resultant string is returned with the
+ − 1950 environment variable or username expanded and resolved to indicate
+ − 1951 whether it is a file(/result) or a directory (/result/)."
+ − 1952 (let ((file
+ − 1953 (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string)
+ − 1954 (cond ((string= (substring file-string
+ − 1955 (match-beginning 1)
+ − 1956 (match-end 1)) "~")
+ − 1957 (concat (substring file-string 0 (match-end 1))
+ − 1958 string))
+ − 1959 (t (substitute-in-file-name
+ − 1960 (concat (substring file-string 0 (match-end 1))
+ − 1961 string)))))
+ − 1962 (t (concat (file-name-directory
+ − 1963 (substitute-in-file-name file-string)) string))))
+ − 1964 result)
+ − 1965
+ − 1966 (cond ((stringp (setq result (and (file-exists-p (expand-file-name file))
+ − 1967 (read-file-name-internal
+ − 1968 (condition-case nil
+ − 1969 (expand-file-name file)
+ − 1970 (error file))
+ − 1971 "" nil))))
+ − 1972 result)
+ − 1973 (t file))))
+ − 1974
442
+ − 1975 (defun mouse-rfn-setup-vars (prompt)
+ − 1976 ;; a specifier would be nice.
+ − 1977 (set (make-local-variable 'frame-title-format)
+ − 1978 (capitalize-string-as-title
+ − 1979 ;; Kludge: Delete ": " off the end.
+ − 1980 (replace-in-string prompt ": $" "")))
+ − 1981 ;; ensure that killing the frame works right,
+ − 1982 ;; instead of leaving us in the minibuffer.
+ − 1983 (add-local-hook 'delete-frame-hook
+ − 1984 #'(lambda (frame)
+ − 1985 (abort-recursive-edit))))
+ − 1986
428
+ − 1987 (defun mouse-file-display-completion-list (window dir minibuf user-data)
+ − 1988 (let ((standard-output (window-buffer window)))
+ − 1989 (condition-case nil
+ − 1990 (display-completion-list
442
+ − 1991 (minibuf-directory-files dir nil t)
+ − 1992 :window-width (window-width window)
+ − 1993 :window-height (window-text-area-height window)
+ − 1994 :completion-string ""
428
+ − 1995 :activate-callback
+ − 1996 'mouse-read-file-name-activate-callback
+ − 1997 :user-data user-data
+ − 1998 :reference-buffer minibuf
+ − 1999 :help-string "")
442
+ − 2000 (t nil))
+ − 2001 ))
428
+ − 2002
+ − 2003 (defun mouse-directory-display-completion-list (window dir minibuf user-data)
+ − 2004 (let ((standard-output (window-buffer window)))
+ − 2005 (condition-case nil
+ − 2006 (display-completion-list
442
+ − 2007 (minibuf-directory-files dir nil 1)
428
+ − 2008 :window-width (window-width window)
442
+ − 2009 :window-height (window-text-area-height window)
+ − 2010 :completion-string ""
428
+ − 2011 :activate-callback
+ − 2012 'mouse-read-file-name-activate-callback
+ − 2013 :user-data user-data
+ − 2014 :reference-buffer minibuf
+ − 2015 :help-string "")
442
+ − 2016 (t nil))
+ − 2017 ))
428
+ − 2018
+ − 2019 (defun mouse-read-file-name-activate-callback (event extent user-data)
+ − 2020 (let* ((file (extent-string extent))
+ − 2021 (minibuf (symbol-value-in-buffer 'completion-reference-buffer
+ − 2022 (extent-object extent)))
442
+ − 2023 (ministring (buffer-substring nil nil minibuf))
+ − 2024 (in-dir (file-name-directory ministring))
428
+ − 2025 (full (expand-file-name file in-dir))
+ − 2026 (filebuf (nth 0 user-data))
442
+ − 2027 (dirbuf (nth 1 user-data))
428
+ − 2028 (filewin (nth 2 user-data))
+ − 2029 (dirwin (nth 3 user-data)))
+ − 2030 (if (file-regular-p full)
+ − 2031 (default-choose-completion event extent minibuf)
+ − 2032 (erase-buffer minibuf)
+ − 2033 (insert-string (file-name-as-directory
+ − 2034 (abbreviate-file-name full t)) minibuf)
+ − 2035 (reset-buffer filebuf)
442
+ − 2036 (if (not dirbuf)
428
+ − 2037 (mouse-directory-display-completion-list filewin full minibuf
+ − 2038 user-data)
+ − 2039 (mouse-file-display-completion-list filewin full minibuf user-data)
442
+ − 2040 (reset-buffer dirbuf)
428
+ − 2041 (mouse-directory-display-completion-list dirwin full minibuf
+ − 2042 user-data)))))
+ − 2043
442
+ − 2044 ;; our cheesy but god-awful time consuming file dialog box implementation.
+ − 2045 ;; this will be replaced with use of the native file dialog box (when
+ − 2046 ;; available).
428
+ − 2047 (defun mouse-read-file-name-1 (history prompt dir default
442
+ − 2048 must-match initial-contents
+ − 2049 completer)
+ − 2050 ;; file-p is t if we're reading files, nil if directories.
428
+ − 2051 (let* ((file-p (eq 'read-file-name-internal completer))
+ − 2052 (filebuf (get-buffer-create "*Completions*"))
442
+ − 2053 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*")))
+ − 2054 (butbuf (generate-new-buffer " *mouse-read-file*"))
428
+ − 2055 (frame (make-dialog-frame))
+ − 2056 filewin dirwin
+ − 2057 user-data)
+ − 2058 (unwind-protect
+ − 2059 (progn
+ − 2060 (reset-buffer filebuf)
442
+ − 2061
+ − 2062 ;; set up the frame.
+ − 2063 (focus-frame frame)
428
+ − 2064 (let ((window-min-height 1))
+ − 2065 ;; #### should be 2 not 3, but that causes
+ − 2066 ;; "window too small to split" errors for some
+ − 2067 ;; people (but not for me ...) There's a more
+ − 2068 ;; fundamental bug somewhere.
+ − 2069 (split-window nil (- (frame-height frame) 3)))
+ − 2070 (if file-p
+ − 2071 (progn
+ − 2072 (split-window-horizontally 16)
+ − 2073 (setq filewin (frame-rightmost-window frame)
+ − 2074 dirwin (frame-leftmost-window frame))
+ − 2075 (set-window-buffer filewin filebuf)
442
+ − 2076 (set-window-buffer dirwin dirbuf))
428
+ − 2077 (setq filewin (frame-highest-window frame))
+ − 2078 (set-window-buffer filewin filebuf))
442
+ − 2079 (setq user-data (list filebuf dirbuf filewin dirwin))
+ − 2080 (set-window-buffer (frame-lowest-window frame) butbuf)
+ − 2081
+ − 2082 ;; set up completion buffers.
+ − 2083 (let ((rfcshookfun
+ − 2084 ;; kludge!
+ − 2085 ;; #### I really need to flesh out the object
+ − 2086 ;; hierarchy better to avoid these kludges.
+ − 2087 ;; (?? I wrote this comment above some time ago,
+ − 2088 ;; and I don't understand what I'm referring to
+ − 2089 ;; any more. --ben
+ − 2090 (lambda ()
+ − 2091 (mouse-rfn-setup-vars prompt)
+ − 2092 (when (featurep 'scrollbar)
+ − 2093 (set-specifier scrollbar-width 0 (current-buffer)))
+ − 2094 (setq truncate-lines t))))
+ − 2095
+ − 2096 (set-buffer filebuf)
+ − 2097 (add-local-hook 'completion-setup-hook rfcshookfun)
+ − 2098 (when file-p
+ − 2099 (set-buffer dirbuf)
+ − 2100 (add-local-hook 'completion-setup-hook rfcshookfun)))
+ − 2101
+ − 2102 ;; set up minibuffer.
+ − 2103 (add-one-shot-hook
+ − 2104 'minibuffer-setup-hook
+ − 2105 (lambda ()
+ − 2106 (if (not file-p)
+ − 2107 (mouse-directory-display-completion-list
+ − 2108 filewin dir (current-buffer) user-data)
+ − 2109 (mouse-file-display-completion-list
+ − 2110 filewin dir (current-buffer) user-data)
+ − 2111 (mouse-directory-display-completion-list
+ − 2112 dirwin dir (current-buffer) user-data))
+ − 2113 (set
+ − 2114 (make-local-variable
+ − 2115 'completion-display-completion-list-function)
+ − 2116 (lambda (completions)
+ − 2117 (display-completion-list
+ − 2118 completions
+ − 2119 :help-string ""
+ − 2120 :window-width (window-width filewin)
+ − 2121 :window-height (window-text-area-height filewin)
+ − 2122 :completion-string ""
+ − 2123 :activate-callback
+ − 2124 'mouse-read-file-name-activate-callback
+ − 2125 :user-data user-data)))
+ − 2126 (mouse-rfn-setup-vars prompt)
+ − 2127 (save-selected-window
+ − 2128 ;; kludge to ensure the frame title is correct.
+ − 2129 ;; the minibuffer leaves the frame title the way
+ − 2130 ;; it was before (i.e. of the selected window before
+ − 2131 ;; the dialog box was opened), so to get it correct
+ − 2132 ;; we have to be tricky.
+ − 2133 (select-window filewin)
+ − 2134 (redisplay-frame nil t)
+ − 2135 ;; #### another kludge. sometimes the focus ends up
+ − 2136 ;; back in the main window, not the dialog box. it
+ − 2137 ;; occurs randomly and it's not possible to reliably
+ − 2138 ;; reproduce. We try to fix it by draining non-user
+ − 2139 ;; events and then setting the focus back on the frame.
+ − 2140 (sit-for 0 t)
+ − 2141 (focus-frame frame))))
+ − 2142
+ − 2143 ;; set up button buffer.
+ − 2144 (set-buffer butbuf)
+ − 2145 (mouse-rfn-setup-vars prompt)
428
+ − 2146 (when dir
+ − 2147 (setq default-directory dir))
+ − 2148 (when (featurep 'scrollbar)
442
+ − 2149 (set-specifier scrollbar-width 0 butbuf))
428
+ − 2150 (insert " ")
+ − 2151 (insert-gui-button (make-gui-button "OK"
+ − 2152 (lambda (foo)
+ − 2153 (exit-minibuffer))))
+ − 2154 (insert " ")
+ − 2155 (insert-gui-button (make-gui-button "Cancel"
+ − 2156 (lambda (foo)
+ − 2157 (abort-recursive-edit))))
442
+ − 2158
+ − 2159 ;; now start reading filename.
+ − 2160 (read-file-name-2 history prompt dir default
+ − 2161 must-match initial-contents
+ − 2162 completer))
+ − 2163
+ − 2164 ;; always clean up.
+ − 2165 ;; get rid of our hook that calls abort-recursive-edit -- not a good
+ − 2166 ;; idea here.
+ − 2167 (kill-local-variable 'delete-frame-hook)
428
+ − 2168 (delete-frame frame)
+ − 2169 (kill-buffer filebuf)
442
+ − 2170 (kill-buffer butbuf)
+ − 2171 (and dirbuf (kill-buffer dirbuf)))))
428
+ − 2172
+ − 2173 (defun read-face (prompt &optional must-match)
+ − 2174 "Read the name of a face from the minibuffer and return it as a symbol."
+ − 2175 (intern (completing-read prompt obarray 'find-face must-match)))
+ − 2176
+ − 2177 ;; #### - wrong place for this variable? Exactly. We probably want
+ − 2178 ;; `color-list' to be a console method, so `tty-color-list' becomes
+ − 2179 ;; obsolete, and `read-color-completion-table' conses (mapcar #'list
+ − 2180 ;; (color-list)), optionally caching the results.
+ − 2181
+ − 2182 ;; Ben wanted all of the possibilities from the `configure' script used
+ − 2183 ;; here, but I think this is way too many. I already trimmed the R4 variants
+ − 2184 ;; and a few obvious losers from the list. --Stig
+ − 2185 (defvar x-library-search-path '("/usr/X11R6/lib/X11/"
+ − 2186 "/usr/X11R5/lib/X11/"
+ − 2187 "/usr/lib/X11R6/X11/"
+ − 2188 "/usr/lib/X11R5/X11/"
+ − 2189 "/usr/local/X11R6/lib/X11/"
+ − 2190 "/usr/local/X11R5/lib/X11/"
+ − 2191 "/usr/local/lib/X11R6/X11/"
+ − 2192 "/usr/local/lib/X11R5/X11/"
+ − 2193 "/usr/X11/lib/X11/"
+ − 2194 "/usr/lib/X11/"
+ − 2195 "/usr/local/lib/X11/"
+ − 2196 "/usr/X386/lib/X11/"
+ − 2197 "/usr/x386/lib/X11/"
+ − 2198 "/usr/XFree86/lib/X11/"
+ − 2199 "/usr/unsupported/lib/X11/"
+ − 2200 "/usr/athena/lib/X11/"
+ − 2201 "/usr/local/x11r5/lib/X11/"
+ − 2202 "/usr/lpp/Xamples/lib/X11/"
+ − 2203 "/usr/openwin/lib/X11/"
+ − 2204 "/usr/openwin/share/lib/X11/")
+ − 2205 "Search path used by `read-color' to find rgb.txt.")
+ − 2206
+ − 2207 (defvar x-read-color-completion-table)
+ − 2208
+ − 2209 (defun read-color-completion-table ()
+ − 2210 (case (device-type)
+ − 2211 ;; #### Evil device-type dependency
462
+ − 2212 ((x gtk)
428
+ − 2213 (if (boundp 'x-read-color-completion-table)
+ − 2214 x-read-color-completion-table
+ − 2215 (let ((rgb-file (locate-file "rgb.txt" x-library-search-path))
+ − 2216 clist color p)
+ − 2217 (if (not rgb-file)
+ − 2218 ;; prevents multiple searches for rgb.txt if we can't find it
+ − 2219 (setq x-read-color-completion-table nil)
+ − 2220 (with-current-buffer (get-buffer-create " *colors*")
+ − 2221 (reset-buffer (current-buffer))
+ − 2222 (insert-file-contents rgb-file)
+ − 2223 (while (not (eobp))
+ − 2224 ;; skip over comments
+ − 2225 (while (looking-at "^!")
+ − 2226 (end-of-line)
+ − 2227 (forward-char 1))
+ − 2228 (skip-chars-forward "0-9 \t")
+ − 2229 (setq p (point))
+ − 2230 (end-of-line)
+ − 2231 (setq color (buffer-substring p (point))
+ − 2232 clist (cons (list color) clist))
+ − 2233 ;; Ugh. If we want to be able to complete the lowercase form
+ − 2234 ;; of the color name, we need to add it twice! Yuck.
+ − 2235 (let ((dcase (downcase color)))
+ − 2236 (or (string= dcase color)
+ − 2237 (push (list dcase) clist)))
+ − 2238 (forward-char 1))
+ − 2239 (kill-buffer (current-buffer))))
+ − 2240 (setq x-read-color-completion-table clist)
+ − 2241 x-read-color-completion-table)))
+ − 2242 (mswindows
502
+ − 2243 (mapcar #'list (declare-fboundp (mswindows-color-list))))
428
+ − 2244 (tty
502
+ − 2245 (mapcar #'list (declare-fboundp (tty-color-list))))))
428
+ − 2246
+ − 2247 (defun read-color (prompt &optional must-match initial-contents)
+ − 2248 "Read the name of a color from the minibuffer.
+ − 2249 On X devices, this uses `x-library-search-path' to find rgb.txt in order
+ − 2250 to build a completion table.
+ − 2251 On TTY devices, this uses `tty-color-list'.
+ − 2252 On mswindows devices, this uses `mswindows-color-list'."
+ − 2253 (let ((table (read-color-completion-table)))
+ − 2254 (completing-read prompt table nil (and table must-match)
+ − 2255 initial-contents)))
+ − 2256
+ − 2257
+ − 2258 ;; #### The doc string for read-non-nil-coding system gets lost if we
+ − 2259 ;; only include these if the mule feature is present. Strangely,
+ − 2260 ;; read-coding-system doesn't.
+ − 2261
+ − 2262 ;;(if (featurep 'mule)
+ − 2263
+ − 2264 (defun read-coding-system (prompt &optional default-coding-system)
+ − 2265 "Read a coding-system (or nil) from the minibuffer.
+ − 2266 Prompting with string PROMPT.
+ − 2267 If the user enters null input, return second argument DEFAULT-CODING-SYSTEM.
+ − 2268 DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object."
+ − 2269 (intern (completing-read prompt obarray 'find-coding-system t nil nil
+ − 2270 (cond ((symbolp default-coding-system)
+ − 2271 (symbol-name default-coding-system))
+ − 2272 ((coding-system-p default-coding-system)
+ − 2273 (symbol-name (coding-system-name default-coding-system)))
+ − 2274 (t
+ − 2275 default-coding-system)))))
+ − 2276
+ − 2277 (defun read-non-nil-coding-system (prompt)
+ − 2278 "Read a non-nil coding-system from the minibuffer.
+ − 2279 Prompt with string PROMPT."
+ − 2280 (let ((retval (intern "")))
+ − 2281 (while (= 0 (length (symbol-name retval)))
+ − 2282 (setq retval (intern (completing-read prompt obarray
+ − 2283 'find-coding-system
+ − 2284 t))))
+ − 2285 retval))
+ − 2286
+ − 2287 ;;) ;; end of (featurep 'mule)
+ − 2288
+ − 2289
+ − 2290
+ − 2291 (defcustom force-dialog-box-use nil
+ − 2292 "*If non-nil, always use a dialog box for asking questions, if possible.
+ − 2293 You should *bind* this, not set it. This is useful if you're doing
+ − 2294 something mousy but which wasn't actually invoked using the mouse."
+ − 2295 :type 'boolean
+ − 2296 :group 'minibuffer)
+ − 2297
+ − 2298 ;; We include this here rather than dialog.el so it is defined
+ − 2299 ;; even when dialog boxes are not present.
+ − 2300 (defun should-use-dialog-box-p ()
+ − 2301 "If non-nil, questions should be asked with a dialog box instead of the
+ − 2302 minibuffer. This looks at `last-command-event' to see if it was a mouse
+ − 2303 event, and checks whether dialog-support exists and the current device
+ − 2304 supports dialog boxes.
+ − 2305
+ − 2306 The dialog box is totally disabled if the variable `use-dialog-box'
+ − 2307 is set to nil."
+ − 2308 (and (featurep 'dialog)
+ − 2309 (device-on-window-system-p)
+ − 2310 use-dialog-box
+ − 2311 (or force-dialog-box-use
+ − 2312 (button-press-event-p last-command-event)
+ − 2313 (button-release-event-p last-command-event)
+ − 2314 (misc-user-event-p last-command-event))))
+ − 2315
+ − 2316 ;;; minibuf.el ends here
