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