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