Commit | Line | Data |
---|---|---|
32bae13c SM |
1 | ;;; minibuffer.el --- Minibuffer completion functions |
2 | ||
3 | ;; Copyright (C) 2008 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation, either version 3 of the License, or | |
12 | ;; (at your option) any later version. | |
13 | ||
14 | ;; This program is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
20 | ;; along with this program. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | ;;; Commentary: | |
23 | ||
ba5ff07b SM |
24 | ;; Names starting with "minibuffer--" are for functions and variables that |
25 | ;; are meant to be for internal use only. | |
26 | ||
e2947429 SM |
27 | ;; TODO: |
28 | ;; - make the `hide-spaces' arg of all-completions obsolete. | |
29 | ||
21622c6d SM |
30 | ;; BUGS: |
31 | ;; - envvar completion for file names breaks completion-base-size. | |
32bae13c SM |
32 | |
33 | ;;; Code: | |
34 | ||
35 | (eval-when-compile (require 'cl)) | |
36 | ||
e2947429 SM |
37 | (defvar completion-all-completions-with-base-size nil |
38 | "If non-nil, `all-completions' may return the base-size in the last cdr. | |
39 | The base-size is the length of the prefix that is elided from each | |
40 | element in the returned list of completions. See `completion-base-size'.") | |
41 | ||
21622c6d SM |
42 | ;;; Completion table manipulation |
43 | ||
e2947429 SM |
44 | (defun completion--some (fun xs) |
45 | "Apply FUN to each element of XS in turn. | |
46 | Return the first non-nil returned value. | |
47 | Like CL's `some'." | |
48 | (let (res) | |
49 | (while (and (not res) xs) | |
50 | (setq res (funcall fun (pop xs)))) | |
51 | res)) | |
52 | ||
21622c6d | 53 | (defun apply-partially (fun &rest args) |
e2947429 SM |
54 | "Do a \"curried\" partial application of FUN to ARGS. |
55 | ARGS is a list of the first N arguments to pass to FUN. | |
56 | The result is a new function that takes the remaining arguments, | |
57 | and calls FUN." | |
21622c6d SM |
58 | (lexical-let ((fun fun) (args1 args)) |
59 | (lambda (&rest args2) (apply fun (append args1 args2))))) | |
60 | ||
61 | (defun complete-with-action (action table string pred) | |
62 | "Perform completion ACTION. | |
63 | STRING is the string to complete. | |
64 | TABLE is the completion table, which should not be a function. | |
65 | PRED is a completion predicate. | |
66 | ACTION can be one of nil, t or `lambda'." | |
67 | ;; (assert (not (functionp table))) | |
68 | (funcall | |
69 | (cond | |
70 | ((null action) 'try-completion) | |
71 | ((eq action t) 'all-completions) | |
72 | (t 'test-completion)) | |
73 | string table pred)) | |
74 | ||
75 | (defun completion-table-dynamic (fun) | |
76 | "Use function FUN as a dynamic completion table. | |
77 | FUN is called with one argument, the string for which completion is required, | |
78 | and it should return an alist containing all the intended possible | |
79 | completions. This alist may be a full list of possible completions so that FUN | |
80 | can ignore the value of its argument. If completion is performed in the | |
81 | minibuffer, FUN will be called in the buffer from which the minibuffer was | |
82 | entered. | |
83 | ||
84 | The result of the `dynamic-completion-table' form is a function | |
85 | that can be used as the ALIST argument to `try-completion' and | |
86 | `all-completion'. See Info node `(elisp)Programmed Completion'." | |
87 | (lexical-let ((fun fun)) | |
88 | (lambda (string pred action) | |
89 | (with-current-buffer (let ((win (minibuffer-selected-window))) | |
90 | (if (window-live-p win) (window-buffer win) | |
91 | (current-buffer))) | |
92 | (complete-with-action action (funcall fun string) string pred))))) | |
93 | ||
94 | (defmacro lazy-completion-table (var fun) | |
95 | "Initialize variable VAR as a lazy completion table. | |
96 | If the completion table VAR is used for the first time (e.g., by passing VAR | |
97 | as an argument to `try-completion'), the function FUN is called with no | |
98 | arguments. FUN must return the completion table that will be stored in VAR. | |
99 | If completion is requested in the minibuffer, FUN will be called in the buffer | |
100 | from which the minibuffer was entered. The return value of | |
101 | `lazy-completion-table' must be used to initialize the value of VAR. | |
102 | ||
103 | You should give VAR a non-nil `risky-local-variable' property." | |
69e018a7 | 104 | (declare (debug (symbolp lambda-expr))) |
21622c6d SM |
105 | (let ((str (make-symbol "string"))) |
106 | `(completion-table-dynamic | |
107 | (lambda (,str) | |
108 | (when (functionp ,var) | |
109 | (setq ,var (,fun))) | |
110 | ,var)))) | |
111 | ||
112 | (defun completion-table-with-context (prefix table string pred action) | |
113 | ;; TODO: add `suffix', and think about how we should support `pred'. | |
e2947429 SM |
114 | ;; Notice that `pred' is not a predicate when called from read-file-name |
115 | ;; or Info-read-node-name-2. | |
21622c6d SM |
116 | ;; (if pred (setq pred (lexical-let ((pred pred)) |
117 | ;; ;; FIXME: this doesn't work if `table' is an obarray. | |
118 | ;; (lambda (s) (funcall pred (concat prefix s)))))) | |
e2947429 SM |
119 | (let ((comp (complete-with-action action table string pred))) |
120 | (cond | |
121 | ;; In case of try-completion, add the prefix. | |
122 | ((stringp comp) (concat prefix comp)) | |
123 | ;; In case of non-empty all-completions, | |
124 | ;; add the prefix size to the base-size. | |
125 | ((consp comp) | |
126 | (let ((last (last comp))) | |
127 | (when completion-all-completions-with-base-size | |
128 | (setcdr last (+ (or (cdr last) 0) (length prefix)))) | |
129 | comp)) | |
130 | (t comp)))) | |
21622c6d SM |
131 | |
132 | (defun completion-table-with-terminator (terminator table string pred action) | |
133 | (let ((comp (complete-with-action action table string pred))) | |
88893215 SM |
134 | (cond |
135 | ((eq action nil) | |
136 | (if (eq comp t) | |
137 | (concat string terminator) | |
138 | (if (and (stringp comp) | |
139 | (eq (complete-with-action action table comp pred) t)) | |
140 | (concat comp terminator) | |
141 | comp)) | |
142 | comp) | |
143 | ;; completion-table-with-terminator is always used for | |
144 | ;; "sub-completions" so it's only called if the terminator is missing, | |
145 | ;; in which case `test-completion' should return nil. | |
146 | ((eq action 'lambda) nil)))) | |
21622c6d | 147 | |
e2947429 SM |
148 | (defun completion-table-in-turn (&rest tables) |
149 | "Create a completion table that tries each table in TABLES in turn." | |
150 | (lexical-let ((tables tables)) | |
21622c6d | 151 | (lambda (string pred action) |
e2947429 SM |
152 | (completion--some (lambda (table) |
153 | (complete-with-action action table string pred)) | |
154 | tables)))) | |
155 | ||
156 | (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) | |
157 | (define-obsolete-function-alias | |
158 | 'complete-in-turn 'completion-table-in-turn "23.1") | |
21622c6d SM |
159 | |
160 | ;;; Minibuffer completion | |
161 | ||
ba5ff07b SM |
162 | (defgroup minibuffer nil |
163 | "Controlling the behavior of the minibuffer." | |
164 | :link '(custom-manual "(emacs)Minibuffer") | |
165 | :group 'environment) | |
166 | ||
32bae13c SM |
167 | (defun minibuffer-message (message &rest args) |
168 | "Temporarily display MESSAGE at the end of the minibuffer. | |
169 | The text is displayed for `minibuffer-message-timeout' seconds, | |
170 | or until the next input event arrives, whichever comes first. | |
171 | Enclose MESSAGE in [...] if this is not yet the case. | |
172 | If ARGS are provided, then pass MESSAGE through `format'." | |
173 | ;; Clear out any old echo-area message to make way for our new thing. | |
174 | (message nil) | |
ba5ff07b | 175 | (unless (and (null args) (string-match "\\[.+\\]" message)) |
32bae13c SM |
176 | (setq message (concat " [" message "]"))) |
177 | (when args (setq message (apply 'format message args))) | |
178 | (let ((ol (make-overlay (point-max) (point-max) nil t t))) | |
179 | (unwind-protect | |
180 | (progn | |
bf87d5fc SM |
181 | (unless (zerop (length message)) |
182 | ;; The current C cursor code doesn't know to use the overlay's | |
183 | ;; marker's stickiness to figure out whether to place the cursor | |
184 | ;; before or after the string, so let's spoon-feed it the pos. | |
185 | (put-text-property 0 1 'cursor t message)) | |
32bae13c SM |
186 | (overlay-put ol 'after-string message) |
187 | (sit-for (or minibuffer-message-timeout 1000000))) | |
188 | (delete-overlay ol)))) | |
189 | ||
190 | (defun minibuffer-completion-contents () | |
191 | "Return the user input in a minibuffer before point as a string. | |
192 | That is what completion commands operate on." | |
193 | (buffer-substring (field-beginning) (point))) | |
194 | ||
195 | (defun delete-minibuffer-contents () | |
196 | "Delete all user input in a minibuffer. | |
197 | If the current buffer is not a minibuffer, erase its entire contents." | |
198 | (delete-field)) | |
199 | ||
ba5ff07b SM |
200 | (defcustom completion-auto-help t |
201 | "Non-nil means automatically provide help for invalid completion input. | |
202 | If the value is t the *Completion* buffer is displayed whenever completion | |
203 | is requested but cannot be done. | |
204 | If the value is `lazy', the *Completions* buffer is only displayed after | |
205 | the second failed attempt to complete." | |
e1bb0fe5 | 206 | :type '(choice (const nil) (const t) (const lazy)) |
ba5ff07b SM |
207 | :group 'minibuffer) |
208 | ||
e2947429 SM |
209 | (defvar completion-styles-alist |
210 | '((basic try-completion all-completions) | |
211 | ;; (partial-completion | |
212 | ;; completion-pcm--try-completion completion-pcm--all-completions) | |
213 | ) | |
214 | "List of available completion styles. | |
215 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS) | |
216 | where NAME is the name that should be used in `completion-styles' | |
217 | TRY-COMPLETION is the function that does the completion, and | |
218 | ALL-COMPLETIONS is the function that lists the completions.") | |
219 | ||
220 | (defcustom completion-styles '(basic) | |
221 | "List of completion styles to use." | |
222 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) | |
223 | completion-styles-alist))) | |
224 | :group 'minibuffer | |
225 | :version "23.1") | |
226 | ||
227 | (defun minibuffer-try-completion (string table pred) | |
228 | (if (and (symbolp table) (get table 'no-completion-styles)) | |
229 | (try-completion string table pred) | |
230 | (completion--some (lambda (style) | |
2ed430f4 | 231 | (funcall (nth 1 (assq style completion-styles-alist)) |
e2947429 SM |
232 | string table pred)) |
233 | completion-styles))) | |
234 | ||
235 | (defun minibuffer-all-completions (string table pred &optional hide-spaces) | |
236 | (let ((completion-all-completions-with-base-size t)) | |
237 | (if (and (symbolp table) (get table 'no-completion-styles)) | |
238 | (all-completions string table pred hide-spaces) | |
239 | (completion--some (lambda (style) | |
2ed430f4 | 240 | (funcall (nth 2 (assq style completion-styles-alist)) |
e2947429 SM |
241 | string table pred hide-spaces)) |
242 | completion-styles)))) | |
243 | ||
ba5ff07b SM |
244 | (defun minibuffer--bitset (modified completions exact) |
245 | (logior (if modified 4 0) | |
246 | (if completions 2 0) | |
247 | (if exact 1 0))) | |
248 | ||
249 | (defun minibuffer--do-completion (&optional try-completion-function) | |
32bae13c | 250 | "Do the completion and return a summary of what happened. |
ba5ff07b SM |
251 | M = completion was performed, the text was Modified. |
252 | C = there were available Completions. | |
253 | E = after completion we now have an Exact match. | |
254 | ||
255 | MCE | |
256 | 000 0 no possible completion | |
257 | 001 1 was already an exact and unique completion | |
258 | 010 2 no completion happened | |
259 | 011 3 was already an exact completion | |
260 | 100 4 ??? impossible | |
261 | 101 5 ??? impossible | |
262 | 110 6 some completion happened | |
263 | 111 7 completed to an exact completion" | |
264 | (let* ((beg (field-beginning)) | |
265 | (string (buffer-substring beg (point))) | |
e2947429 SM |
266 | (completion (funcall (or try-completion-function |
267 | 'minibuffer-try-completion) | |
ba5ff07b SM |
268 | string |
269 | minibuffer-completion-table | |
270 | minibuffer-completion-predicate))) | |
32bae13c SM |
271 | (cond |
272 | ((null completion) | |
ba5ff07b SM |
273 | (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil)) |
274 | ((eq t completion) (minibuffer--bitset nil nil t)) ;Exact and unique match. | |
32bae13c SM |
275 | (t |
276 | ;; `completed' should be t if some completion was done, which doesn't | |
277 | ;; include simply changing the case of the entered string. However, | |
278 | ;; for appearance, the string is rewritten if the case changes. | |
279 | (let ((completed (not (eq t (compare-strings completion nil nil | |
280 | string nil nil t)))) | |
281 | (unchanged (eq t (compare-strings completion nil nil | |
282 | string nil nil nil)))) | |
283 | (unless unchanged | |
ba5ff07b SM |
284 | ;; Merge a trailing / in completion with a / after point. |
285 | ;; We used to only do it for word completion, but it seems to make | |
286 | ;; sense for all completions. | |
287 | (if (and (eq ?/ (aref completion (1- (length completion)))) | |
288 | (< (point) (field-end)) | |
289 | (eq ?/ (char-after))) | |
290 | (setq completion (substring completion 0 -1))) | |
291 | ||
292 | ;; Insert in minibuffer the chars we got. | |
293 | (let ((end (point))) | |
32bae13c SM |
294 | (insert completion) |
295 | (delete-region beg end))) | |
ba5ff07b | 296 | |
32bae13c SM |
297 | (if (not (or unchanged completed)) |
298 | ;; The case of the string changed, but that's all. We're not sure | |
299 | ;; whether this is a unique completion or not, so try again using | |
300 | ;; the real case (this shouldn't recurse again, because the next | |
301 | ;; time try-completion will return either t or the exact string). | |
d2925a49 | 302 | (minibuffer--do-completion try-completion-function) |
32bae13c SM |
303 | |
304 | ;; It did find a match. Do we match some possibility exactly now? | |
305 | (let ((exact (test-completion (field-string) | |
306 | minibuffer-completion-table | |
307 | minibuffer-completion-predicate))) | |
ba5ff07b SM |
308 | (unless completed |
309 | ;; Show the completion table, if requested. | |
310 | (cond | |
311 | ((not exact) | |
312 | (if (case completion-auto-help | |
313 | (lazy (eq this-command last-command)) | |
314 | (t completion-auto-help)) | |
315 | (minibuffer-completion-help) | |
316 | (minibuffer-message "Next char not unique"))) | |
317 | ;; If the last exact completion and this one were the same, | |
318 | ;; it means we've already given a "Complete but not unique" | |
319 | ;; message and the user's hit TAB again, so now we give him help. | |
320 | ((eq this-command last-command) | |
321 | (if completion-auto-help (minibuffer-completion-help))))) | |
322 | ||
323 | (minibuffer--bitset completed t exact)))))))) | |
32bae13c SM |
324 | |
325 | (defun minibuffer-complete () | |
326 | "Complete the minibuffer contents as far as possible. | |
327 | Return nil if there is no valid completion, else t. | |
328 | If no characters can be completed, display a list of possible completions. | |
329 | If you repeat this command after it displayed such a list, | |
330 | scroll the window of possible completions." | |
331 | (interactive) | |
332 | ;; If the previous command was not this, | |
333 | ;; mark the completion buffer obsolete. | |
334 | (unless (eq this-command last-command) | |
335 | (setq minibuffer-scroll-window nil)) | |
336 | ||
337 | (let ((window minibuffer-scroll-window)) | |
338 | ;; If there's a fresh completion window with a live buffer, | |
339 | ;; and this command is repeated, scroll that window. | |
340 | (if (window-live-p window) | |
341 | (with-current-buffer (window-buffer window) | |
342 | (if (pos-visible-in-window-p (point-max) window) | |
343 | ;; If end is in view, scroll up to the beginning. | |
344 | (set-window-start window (point-min) nil) | |
345 | ;; Else scroll down one screen. | |
346 | (scroll-other-window)) | |
347 | nil) | |
348 | ||
ba5ff07b SM |
349 | (case (minibuffer--do-completion) |
350 | (0 nil) | |
351 | (1 (goto-char (field-end)) | |
352 | (minibuffer-message "Sole completion") | |
353 | t) | |
354 | (3 (goto-char (field-end)) | |
355 | (minibuffer-message "Complete, but not unique") | |
356 | t) | |
357 | (t t))))) | |
32bae13c SM |
358 | |
359 | (defun minibuffer-complete-and-exit () | |
360 | "If the minibuffer contents is a valid completion then exit. | |
361 | Otherwise try to complete it. If completion leads to a valid completion, | |
362 | a repetition of this command will exit." | |
363 | (interactive) | |
364 | (cond | |
365 | ;; Allow user to specify null string | |
366 | ((= (field-beginning) (field-end)) (exit-minibuffer)) | |
367 | ((test-completion (field-string) | |
368 | minibuffer-completion-table | |
369 | minibuffer-completion-predicate) | |
370 | (when completion-ignore-case | |
371 | ;; Fixup case of the field, if necessary. | |
372 | (let* ((string (field-string)) | |
e2947429 SM |
373 | (compl (minibuffer-try-completion |
374 | string | |
375 | minibuffer-completion-table | |
376 | minibuffer-completion-predicate))) | |
32bae13c SM |
377 | (when (and (stringp compl) |
378 | ;; If it weren't for this piece of paranoia, I'd replace | |
379 | ;; the whole thing with a call to complete-do-completion. | |
380 | (= (length string) (length compl))) | |
381 | (let ((beg (field-beginning)) | |
382 | (end (field-end))) | |
383 | (goto-char end) | |
384 | (insert compl) | |
385 | (delete-region beg end))))) | |
386 | (exit-minibuffer)) | |
387 | ||
388 | ((eq minibuffer-completion-confirm 'confirm-only) | |
389 | ;; The user is permitted to exit with an input that's rejected | |
390 | ;; by test-completion, but at the condition to confirm her choice. | |
391 | (if (eq last-command this-command) | |
392 | (exit-minibuffer) | |
393 | (minibuffer-message "Confirm") | |
394 | nil)) | |
395 | ||
396 | (t | |
397 | ;; Call do-completion, but ignore errors. | |
ba5ff07b SM |
398 | (case (condition-case nil |
399 | (minibuffer--do-completion) | |
400 | (error 1)) | |
401 | ((1 3) (exit-minibuffer)) | |
402 | (7 (if (not minibuffer-completion-confirm) | |
403 | (exit-minibuffer) | |
404 | (minibuffer-message "Confirm") | |
405 | nil)) | |
406 | (t nil))))) | |
407 | ||
408 | (defun minibuffer-try-word-completion (string table predicate) | |
e2947429 | 409 | (let ((completion (minibuffer-try-completion string table predicate))) |
ba5ff07b SM |
410 | (if (not (stringp completion)) |
411 | completion | |
32bae13c | 412 | |
32bae13c SM |
413 | ;; Completing a single word is actually more difficult than completing |
414 | ;; as much as possible, because we first have to find the "current | |
415 | ;; position" in `completion' in order to find the end of the word | |
416 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
417 | ;; which makes it trivial to find the position, but with fancier | |
418 | ;; completion (plus env-var expansion, ...) `completion' might not | |
419 | ;; look anything like `string' at all. | |
e1bb0fe5 | 420 | |
32bae13c SM |
421 | (when minibuffer-completing-file-name |
422 | ;; In order to minimize the problem mentioned above, let's try to | |
423 | ;; reduce the different between `string' and `completion' by | |
424 | ;; mirroring some of the work done in read-file-name-internal. | |
425 | (let ((substituted (condition-case nil | |
426 | ;; Might fail when completing an env-var. | |
427 | (substitute-in-file-name string) | |
428 | (error string)))) | |
429 | (unless (eq string substituted) | |
ba5ff07b | 430 | (setq string substituted)))) |
32bae13c SM |
431 | |
432 | ;; Make buffer (before point) contain the longest match | |
433 | ;; of `string's tail and `completion's head. | |
434 | (let* ((startpos (max 0 (- (length string) (length completion)))) | |
435 | (length (- (length string) startpos))) | |
436 | (while (and (> length 0) | |
437 | (not (eq t (compare-strings string startpos nil | |
438 | completion 0 length | |
439 | completion-ignore-case)))) | |
440 | (setq startpos (1+ startpos)) | |
441 | (setq length (1- length))) | |
442 | ||
ba5ff07b | 443 | (setq string (substring string startpos))) |
32bae13c SM |
444 | |
445 | ;; Now `string' is a prefix of `completion'. | |
446 | ||
447 | ;; If completion finds next char not unique, | |
448 | ;; consider adding a space or a hyphen. | |
449 | (when (= (length string) (length completion)) | |
450 | (let ((exts '(" " "-")) | |
451 | tem) | |
452 | (while (and exts (not (stringp tem))) | |
e2947429 SM |
453 | (setq tem (minibuffer-try-completion (concat string (pop exts)) |
454 | table predicate))) | |
32bae13c SM |
455 | (if (stringp tem) (setq completion tem)))) |
456 | ||
ba5ff07b SM |
457 | ;; Otherwise cut after the first word. |
458 | (if (string-match "\\W" completion (length string)) | |
459 | ;; First find first word-break in the stuff found by completion. | |
460 | ;; i gets index in string of where to stop completing. | |
461 | (substring completion 0 (match-end 0)) | |
462 | completion)))) | |
463 | ||
464 | ||
465 | (defun minibuffer-complete-word () | |
466 | "Complete the minibuffer contents at most a single word. | |
467 | After one word is completed as much as possible, a space or hyphen | |
468 | is added, provided that matches some possible completion. | |
469 | Return nil if there is no valid completion, else t." | |
470 | (interactive) | |
471 | (case (minibuffer--do-completion 'minibuffer-try-word-completion) | |
472 | (0 nil) | |
473 | (1 (goto-char (field-end)) | |
474 | (minibuffer-message "Sole completion") | |
475 | t) | |
476 | (3 (goto-char (field-end)) | |
477 | (minibuffer-message "Complete, but not unique") | |
478 | t) | |
479 | (t t))) | |
480 | ||
481 | (defun minibuffer--insert-strings (strings) | |
32bae13c SM |
482 | "Insert a list of STRINGS into the current buffer. |
483 | Uses columns to keep the listing readable but compact. | |
484 | It also eliminates runs of equal strings." | |
485 | (when (consp strings) | |
486 | (let* ((length (apply 'max | |
487 | (mapcar (lambda (s) | |
488 | (if (consp s) | |
489 | (+ (length (car s)) (length (cadr s))) | |
490 | (length s))) | |
491 | strings))) | |
492 | (window (get-buffer-window (current-buffer) 0)) | |
493 | (wwidth (if window (1- (window-width window)) 79)) | |
494 | (columns (min | |
495 | ;; At least 2 columns; at least 2 spaces between columns. | |
496 | (max 2 (/ wwidth (+ 2 length))) | |
497 | ;; Don't allocate more columns than we can fill. | |
498 | ;; Windows can't show less than 3 lines anyway. | |
499 | (max 1 (/ (length strings) 2)))) | |
500 | (colwidth (/ wwidth columns)) | |
501 | (column 0) | |
502 | (laststring nil)) | |
503 | ;; The insertion should be "sensible" no matter what choices were made | |
504 | ;; for the parameters above. | |
505 | (dolist (str strings) | |
506 | (unless (equal laststring str) ; Remove (consecutive) duplicates. | |
507 | (setq laststring str) | |
508 | (unless (bolp) | |
509 | (insert " \t") | |
510 | (setq column (+ column colwidth)) | |
511 | ;; Leave the space unpropertized so that in the case we're | |
512 | ;; already past the goal column, there is still | |
513 | ;; a space displayed. | |
514 | (set-text-properties (- (point) 1) (point) | |
515 | ;; We can't just set tab-width, because | |
516 | ;; completion-setup-function will kill all | |
517 | ;; local variables :-( | |
518 | `(display (space :align-to ,column)))) | |
519 | (when (< wwidth (+ (max colwidth | |
520 | (if (consp str) | |
521 | (+ (length (car str)) (length (cadr str))) | |
522 | (length str))) | |
523 | column)) | |
524 | (delete-char -2) (insert "\n") (setq column 0)) | |
525 | (if (not (consp str)) | |
526 | (put-text-property (point) (progn (insert str) (point)) | |
527 | 'mouse-face 'highlight) | |
528 | (put-text-property (point) (progn (insert (car str)) (point)) | |
529 | 'mouse-face 'highlight) | |
530 | (put-text-property (point) (progn (insert (cadr str)) (point)) | |
531 | 'mouse-face nil))))))) | |
532 | ||
533 | (defvar completion-common-substring) | |
534 | ||
21622c6d SM |
535 | (defvar completion-setup-hook nil |
536 | "Normal hook run at the end of setting up a completion list buffer. | |
537 | When this hook is run, the current buffer is the one in which the | |
538 | command to display the completion list buffer was run. | |
539 | The completion list buffer is available as the value of `standard-output'. | |
540 | The common prefix substring for completion may be available as the | |
541 | value of `completion-common-substring'. See also `display-completion-list'.") | |
542 | ||
32bae13c SM |
543 | (defun display-completion-list (completions &optional common-substring) |
544 | "Display the list of completions, COMPLETIONS, using `standard-output'. | |
545 | Each element may be just a symbol or string | |
546 | or may be a list of two strings to be printed as if concatenated. | |
547 | If it is a list of two strings, the first is the actual completion | |
548 | alternative, the second serves as annotation. | |
549 | `standard-output' must be a buffer. | |
550 | The actual completion alternatives, as inserted, are given `mouse-face' | |
551 | properties of `highlight'. | |
552 | At the end, this runs the normal hook `completion-setup-hook'. | |
553 | It can find the completion buffer in `standard-output'. | |
554 | The optional second arg COMMON-SUBSTRING is a string. | |
555 | It is used to put faces, `completions-first-difference' and | |
556 | `completions-common-part' on the completion buffer. The | |
557 | `completions-common-part' face is put on the common substring | |
558 | specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil | |
559 | and the current buffer is not the minibuffer, the faces are not put. | |
560 | Internally, COMMON-SUBSTRING is bound to `completion-common-substring' | |
561 | during running `completion-setup-hook'." | |
562 | (if (not (bufferp standard-output)) | |
563 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
564 | (with-temp-buffer | |
565 | (let ((standard-output (current-buffer)) | |
566 | (completion-setup-hook nil)) | |
567 | (display-completion-list completions)) | |
568 | (princ (buffer-string))) | |
569 | ||
570 | (with-current-buffer standard-output | |
571 | (goto-char (point-max)) | |
572 | (if (null completions) | |
573 | (insert "There are no possible completions of what you have typed.") | |
e1bb0fe5 | 574 | |
32bae13c | 575 | (insert "Possible completions are:\n") |
e2947429 SM |
576 | (let ((last (last completions))) |
577 | ;; Get the base-size from the tail of the list. | |
578 | (set (make-local-variable 'completion-base-size) (or (cdr last) 0)) | |
579 | (setcdr last nil)) ;Make completions a properly nil-terminated list. | |
ba5ff07b | 580 | (minibuffer--insert-strings completions)))) |
e2947429 | 581 | |
32bae13c SM |
582 | (let ((completion-common-substring common-substring)) |
583 | (run-hooks 'completion-setup-hook)) | |
584 | nil) | |
585 | ||
586 | (defun minibuffer-completion-help () | |
587 | "Display a list of possible completions of the current minibuffer contents." | |
588 | (interactive) | |
589 | (message "Making completion list...") | |
590 | (let* ((string (field-string)) | |
e2947429 | 591 | (completions (minibuffer-all-completions |
32bae13c SM |
592 | string |
593 | minibuffer-completion-table | |
594 | minibuffer-completion-predicate | |
595 | t))) | |
596 | (message nil) | |
597 | (if (and completions | |
e2947429 SM |
598 | (or (consp (cdr completions)) |
599 | (not (equal (car completions) string)))) | |
32bae13c | 600 | (with-output-to-temp-buffer "*Completions*" |
e2947429 SM |
601 | (let* ((last (last completions)) |
602 | (base-size (cdr last))) | |
603 | ;; Remove the base-size tail because `sort' requires a properly | |
604 | ;; nil-terminated list. | |
605 | (when last (setcdr last nil)) | |
606 | (display-completion-list (nconc (sort completions 'string-lessp) | |
607 | base-size)))) | |
32bae13c SM |
608 | |
609 | ;; If there are no completions, or if the current input is already the | |
610 | ;; only possible completion, then hide (previous&stale) completions. | |
611 | (let ((window (and (get-buffer "*Completions*") | |
612 | (get-buffer-window "*Completions*" 0)))) | |
613 | (when (and (window-live-p window) (window-dedicated-p window)) | |
614 | (condition-case () | |
615 | (delete-window window) | |
616 | (error (iconify-frame (window-frame window)))))) | |
617 | (ding) | |
618 | (minibuffer-message | |
619 | (if completions "Sole completion" "No completions"))) | |
620 | nil)) | |
621 | ||
622 | (defun exit-minibuffer () | |
623 | "Terminate this minibuffer argument." | |
624 | (interactive) | |
625 | ;; If the command that uses this has made modifications in the minibuffer, | |
626 | ;; we don't want them to cause deactivation of the mark in the original | |
627 | ;; buffer. | |
628 | ;; A better solution would be to make deactivate-mark buffer-local | |
629 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
630 | ;; this should do the trick in most cases. | |
ba5ff07b | 631 | (setq deactivate-mark nil) |
32bae13c SM |
632 | (throw 'exit nil)) |
633 | ||
634 | (defun self-insert-and-exit () | |
635 | "Terminate minibuffer input." | |
636 | (interactive) | |
637 | (if (characterp last-command-char) | |
638 | (call-interactively 'self-insert-command) | |
639 | (ding)) | |
640 | (exit-minibuffer)) | |
641 | ||
34b67b0f SM |
642 | (defun minibuffer--double-dollars (str) |
643 | (replace-regexp-in-string "\\$" "$$" str)) | |
644 | ||
21622c6d SM |
645 | (defun completion--make-envvar-table () |
646 | (mapcar (lambda (enventry) | |
647 | (substring enventry 0 (string-match "=" enventry))) | |
648 | process-environment)) | |
649 | ||
650 | (defun completion--embedded-envvar-table (string pred action) | |
651 | (when (string-match (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" | |
652 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'") | |
653 | string) | |
654 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) | |
017c22fe | 655 | (table (completion--make-envvar-table)) |
21622c6d SM |
656 | (prefix (substring string 0 beg))) |
657 | (if (eq (aref string (1- beg)) ?{) | |
658 | (setq table (apply-partially 'completion-table-with-terminator | |
659 | "}" table))) | |
660 | (completion-table-with-context prefix table | |
661 | (substring string beg) | |
662 | pred action)))) | |
017c22fe | 663 | |
21622c6d | 664 | (defun completion--file-name-table (string dir action) |
34b67b0f SM |
665 | "Internal subroutine for read-file-name. Do not call this." |
666 | (setq dir (expand-file-name dir)) | |
667 | (if (and (zerop (length string)) (eq 'lambda action)) | |
668 | nil ; FIXME: why? | |
21622c6d SM |
669 | (let* ((str (condition-case nil |
670 | (substitute-in-file-name string) | |
671 | (error string))) | |
34b67b0f SM |
672 | (name (file-name-nondirectory str)) |
673 | (specdir (file-name-directory str)) | |
674 | (realdir (if specdir (expand-file-name specdir dir) | |
675 | (file-name-as-directory dir)))) | |
017c22fe | 676 | |
34b67b0f SM |
677 | (cond |
678 | ((null action) | |
679 | (let ((comp (file-name-completion name realdir | |
680 | read-file-name-predicate))) | |
681 | (if (stringp comp) | |
682 | ;; Requote the $s before returning the completion. | |
683 | (minibuffer--double-dollars (concat specdir comp)) | |
684 | ;; Requote the $s before checking for changes. | |
685 | (setq str (minibuffer--double-dollars str)) | |
686 | (if (string-equal string str) | |
687 | comp | |
688 | ;; If there's no real completion, but substitute-in-file-name | |
689 | ;; changed the string, then return the new string. | |
690 | str)))) | |
017c22fe | 691 | |
34b67b0f | 692 | ((eq action t) |
e2947429 SM |
693 | (let ((all (file-name-all-completions name realdir)) |
694 | ;; Actually, this is not always right in the presence of | |
695 | ;; envvars, but there's not much we can do, I think. | |
696 | (base-size (length (file-name-directory string)))) | |
697 | ||
698 | ;; Check the predicate, if necessary. | |
699 | (unless (memq read-file-name-predicate '(nil file-exists-p)) | |
34b67b0f SM |
700 | (let ((comp ()) |
701 | (pred | |
702 | (if (eq read-file-name-predicate 'file-directory-p) | |
703 | ;; Brute-force speed up for directory checking: | |
704 | ;; Discard strings which don't end in a slash. | |
705 | (lambda (s) | |
706 | (let ((len (length s))) | |
707 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | |
708 | ;; Must do it the hard (and slow) way. | |
709 | read-file-name-predicate))) | |
710 | (let ((default-directory realdir)) | |
711 | (dolist (tem all) | |
712 | (if (funcall pred tem) (push tem comp)))) | |
e2947429 SM |
713 | (setq all (nreverse comp)))) |
714 | ||
88893215 SM |
715 | (if (and completion-all-completions-with-base-size (consp all)) |
716 | ;; Add base-size, but only if the list is non-empty. | |
717 | (nconc all base-size)) | |
718 | ||
719 | all)) | |
34b67b0f SM |
720 | |
721 | (t | |
722 | ;; Only other case actually used is ACTION = lambda. | |
723 | (let ((default-directory dir)) | |
724 | (funcall (or read-file-name-predicate 'file-exists-p) str))))))) | |
725 | ||
21622c6d | 726 | (defalias 'read-file-name-internal |
017c22fe | 727 | (completion-table-in-turn 'completion--embedded-envvar-table |
88893215 | 728 | 'completion--file-name-table) |
21622c6d | 729 | "Internal subroutine for `read-file-name'. Do not call this.") |
34b67b0f | 730 | |
32bae13c SM |
731 | (provide 'minibuffer) |
732 | ;;; minibuffer.el ends here |