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