Mercurial > hg > xemacs-beta
annotate lisp/minibuf.el @ 5889:bd644055ef44
Correct a bug in #'check-type, non-setf'able PLACEs
lisp/ChangeLog addition:
2015-04-11 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el:
* cl-macs.el (check-type):
Correct the sense of the type test here when PLACE is not
setf'able, something which gave confusing errors with literal
fixnums or, e.g., (+ 30 40).
tests/ChangeLog addition:
2015-04-11 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Check for a bug just fixed in cl-macs.el.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 11 Apr 2015 18:06:17 +0100 |
| parents | bbe4146603db |
| children |
| 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) | |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
1486 (let ((n (count ?$ string)) |
| 428 | 1487 (olen (length string)) |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
1488 new o ch) |
|
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
1489 (if (eql n 0) |
| 428 | 1490 string |
| 1491 (setq new (make-string (+ olen n) ?$)) | |
| 1492 (setq n 0 o 0) | |
| 1493 (while (< o olen) | |
| 1494 (setq ch (aref string o)) | |
| 1495 (aset new n ch) | |
| 1496 (setq o (1+ o) n (1+ n)) | |
| 1497 (if (eq ch ?$) | |
| 1498 ;; already aset by make-string initial-value | |
| 1499 (setq n (1+ n)))) | |
| 1500 new))) | |
| 1501 | |
| 442 | 1502 ;; Wrapper for `directory-files' for use in generating completion lists. |
| 1503 ;; Generates output in the same format as `file-name-all-completions'. | |
| 1504 ;; | |
| 1505 ;; The EFS replacement for `directory-files' doesn't support the FILES-ONLY | |
| 1506 ;; option, so it has to be faked. The listing cache will hopefully | |
| 1507 ;; improve the performance of this operation. | |
| 1508 (defun minibuf-directory-files (dir &optional match-regexp files-only) | |
| 1509 (let ((want-file (or (eq files-only nil) (eq files-only t))) | |
| 1510 (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
|
1511 (mapcan |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1512 #'(lambda (f) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1513 (and (not (equal "." f)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1514 (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
|
1515 (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
|
1516 (and want-file (list f))))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1517 (directory-files dir nil match-regexp)))) |
| 442 | 1518 |
| 1519 | |
| 428 | 1520 (defun read-file-name-2 (history prompt dir default |
| 1521 must-match initial-contents | |
| 1522 completer) | |
| 1523 (if (not dir) | |
| 1524 (setq dir default-directory)) | |
| 1525 (setq dir (abbreviate-file-name dir t)) | |
| 1526 (let* ((insert (cond ((and (not insert-default-directory) | |
| 1527 (not initial-contents)) | |
| 1528 "") | |
| 1529 (initial-contents | |
| 1530 (cons (un-substitute-in-file-name | |
| 1531 (concat dir initial-contents)) | |
| 1532 (length dir))) | |
| 1533 (t | |
| 1534 (un-substitute-in-file-name dir)))) | |
| 1535 (val | |
| 1536 ;; Hateful, broken, case-sensitive un*x | |
| 1537 ;;; (completing-read prompt | |
| 1538 ;;; completer | |
| 1539 ;;; dir | |
| 1540 ;;; must-match | |
| 1541 ;;; insert | |
| 1542 ;;; history) | |
| 1543 ;; #### - this is essentially the guts of completing read. | |
| 1544 ;; There should be an elegant way to pass a pair of keymaps to | |
| 1545 ;; completing read, but this will do for now. All sins are | |
| 1546 ;; relative. --Stig | |
| 1547 (let ((minibuffer-completion-table completer) | |
| 1548 (minibuffer-completion-predicate dir) | |
| 1549 (minibuffer-completion-confirm (if (eq must-match 't) | |
| 1550 nil t)) | |
| 1551 (last-exact-completion nil)) | |
| 1552 (read-from-minibuffer prompt | |
| 1553 insert | |
| 1554 (if (not must-match) | |
| 1555 read-file-name-map | |
| 1556 read-file-name-must-match-map) | |
| 1557 nil | |
| 434 | 1558 history |
| 1559 nil | |
| 1560 default)))) | |
| 428 | 1561 ;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" |
| 1562 ;;; (let ((hist (cond ((not history) 'minibuffer-history) | |
| 1563 ;;; ((consp history) (car history)) | |
| 1564 ;;; (t history)))) | |
| 1565 ;;; (if (and val | |
| 1566 ;;; hist | |
| 1567 ;;; (not (eq hist 't)) | |
| 1568 ;;; (boundp hist) | |
| 1569 ;;; (equal (car-safe (symbol-value hist)) val)) | |
| 1570 ;;; (let ((e (condition-case nil | |
| 1571 ;;; (expand-file-name val) | |
| 1572 ;;; (error nil)))) | |
| 1573 ;;; (if (and e (not (equal e val))) | |
| 1574 ;;; (set hist (cons e (cdr (symbol-value hist)))))))) | |
| 1575 | |
| 1576 (cond ((not val) | |
| 1577 (error "No file name specified")) | |
| 1578 ((and default | |
| 1579 (equal val (if (consp insert) (car insert) insert))) | |
| 1580 default) | |
| 1581 (t | |
| 1582 (substitute-in-file-name val))))) | |
| 1583 | |
| 1584 ;; #### this function should use minibuffer-completion-table | |
| 1585 ;; or something. But that is sloooooow. | |
| 1586 ;; #### all this shit needs better documentation!!!!!!!! | |
| 1587 (defun read-file-name-activate-callback (event extent dir-p) | |
| 1588 ;; used as the activate-callback of the filename list items | |
| 1589 ;; in the completion buffer, in place of default-choose-completion. | |
| 1590 ;; if a regular file was selected, we call default-choose-completion | |
| 1591 ;; (which just inserts the string in the minibuffer and calls | |
| 1592 ;; exit-minibuffer). If a directory was selected, we display | |
| 1593 ;; the contents of the directory. | |
| 1594 (let* ((file (extent-string extent)) | |
| 1595 (completion-buf (extent-object extent)) | |
| 1596 (minibuf (symbol-value-in-buffer 'completion-reference-buffer | |
| 1597 completion-buf)) | |
| 1598 (in-dir (file-name-directory (buffer-substring nil nil minibuf))) | |
| 1599 (full (expand-file-name file in-dir))) | |
| 1600 (if (not (file-directory-p full)) | |
| 1601 (default-choose-completion event extent minibuf) | |
| 1602 (erase-buffer minibuf) | |
| 1603 (insert-string (file-name-as-directory | |
| 1604 (abbreviate-file-name full t)) minibuf) | |
| 1605 (reset-buffer completion-buf) | |
| 1606 (let ((standard-output completion-buf)) | |
| 1607 (display-completion-list | |
| 442 | 1608 (minibuf-directory-files full nil (if dir-p 'directory)) |
| 428 | 1609 :user-data dir-p |
| 1610 :reference-buffer minibuf | |
| 1611 :activate-callback 'read-file-name-activate-callback) | |
| 1612 (goto-char (point-min) completion-buf))))) | |
| 1613 | |
| 673 | 1614 (defun read-file-name-1 (type history prompt dir default |
| 1615 must-match initial-contents | |
| 1616 completer) | |
| 428 | 1617 (if (should-use-dialog-box-p) |
| 442 | 1618 (condition-case nil |
| 1619 (let ((file | |
| 1620 (apply #'make-dialog-box | |
| 673 | 1621 type `(:title ,(capitalize-string-as-title |
| 1622 ;; Kludge: Delete ": " off the end. | |
| 1623 (replace-in-string prompt ": $" "")) | |
| 1624 ,@(and dir (list :initial-directory | |
| 1625 dir)) | |
| 1626 :file-must-exist ,must-match | |
| 1627 ,@(and initial-contents | |
| 1628 (list :initial-filename | |
| 1629 initial-contents)))))) | |
| 442 | 1630 ;; hack -- until we implement reading a directory properly, |
| 1631 ;; allow a file as indicating the directory it's in | |
| 1632 (if (and (eq completer 'read-directory-name-internal) | |
| 1633 (not (file-directory-p file))) | |
| 1634 (file-name-directory file) | |
| 1635 file)) | |
| 1636 (unimplemented | |
| 1637 ;; this calls read-file-name-2 | |
| 1638 (mouse-read-file-name-1 history prompt dir default must-match | |
| 1639 initial-contents completer) | |
| 1640 )) | |
| 1641 (add-one-shot-hook | |
| 1642 'minibuffer-setup-hook | |
| 1643 (lambda () | |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1644 (and (file-system-ignore-case-p (or dir default-directory)) |
| 442 | 1645 (set (make-local-variable 'completion-ignore-case) t)) |
| 1646 (set | |
| 1647 (make-local-variable | |
| 1648 'completion-display-completion-list-function) | |
| 1649 #'(lambda (completions) | |
| 1650 (display-completion-list | |
| 1651 completions | |
| 1652 :user-data (not (eq completer 'read-file-name-internal)) | |
| 1653 :activate-callback | |
| 1654 'read-file-name-activate-callback))))) | |
| 1655 (read-file-name-2 history prompt dir default must-match | |
| 1656 initial-contents completer))) | |
| 428 | 1657 |
| 1658 (defun read-file-name (prompt | |
| 1659 &optional dir default must-match initial-contents | |
| 1660 history) | |
| 1661 "Read file name, prompting with PROMPT and completing in directory DIR. | |
| 1662 This will prompt with a dialog box if appropriate, according to | |
| 1663 `should-use-dialog-box-p'. | |
| 1664 Value is not expanded---you must call `expand-file-name' yourself. | |
| 438 | 1665 Value is subject to interpretation by `substitute-in-file-name' however. |
| 428 | 1666 Default name to DEFAULT if user enters a null string. |
| 1667 (If DEFAULT is omitted, the visited file name is used, | |
| 1668 except that if INITIAL-CONTENTS is specified, that combined with DIR is | |
| 1669 used.) | |
| 1670 Fourth arg MUST-MATCH non-nil means require existing file's name. | |
| 1671 Non-nil and non-t means also require confirmation after completion. | |
| 440 | 1672 Fifth arg INITIAL-CONTENTS specifies text to start with. If this is not |
| 1673 specified, and `insert-default-directory' is non-nil, DIR or the current | |
| 1674 directory will be used. | |
| 428 | 1675 Sixth arg HISTORY specifies the history list to use. Default is |
| 1676 `file-name-history'. | |
| 1677 DIR defaults to current buffer's directory default." | |
| 673 | 1678 (read-file-name-1 |
| 1679 'file (or history 'file-name-history) | |
| 428 | 1680 prompt dir (or default |
| 440 | 1681 (and initial-contents |
| 1682 (abbreviate-file-name (expand-file-name | |
| 1683 initial-contents dir) t)) | |
| 1684 (and buffer-file-truename | |
| 1685 (abbreviate-file-name buffer-file-name t))) | |
| 428 | 1686 must-match initial-contents |
| 1687 ;; A separate function (not an anonymous lambda-expression) | |
| 1688 ;; and passed as a symbol because of disgusting kludges in various | |
| 1689 ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...) | |
| 1690 'read-file-name-internal)) | |
| 1691 | |
| 1692 (defun read-directory-name (prompt | |
| 1693 &optional dir default must-match initial-contents | |
| 1694 history) | |
| 1695 "Read directory name, prompting with PROMPT and completing in directory DIR. | |
| 1696 This will prompt with a dialog box if appropriate, according to | |
| 1697 `should-use-dialog-box-p'. | |
| 1698 Value is not expanded---you must call `expand-file-name' yourself. | |
| 1699 Value is subject to interpreted by substitute-in-file-name however. | |
| 1700 Default name to DEFAULT if user enters a null string. | |
| 1701 (If DEFAULT is omitted, the current buffer's default directory is used.) | |
| 1702 Fourth arg MUST-MATCH non-nil means require existing directory's name. | |
| 1703 Non-nil and non-t means also require confirmation after completion. | |
| 1704 Fifth arg INITIAL-CONTENTS specifies text to start with. | |
| 1705 Sixth arg HISTORY specifies the history list to use. Default is | |
| 1706 `file-name-history'. | |
| 1707 DIR defaults to current buffer's directory default." | |
| 1708 (read-file-name-1 | |
| 673 | 1709 'directory (or history 'file-name-history) |
| 1710 prompt dir (or default default-directory) must-match initial-contents | |
| 1711 'read-directory-name-internal)) | |
| 428 | 1712 |
| 1713 | |
| 1714 ;; Environment-variable and ~username completion hack | |
| 1715 (defun read-file-name-internal-1 (string dir action completer) | |
| 1716 (if (not (string-match | |
| 1717 "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'" | |
| 1718 string)) | |
| 1719 ;; Not doing environment-variable completion hack | |
| 1720 (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
|
1721 (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
|
1722 (or dir default-directory))) |
| 428 | 1723 (sstring (if orig (substitute-in-file-name string) string)) |
| 1724 (specdir (if orig (file-name-directory sstring) nil)) | |
| 1725 (name (if orig (file-name-nondirectory sstring) string)) | |
| 1726 (direct (if specdir (expand-file-name specdir dir) dir))) | |
| 1727 ;; ~username completion | |
| 1728 (if (and (fboundp 'user-name-completion-1) | |
| 1729 (string-match "^[~]" name)) | |
| 1730 (let ((user (substring name 1))) | |
| 1731 (cond ((eq action 'lambda) | |
| 1732 (file-directory-p name)) | |
| 1733 ((eq action 't) | |
| 1734 ;; all completions | |
| 1735 (mapcar #'(lambda (p) (concat "~" p)) | |
| 502 | 1736 (declare-fboundp |
| 1737 (user-name-all-completions user)))) | |
| 428 | 1738 (t;; 'nil |
| 1739 ;; complete | |
| 502 | 1740 (let* ((val+uniq (declare-fboundp |
| 1741 (user-name-completion-1 user))) | |
| 428 | 1742 (val (car val+uniq)) |
| 1743 (uniq (cdr val+uniq))) | |
| 1744 (cond ((stringp val) | |
| 1745 (if uniq | |
| 1746 (file-name-as-directory (concat "~" val)) | |
| 1747 (concat "~" val))) | |
| 1748 ((eq val t) | |
| 1749 (file-name-as-directory name)) | |
| 1750 (t nil)))))) | |
| 1751 (funcall completer | |
| 1752 action | |
| 1753 orig | |
| 1754 sstring | |
| 1755 specdir | |
| 1756 direct | |
| 1757 name))) | |
| 1758 ;; An odd number of trailing $'s | |
| 1759 (let* ((start (match-beginning 3)) | |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1760 (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
|
1761 (or dir default-directory))) |
| 428 | 1762 (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
|
1763 (cond ((eql start (length string)) |
| 428 | 1764 ;; "...$" |
| 1765 start) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5267
diff
changeset
|
1766 ((eql (aref string start) ?{) |
| 428 | 1767 ;; "...${..." |
| 1768 (1+ start)) | |
| 1769 (t | |
| 1770 start)))) | |
| 1771 (head (substring string 0 (1- start))) | |
| 1772 (alist #'(lambda () | |
|
5882
bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
1773 (mapcar #'(lambda (x) (subseq x 0 (position ?= x))) |
| 428 | 1774 process-environment)))) |
| 1775 | |
| 1776 (cond ((eq action 'lambda) | |
| 1777 nil) | |
| 1778 ((eq action 't) | |
| 1779 ;; all completions | |
| 1780 (mapcar #'(lambda (p) | |
| 1781 (if (and (> (length p) 0) | |
| 1782 ;;#### Unix-specific | |
| 1783 ;;#### -- need absolute-pathname-p | |
| 1784 (/= (aref p 0) ?/)) | |
| 1785 (concat "$" p) | |
| 1786 (concat head "$" p))) | |
| 1787 (all-completions env (funcall alist)))) | |
| 1788 (t ;; nil | |
| 1789 ;; complete | |
| 1790 (let* ((e (funcall alist)) | |
| 1791 (val (try-completion env e))) | |
| 1792 (cond ((stringp val) | |
| 1793 (if (string-match "[^A-Za-z0-9_]" val) | |
| 1794 (concat head | |
| 1795 "${" val | |
| 1796 ;; completed uniquely? | |
| 1797 (if (eq (try-completion val e) 't) | |
| 1798 "}" "")) | |
| 1799 (concat head "$" val))) | |
| 1800 ((eql val 't) | |
| 1801 (concat head | |
| 1802 (un-substitute-in-file-name (getenv env)))) | |
| 1803 (t nil)))))))) | |
| 1804 | |
| 1805 | |
| 1806 (defun read-file-name-internal (string dir action) | |
| 1807 (read-file-name-internal-1 | |
| 1808 string dir action | |
| 1809 #'(lambda (action orig string specdir dir name) | |
| 1810 (cond ((eq action 'lambda) | |
| 1811 (if (not orig) | |
| 1812 nil | |
| 1813 (let ((sstring (condition-case nil | |
| 1814 (expand-file-name string) | |
| 1815 (error nil)))) | |
| 1816 (if (not sstring) | |
| 1817 ;; Some pathname syntax error in string | |
| 1818 nil | |
| 1819 (file-exists-p sstring))))) | |
| 1820 ((eq action 't) | |
| 1821 ;; all completions | |
| 1822 (mapcar #'un-substitute-in-file-name | |
| 442 | 1823 (if (string= name "") |
| 1824 (delete "./" (file-name-all-completions "" dir)) | |
| 1825 (file-name-all-completions name dir)))) | |
| 428 | 1826 (t;; nil |
| 1827 ;; complete | |
| 1828 (let* ((d (or dir default-directory)) | |
| 1829 (val (file-name-completion name d))) | |
| 1830 (if (and (eq val 't) | |
| 1831 (not (null completion-ignored-extensions))) | |
| 1832 ;;#### (file-name-completion "foo") returns 't | |
| 1833 ;; when both "foo" and "foo~" exist and the latter | |
| 1834 ;; is "pruned" by completion-ignored-extensions. | |
| 1835 ;; I think this is a bug in file-name-completion. | |
| 1836 (setq val (let ((completion-ignored-extensions '())) | |
| 1837 (file-name-completion name d)))) | |
| 1838 (if (stringp val) | |
| 1839 (un-substitute-in-file-name (if specdir | |
| 1840 (concat specdir val) | |
| 1841 val)) | |
| 1842 (let ((tem (un-substitute-in-file-name string))) | |
| 1843 (if (not (equal tem orig)) | |
| 1844 ;; substitute-in-file-name did something | |
| 1845 tem | |
| 1846 val))))))))) | |
| 1847 | |
| 1848 (defun read-directory-name-internal (string dir action) | |
| 1849 (read-file-name-internal-1 | |
| 1850 string dir action | |
| 1851 #'(lambda (action orig string specdir dir name) | |
| 1852 (let* ((dirs #'(lambda (fn) | |
| 1853 (let ((l (if (equal name "") | |
| 442 | 1854 (minibuf-directory-files |
| 428 | 1855 dir |
| 1856 "" | |
| 1857 'directories) | |
| 442 | 1858 (minibuf-directory-files |
| 428 | 1859 dir |
| 1860 (concat "\\`" (regexp-quote name)) | |
| 1861 'directories)))) | |
| 1862 (mapcar fn | |
| 1863 ;; Wretched unix | |
| 1864 (delete "." l)))))) | |
| 1865 (cond ((eq action 'lambda) | |
| 1866 ;; complete? | |
| 1867 (if (not orig) | |
| 1868 nil | |
| 1869 (file-directory-p string))) | |
| 1870 ((eq action 't) | |
| 1871 ;; all completions | |
| 1872 (funcall dirs #'(lambda (n) | |
| 1873 (un-substitute-in-file-name | |
| 1874 (file-name-as-directory n))))) | |
| 1875 (t | |
| 1876 ;; complete | |
| 1877 (let ((val (try-completion | |
| 1878 name | |
| 1879 (funcall dirs | |
| 1880 #'(lambda (n) | |
| 1881 (list (file-name-as-directory | |
| 1882 n))))))) | |
| 1883 (if (stringp val) | |
| 1884 (un-substitute-in-file-name (if specdir | |
| 1885 (concat specdir val) | |
| 1886 val)) | |
| 1887 (let ((tem (un-substitute-in-file-name string))) | |
| 1888 (if (not (equal tem orig)) | |
| 1889 ;; substitute-in-file-name did something | |
| 1890 tem | |
| 1891 val)))))))))) | |
| 1892 | |
| 1893 (defun append-expand-filename (file-string string) | |
| 1894 "Append STRING to FILE-STRING differently depending on whether STRING | |
| 1895 is a username (~string), an environment variable ($string), | |
| 1896 or a filename (/string). The resultant string is returned with the | |
| 1897 environment variable or username expanded and resolved to indicate | |
| 1898 whether it is a file(/result) or a directory (/result/)." | |
| 1899 (let ((file | |
| 1900 (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string) | |
| 1901 (cond ((string= (substring file-string | |
| 1902 (match-beginning 1) | |
| 1903 (match-end 1)) "~") | |
| 1904 (concat (substring file-string 0 (match-end 1)) | |
| 1905 string)) | |
| 1906 (t (substitute-in-file-name | |
| 1907 (concat (substring file-string 0 (match-end 1)) | |
| 1908 string))))) | |
| 1909 (t (concat (file-name-directory | |
| 1910 (substitute-in-file-name file-string)) string)))) | |
| 1911 result) | |
| 1912 | |
| 1913 (cond ((stringp (setq result (and (file-exists-p (expand-file-name file)) | |
| 1914 (read-file-name-internal | |
| 1915 (condition-case nil | |
| 1916 (expand-file-name file) | |
| 1917 (error file)) | |
| 1918 "" nil)))) | |
| 1919 result) | |
| 1920 (t file)))) | |
| 1921 | |
| 442 | 1922 (defun mouse-rfn-setup-vars (prompt) |
| 1923 ;; a specifier would be nice. | |
| 1924 (set (make-local-variable 'frame-title-format) | |
| 1925 (capitalize-string-as-title | |
| 1926 ;; Kludge: Delete ": " off the end. | |
| 1927 (replace-in-string prompt ": $" ""))) | |
| 1928 ;; ensure that killing the frame works right, | |
| 1929 ;; instead of leaving us in the minibuffer. | |
| 1930 (add-local-hook 'delete-frame-hook | |
| 1931 #'(lambda (frame) | |
| 1932 (abort-recursive-edit)))) | |
| 1933 | |
| 428 | 1934 (defun mouse-file-display-completion-list (window dir minibuf user-data) |
| 1935 (let ((standard-output (window-buffer window))) | |
| 1936 (condition-case nil | |
| 1937 (display-completion-list | |
| 442 | 1938 (minibuf-directory-files dir nil t) |
| 1939 :window-width (window-width window) | |
| 1940 :window-height (window-text-area-height window) | |
| 1941 :completion-string "" | |
| 428 | 1942 :activate-callback |
| 1943 'mouse-read-file-name-activate-callback | |
| 1944 :user-data user-data | |
| 1945 :reference-buffer minibuf | |
| 1946 :help-string "") | |
| 442 | 1947 (t nil)) |
| 1948 )) | |
| 428 | 1949 |
| 1950 (defun mouse-directory-display-completion-list (window dir minibuf user-data) | |
| 1951 (let ((standard-output (window-buffer window))) | |
| 1952 (condition-case nil | |
| 1953 (display-completion-list | |
| 442 | 1954 (minibuf-directory-files dir nil 1) |
| 428 | 1955 :window-width (window-width window) |
| 442 | 1956 :window-height (window-text-area-height window) |
| 1957 :completion-string "" | |
| 428 | 1958 :activate-callback |
| 1959 'mouse-read-file-name-activate-callback | |
| 1960 :user-data user-data | |
| 1961 :reference-buffer minibuf | |
| 1962 :help-string "") | |
| 442 | 1963 (t nil)) |
| 1964 )) | |
| 428 | 1965 |
| 1966 (defun mouse-read-file-name-activate-callback (event extent user-data) | |
| 1967 (let* ((file (extent-string extent)) | |
| 1968 (minibuf (symbol-value-in-buffer 'completion-reference-buffer | |
| 1969 (extent-object extent))) | |
| 442 | 1970 (ministring (buffer-substring nil nil minibuf)) |
| 1971 (in-dir (file-name-directory ministring)) | |
| 428 | 1972 (full (expand-file-name file in-dir)) |
| 1973 (filebuf (nth 0 user-data)) | |
| 442 | 1974 (dirbuf (nth 1 user-data)) |
| 428 | 1975 (filewin (nth 2 user-data)) |
| 1976 (dirwin (nth 3 user-data))) | |
| 1977 (if (file-regular-p full) | |
| 1978 (default-choose-completion event extent minibuf) | |
| 1979 (erase-buffer minibuf) | |
| 1980 (insert-string (file-name-as-directory | |
| 1981 (abbreviate-file-name full t)) minibuf) | |
| 1982 (reset-buffer filebuf) | |
| 442 | 1983 (if (not dirbuf) |
| 428 | 1984 (mouse-directory-display-completion-list filewin full minibuf |
| 1985 user-data) | |
| 1986 (mouse-file-display-completion-list filewin full minibuf user-data) | |
| 442 | 1987 (reset-buffer dirbuf) |
| 428 | 1988 (mouse-directory-display-completion-list dirwin full minibuf |
| 1989 user-data))))) | |
| 1990 | |
| 442 | 1991 ;; our cheesy but god-awful time consuming file dialog box implementation. |
| 1992 ;; this will be replaced with use of the native file dialog box (when | |
| 1993 ;; available). | |
| 428 | 1994 (defun mouse-read-file-name-1 (history prompt dir default |
| 442 | 1995 must-match initial-contents |
| 1996 completer) | |
| 1997 ;; file-p is t if we're reading files, nil if directories. | |
| 428 | 1998 (let* ((file-p (eq 'read-file-name-internal completer)) |
| 1999 (filebuf (get-buffer-create "*Completions*")) | |
| 442 | 2000 (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
|
2001 (butbuf (generate-new-buffer " *mouse-read-file-buttons*")) |
| 428 | 2002 (frame (make-dialog-frame)) |
| 2003 filewin dirwin | |
|
4384
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2004 user-data |
|
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2005 (window-min-height 1)) ; allow button window to be height 2 |
| 428 | 2006 (unwind-protect |
| 2007 (progn | |
| 2008 (reset-buffer filebuf) | |
| 442 | 2009 |
| 2010 ;; set up the frame. | |
| 2011 (focus-frame frame) | |
|
4384
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2012 (split-window nil (- (window-height) 2)) |
| 428 | 2013 (if file-p |
| 2014 (progn | |
| 2015 (split-window-horizontally 16) | |
| 2016 (setq filewin (frame-rightmost-window frame) | |
| 2017 dirwin (frame-leftmost-window frame)) | |
| 2018 (set-window-buffer filewin filebuf) | |
| 442 | 2019 (set-window-buffer dirwin dirbuf)) |
| 428 | 2020 (setq filewin (frame-highest-window frame)) |
| 2021 (set-window-buffer filewin filebuf)) | |
| 442 | 2022 (setq user-data (list filebuf dirbuf filewin dirwin)) |
| 2023 (set-window-buffer (frame-lowest-window frame) butbuf) | |
| 2024 | |
| 2025 ;; set up completion buffers. | |
| 2026 (let ((rfcshookfun | |
| 2027 ;; kludge! | |
| 2028 ;; #### I really need to flesh out the object | |
| 2029 ;; hierarchy better to avoid these kludges. | |
| 2030 ;; (?? I wrote this comment above some time ago, | |
| 2031 ;; and I don't understand what I'm referring to | |
| 2032 ;; any more. --ben | |
| 2033 (lambda () | |
| 2034 (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
|
2035 (when-boundp 'scrollbar-width |
| 442 | 2036 (set-specifier scrollbar-width 0 (current-buffer))) |
| 2037 (setq truncate-lines t)))) | |
| 2038 | |
| 2039 (set-buffer filebuf) | |
| 2040 (add-local-hook 'completion-setup-hook rfcshookfun) | |
| 2041 (when file-p | |
| 2042 (set-buffer dirbuf) | |
| 2043 (add-local-hook 'completion-setup-hook rfcshookfun))) | |
| 2044 | |
| 2045 ;; set up minibuffer. | |
| 2046 (add-one-shot-hook | |
| 2047 'minibuffer-setup-hook | |
| 2048 (lambda () | |
| 2049 (if (not file-p) | |
| 2050 (mouse-directory-display-completion-list | |
| 2051 filewin dir (current-buffer) user-data) | |
| 2052 (mouse-file-display-completion-list | |
| 2053 filewin dir (current-buffer) user-data) | |
| 2054 (mouse-directory-display-completion-list | |
| 2055 dirwin dir (current-buffer) user-data)) | |
| 2056 (set | |
| 2057 (make-local-variable | |
| 2058 'completion-display-completion-list-function) | |
| 2059 (lambda (completions) | |
| 2060 (display-completion-list | |
| 2061 completions | |
| 2062 :help-string "" | |
| 2063 :window-width (window-width filewin) | |
| 2064 :window-height (window-text-area-height filewin) | |
| 2065 :completion-string "" | |
| 2066 :activate-callback | |
| 2067 'mouse-read-file-name-activate-callback | |
| 2068 :user-data user-data))) | |
| 2069 (mouse-rfn-setup-vars prompt) | |
| 2070 (save-selected-window | |
| 2071 ;; kludge to ensure the frame title is correct. | |
| 2072 ;; the minibuffer leaves the frame title the way | |
| 2073 ;; it was before (i.e. of the selected window before | |
| 2074 ;; the dialog box was opened), so to get it correct | |
| 2075 ;; we have to be tricky. | |
| 2076 (select-window filewin) | |
| 2077 (redisplay-frame nil t) | |
| 2078 ;; #### another kludge. sometimes the focus ends up | |
| 2079 ;; back in the main window, not the dialog box. it | |
| 2080 ;; occurs randomly and it's not possible to reliably | |
| 2081 ;; reproduce. We try to fix it by draining non-user | |
| 2082 ;; events and then setting the focus back on the frame. | |
| 2083 (sit-for 0 t) | |
| 2084 (focus-frame frame)))) | |
| 2085 | |
| 2086 ;; set up button buffer. | |
| 2087 (set-buffer butbuf) | |
| 2088 (mouse-rfn-setup-vars prompt) | |
| 428 | 2089 (when dir |
| 2090 (setq default-directory dir)) | |
| 2091 (when (featurep 'scrollbar) | |
| 442 | 2092 (set-specifier scrollbar-width 0 butbuf)) |
| 428 | 2093 (insert " ") |
| 2094 (insert-gui-button (make-gui-button "OK" | |
| 2095 (lambda (foo) | |
| 2096 (exit-minibuffer)))) | |
| 2097 (insert " ") | |
| 2098 (insert-gui-button (make-gui-button "Cancel" | |
| 2099 (lambda (foo) | |
| 2100 (abort-recursive-edit)))) | |
| 442 | 2101 |
| 2102 ;; now start reading filename. | |
| 2103 (read-file-name-2 history prompt dir default | |
| 2104 must-match initial-contents | |
| 2105 completer)) | |
| 2106 | |
| 2107 ;; always clean up. | |
| 2108 ;; get rid of our hook that calls abort-recursive-edit -- not a good | |
| 2109 ;; idea here. | |
| 2110 (kill-local-variable 'delete-frame-hook) | |
| 428 | 2111 (delete-frame frame) |
| 2112 (kill-buffer filebuf) | |
| 442 | 2113 (kill-buffer butbuf) |
| 2114 (and dirbuf (kill-buffer dirbuf))))) | |
| 428 | 2115 |
| 2116 (defun read-face (prompt &optional must-match) | |
| 2117 "Read the name of a face from the minibuffer and return it as a symbol." | |
| 2118 (intern (completing-read prompt obarray 'find-face must-match))) | |
| 2119 | |
| 2120 (defun read-color-completion-table () | |
| 2527 | 2121 (mapcar #'list (color-list))) |
| 428 | 2122 |
| 2123 (defun read-color (prompt &optional must-match initial-contents) | |
| 2124 "Read the name of a color from the minibuffer. | |
| 2125 On X devices, this uses `x-library-search-path' to find rgb.txt in order | |
| 2126 to build a completion table. | |
| 2127 On TTY devices, this uses `tty-color-list'. | |
| 2128 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
|
2129 (let ((table (color-list))) |
| 428 | 2130 (completing-read prompt table nil (and table must-match) |
| 2131 initial-contents))) | |
| 2132 | |
| 2133 | |
| 2134 (defun read-coding-system (prompt &optional default-coding-system) | |
| 2135 "Read a coding-system (or nil) from the minibuffer. | |
| 2136 Prompting with string PROMPT. | |
| 2137 If the user enters null input, return second argument DEFAULT-CODING-SYSTEM. | |
| 2138 DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object." | |
| 2139 (intern (completing-read prompt obarray 'find-coding-system t nil nil | |
| 2140 (cond ((symbolp default-coding-system) | |
| 2141 (symbol-name default-coding-system)) | |
| 2142 ((coding-system-p default-coding-system) | |
| 2143 (symbol-name (coding-system-name default-coding-system))) | |
| 2144 (t | |
| 2145 default-coding-system))))) | |
| 2146 | |
| 2147 (defun read-non-nil-coding-system (prompt) | |
| 2148 "Read a non-nil coding-system from the minibuffer. | |
| 2149 Prompt with string PROMPT." | |
| 2150 (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
|
2151 (while (eql 0 (length (symbol-name retval))) |
| 428 | 2152 (setq retval (intern (completing-read prompt obarray |
| 2153 'find-coding-system | |
| 2154 t)))) | |
| 2155 retval)) | |
| 2156 | |
| 2157 | |
| 2158 | |
| 2159 (defcustom force-dialog-box-use nil | |
| 2160 "*If non-nil, always use a dialog box for asking questions, if possible. | |
| 2161 You should *bind* this, not set it. This is useful if you're doing | |
| 2162 something mousy but which wasn't actually invoked using the mouse." | |
| 2163 :type 'boolean | |
| 2164 :group 'minibuffer) | |
| 2165 | |
| 2166 ;; We include this here rather than dialog.el so it is defined | |
| 2167 ;; even when dialog boxes are not present. | |
| 2168 (defun should-use-dialog-box-p () | |
| 2169 "If non-nil, questions should be asked with a dialog box instead of the | |
| 2170 minibuffer. This looks at `last-command-event' to see if it was a mouse | |
| 2171 event, and checks whether dialog-support exists and the current device | |
| 2172 supports dialog boxes. | |
| 2173 | |
| 2174 The dialog box is totally disabled if the variable `use-dialog-box' | |
| 2175 is set to nil." | |
| 2176 (and (featurep 'dialog) | |
| 2177 (device-on-window-system-p) | |
| 2178 use-dialog-box | |
| 2179 (or force-dialog-box-use | |
| 2180 (button-press-event-p last-command-event) | |
| 2181 (button-release-event-p last-command-event) | |
| 2182 (misc-user-event-p last-command-event)))) | |
| 2183 | |
| 2730 | 2184 (defun get-user-response (position question answers) |
| 2185 "Ask a question and get a response from the user, in minibuffer or dialog box. | |
| 2186 POSITION specifies which frame to use. | |
| 2187 This is normally an event or a window or frame. | |
| 2188 If POSITION is t or nil, it means to use the frame the mouse is on. | |
| 2189 The dialog box appears in the middle of the specified frame. | |
| 2190 | |
| 2191 QUESTION is the question to ask (it should end with a question mark followed | |
| 2192 by a space). | |
| 2193 | |
| 2194 ANSWERS are the possible answers. It is a list; each item looks like | |
| 2195 | |
| 2196 (KEY BUTTON-TEXT RESPONSE) | |
| 2197 | |
| 2198 where KEY is the key to be pressed in the minibuffer, BUTTON-TEXT is the | |
| 2199 text to be displayed in a dialog box button (you should put %_ in it to | |
| 2200 indicate the accelerator), and RESPONSE is a value (typically a symbol) | |
| 2201 to be returned if the user selects this response. KEY should be either a | |
| 2202 single character or a string; which one you use needs to be consistent for | |
| 2203 all responses and determines whether the user responds by hitting a single | |
| 2204 key or typing in a string and hitting ENTER. | |
| 2205 | |
| 2206 An item may also be just a string--that makes a nonselectable item in the | |
| 2207 dialog box and is ignored in the minibuffer. | |
| 2208 | |
| 2209 An item may also be nil -- that means to put all preceding items | |
| 2210 on the left of the dialog box and all following items on the right; ignored | |
| 2211 in the minibuffer." | |
| 2212 (if (should-use-dialog-box-p) | |
| 2213 (get-dialog-box-response | |
| 2214 position | |
| 2215 (cons question | |
| 2216 (mapcar #'(lambda (x) | |
| 2217 (cond | |
| 2218 ((null x) nil) | |
| 2219 ((stringp x) x) | |
| 2220 (t (cons (second x) (third x))))) | |
| 2221 answers))) | |
| 2222 (save-excursion | |
| 2223 (let* ((answers (remove-if-not #'consp answers)) | |
| 2224 (possible | |
| 2225 (gettext | |
|
5567
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5474
diff
changeset
|
2226 (labels ((car-to-string-if (x) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5474
diff
changeset
|
2227 (setq x (car x)) |
|
3bc58dc9d688
Replace #'flet by #'labels where appropriate, core code.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5474
diff
changeset
|
2228 (if (stringp x) x (char-to-string x)))) |
| 2730 | 2229 (concat (mapconcat #'car-to-string-if |
| 2230 (butlast answers) ", ") " or " | |
| 2231 (car-to-string-if (car (last answers))))))) | |
| 2232 (question (gettext question)) | |
| 2233 (p (format "%s(%s) " question possible))) | |
| 2234 (block nil | |
| 2235 (if (stringp (caar answers)) | |
| 2236 ;; based on yes-or-no-p. | |
| 2237 (while t | |
| 2238 (let* ((ans (downcase (read-string p nil t))) ;no history | |
| 2239 (res (member* ans answers :test #'equal :key #'car))) | |
| 2240 (if res (return (third (car res))) | |
| 2241 (ding nil 'yes-or-no-p) | |
| 2242 (discard-input) | |
| 2243 (message "Please answer %s." possible) | |
| 2244 (sleep-for 2)))) | |
| 2245 ;; based on y-or-n-p. | |
| 2246 (save-excursion | |
| 2247 (let* ((pre "") event) | |
| 2248 (while t | |
| 2249 (if (let ((cursor-in-echo-area t) | |
| 2250 (inhibit-quit t)) | |
| 2251 (message "%s%s(%s) " pre question possible) | |
| 2252 (setq event (next-command-event event)) | |
| 2253 (condition-case nil | |
| 2254 (prog1 | |
| 2255 (or quit-flag (eq 'keyboard-quit | |
| 2256 (key-binding event))) | |
| 2257 (setq quit-flag nil)) | |
| 2258 (wrong-type-argument t))) | |
| 2259 (progn | |
| 2260 (message "%s%s(%s) %s" pre question possible | |
| 2261 (single-key-description event)) | |
| 2262 (setq quit-flag nil) | |
| 2263 (signal 'quit '()))) | |
|
5745
f9e4d44504a4
Document #'events-to-keys some more, use it less.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5666
diff
changeset
|
2264 (let ((def (lookup-key query-replace-map (vector event)))) |
| 2730 | 2265 (cond |
| 2266 ((eq def 'recenter) | |
| 2267 (recenter)) | |
| 2268 ((or (eq def 'quit) (eq def 'exit-prefix)) | |
| 2269 (signal 'quit '())) | |
| 2270 ((button-release-event-p event) ; ignore them | |
| 2271 nil) | |
| 2272 (t | |
| 2273 (let ((res (member* (event-to-character event) answers | |
| 2274 :key #'car))) | |
| 2275 (if res (return (third (car res))) | |
| 2276 (message "%s%s(%s) %s" pre question possible | |
| 2277 (single-key-description event)) | |
| 2278 (ding nil 'y-or-n-p) | |
| 2279 (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
|
2280 (if (eql (length pre) 0) |
| 2730 | 2281 (setq pre (format "Please answer %s. " |
| 2282 ;; 17 parens! a record in | |
| 2283 ;; our lisp code. | |
| 2284 possible))))))))))))))))) | |
| 2285 | |
| 428 | 2286 ;;; minibuf.el ends here |