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