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 | ||
3911966b SM |
27 | ;;; Todo: |
28 | ||
19c04f39 | 29 | ;; - Make read-file-name-predicate obsolete. |
d28cfdc2 | 30 | ;; - New command minibuffer-force-complete that chooses one of all-completions. |
3911966b SM |
31 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
32 | ;; - A feature like completing-help.el. | |
33 | ;; - Make the `hide-spaces' arg of all-completions obsolete? | |
32bae13c SM |
34 | |
35 | ;;; Code: | |
36 | ||
37 | (eval-when-compile (require 'cl)) | |
38 | ||
e2947429 SM |
39 | (defvar completion-all-completions-with-base-size nil |
40 | "If non-nil, `all-completions' may return the base-size in the last cdr. | |
41 | The base-size is the length of the prefix that is elided from each | |
42 | element in the returned list of completions. See `completion-base-size'.") | |
43 | ||
21622c6d SM |
44 | ;;; Completion table manipulation |
45 | ||
e2947429 SM |
46 | (defun completion--some (fun xs) |
47 | "Apply FUN to each element of XS in turn. | |
48 | Return the first non-nil returned value. | |
49 | Like CL's `some'." | |
50 | (let (res) | |
51 | (while (and (not res) xs) | |
52 | (setq res (funcall fun (pop xs)))) | |
53 | res)) | |
54 | ||
21622c6d | 55 | (defun apply-partially (fun &rest args) |
e2947429 SM |
56 | "Do a \"curried\" partial application of FUN to ARGS. |
57 | ARGS is a list of the first N arguments to pass to FUN. | |
58 | The result is a new function that takes the remaining arguments, | |
59 | and calls FUN." | |
21622c6d SM |
60 | (lexical-let ((fun fun) (args1 args)) |
61 | (lambda (&rest args2) (apply fun (append args1 args2))))) | |
62 | ||
63 | (defun complete-with-action (action table string pred) | |
64 | "Perform completion ACTION. | |
65 | STRING is the string to complete. | |
66 | TABLE is the completion table, which should not be a function. | |
67 | PRED is a completion predicate. | |
68 | ACTION can be one of nil, t or `lambda'." | |
69 | ;; (assert (not (functionp table))) | |
70 | (funcall | |
71 | (cond | |
72 | ((null action) 'try-completion) | |
73 | ((eq action t) 'all-completions) | |
74 | (t 'test-completion)) | |
75 | string table pred)) | |
76 | ||
77 | (defun completion-table-dynamic (fun) | |
78 | "Use function FUN as a dynamic completion table. | |
79 | FUN is called with one argument, the string for which completion is required, | |
b95c7600 JB |
80 | and it should return an alist containing all the intended possible completions. |
81 | This alist may be a full list of possible completions so that FUN can ignore | |
82 | the value of its argument. If completion is performed in the minibuffer, | |
83 | FUN will be called in the buffer from which the minibuffer was entered. | |
21622c6d SM |
84 | |
85 | The result of the `dynamic-completion-table' form is a function | |
86 | that can be used as the ALIST argument to `try-completion' and | |
b95c7600 | 87 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
21622c6d SM |
88 | (lexical-let ((fun fun)) |
89 | (lambda (string pred action) | |
90 | (with-current-buffer (let ((win (minibuffer-selected-window))) | |
91 | (if (window-live-p win) (window-buffer win) | |
92 | (current-buffer))) | |
93 | (complete-with-action action (funcall fun string) string pred))))) | |
94 | ||
95 | (defmacro lazy-completion-table (var fun) | |
96 | "Initialize variable VAR as a lazy completion table. | |
97 | If the completion table VAR is used for the first time (e.g., by passing VAR | |
98 | as an argument to `try-completion'), the function FUN is called with no | |
99 | arguments. FUN must return the completion table that will be stored in VAR. | |
100 | If completion is requested in the minibuffer, FUN will be called in the buffer | |
101 | from which the minibuffer was entered. The return value of | |
102 | `lazy-completion-table' must be used to initialize the value of VAR. | |
103 | ||
104 | You should give VAR a non-nil `risky-local-variable' property." | |
69e018a7 | 105 | (declare (debug (symbolp lambda-expr))) |
21622c6d SM |
106 | (let ((str (make-symbol "string"))) |
107 | `(completion-table-dynamic | |
108 | (lambda (,str) | |
109 | (when (functionp ,var) | |
110 | (setq ,var (,fun))) | |
111 | ,var)))) | |
112 | ||
113 | (defun completion-table-with-context (prefix table string pred action) | |
25c0d999 | 114 | ;; TODO: add `suffix' maybe? |
e2947429 SM |
115 | ;; Notice that `pred' is not a predicate when called from read-file-name |
116 | ;; or Info-read-node-name-2. | |
25c0d999 SM |
117 | (if (functionp pred) |
118 | (setq pred (lexical-let ((pred pred)) | |
119 | ;; FIXME: this doesn't work if `table' is an obarray. | |
120 | (lambda (s) (funcall pred (concat prefix s)))))) | |
e2947429 SM |
121 | (let ((comp (complete-with-action action table string pred))) |
122 | (cond | |
123 | ;; In case of try-completion, add the prefix. | |
124 | ((stringp comp) (concat prefix comp)) | |
125 | ;; In case of non-empty all-completions, | |
126 | ;; add the prefix size to the base-size. | |
127 | ((consp comp) | |
128 | (let ((last (last comp))) | |
129 | (when completion-all-completions-with-base-size | |
130 | (setcdr last (+ (or (cdr last) 0) (length prefix)))) | |
131 | comp)) | |
132 | (t comp)))) | |
21622c6d SM |
133 | |
134 | (defun completion-table-with-terminator (terminator table string pred action) | |
25c0d999 SM |
135 | (cond |
136 | ((eq action nil) | |
137 | (let ((comp (try-completion string table pred))) | |
88893215 SM |
138 | (if (eq comp t) |
139 | (concat string terminator) | |
140 | (if (and (stringp comp) | |
25c0d999 | 141 | (eq (try-completion comp table pred) t)) |
88893215 | 142 | (concat comp terminator) |
25c0d999 SM |
143 | comp)))) |
144 | ((eq action t) (all-completions string table pred)) | |
145 | ;; completion-table-with-terminator is always used for | |
146 | ;; "sub-completions" so it's only called if the terminator is missing, | |
147 | ;; in which case `test-completion' should return nil. | |
148 | ((eq action 'lambda) nil))) | |
149 | ||
150 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) | |
151 | "Make a completion table equivalent to TABLE but filtered through PRED1. | |
152 | PRED1 is a function of one argument which returns non-nil iff the | |
153 | argument is an element of TABLE which should be considered for completion. | |
154 | STRING, PRED2, and ACTION are the usual arguments to completion tables, | |
155 | as described in `try-completion', `all-completions', and `test-completion'. | |
3911966b SM |
156 | If STRICT is t, the predicate always applies; if nil it only applies if |
157 | it does not reduce the set of possible completions to nothing. | |
25c0d999 SM |
158 | Note: TABLE needs to be a proper completion table which obeys predicates." |
159 | (cond | |
160 | ((and (not strict) (eq action 'lambda)) | |
161 | ;; Ignore pred1 since it doesn't really have to apply anyway. | |
af48580e | 162 | (test-completion string table pred2)) |
25c0d999 SM |
163 | (t |
164 | (or (complete-with-action action table string | |
165 | (if (null pred2) pred1 | |
166 | (lexical-let ((pred1 pred2) (pred2 pred2)) | |
167 | (lambda (x) | |
168 | ;; Call `pred1' first, so that `pred2' | |
169 | ;; really can't tell that `x' is in table. | |
170 | (if (funcall pred1 x) (funcall pred2 x)))))) | |
171 | ;; If completion failed and we're not applying pred1 strictly, try | |
172 | ;; again without pred1. | |
173 | (and (not strict) | |
174 | (complete-with-action action table string pred2)))))) | |
21622c6d | 175 | |
e2947429 SM |
176 | (defun completion-table-in-turn (&rest tables) |
177 | "Create a completion table that tries each table in TABLES in turn." | |
178 | (lexical-let ((tables tables)) | |
21622c6d | 179 | (lambda (string pred action) |
e2947429 SM |
180 | (completion--some (lambda (table) |
181 | (complete-with-action action table string pred)) | |
182 | tables)))) | |
183 | ||
25c0d999 SM |
184 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
185 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) | |
e2947429 SM |
186 | (define-obsolete-function-alias |
187 | 'complete-in-turn 'completion-table-in-turn "23.1") | |
25c0d999 SM |
188 | (define-obsolete-function-alias |
189 | 'dynamic-completion-table 'completion-table-dynamic "23.1") | |
21622c6d SM |
190 | |
191 | ;;; Minibuffer completion | |
192 | ||
ba5ff07b SM |
193 | (defgroup minibuffer nil |
194 | "Controlling the behavior of the minibuffer." | |
195 | :link '(custom-manual "(emacs)Minibuffer") | |
196 | :group 'environment) | |
197 | ||
32bae13c SM |
198 | (defun minibuffer-message (message &rest args) |
199 | "Temporarily display MESSAGE at the end of the minibuffer. | |
200 | The text is displayed for `minibuffer-message-timeout' seconds, | |
201 | or until the next input event arrives, whichever comes first. | |
202 | Enclose MESSAGE in [...] if this is not yet the case. | |
203 | If ARGS are provided, then pass MESSAGE through `format'." | |
204 | ;; Clear out any old echo-area message to make way for our new thing. | |
205 | (message nil) | |
bd5c2732 SM |
206 | (setq message (if (and (null args) (string-match "\\[.+\\]" message)) |
207 | ;; Make sure we can put-text-property. | |
208 | (copy-sequence message) | |
209 | (concat " [" message "]"))) | |
32bae13c SM |
210 | (when args (setq message (apply 'format message args))) |
211 | (let ((ol (make-overlay (point-max) (point-max) nil t t))) | |
212 | (unwind-protect | |
213 | (progn | |
bf87d5fc SM |
214 | (unless (zerop (length message)) |
215 | ;; The current C cursor code doesn't know to use the overlay's | |
216 | ;; marker's stickiness to figure out whether to place the cursor | |
217 | ;; before or after the string, so let's spoon-feed it the pos. | |
218 | (put-text-property 0 1 'cursor t message)) | |
32bae13c SM |
219 | (overlay-put ol 'after-string message) |
220 | (sit-for (or minibuffer-message-timeout 1000000))) | |
221 | (delete-overlay ol)))) | |
222 | ||
223 | (defun minibuffer-completion-contents () | |
224 | "Return the user input in a minibuffer before point as a string. | |
225 | That is what completion commands operate on." | |
226 | (buffer-substring (field-beginning) (point))) | |
227 | ||
228 | (defun delete-minibuffer-contents () | |
229 | "Delete all user input in a minibuffer. | |
230 | If the current buffer is not a minibuffer, erase its entire contents." | |
231 | (delete-field)) | |
232 | ||
ba5ff07b SM |
233 | (defcustom completion-auto-help t |
234 | "Non-nil means automatically provide help for invalid completion input. | |
235 | If the value is t the *Completion* buffer is displayed whenever completion | |
236 | is requested but cannot be done. | |
237 | If the value is `lazy', the *Completions* buffer is only displayed after | |
238 | the second failed attempt to complete." | |
e1bb0fe5 | 239 | :type '(choice (const nil) (const t) (const lazy)) |
ba5ff07b SM |
240 | :group 'minibuffer) |
241 | ||
e2947429 | 242 | (defvar completion-styles-alist |
19c04f39 SM |
243 | '((basic completion-basic-try-completion completion-basic-all-completions) |
244 | (emacs22 completion-emacs22-try-completion completion-emacs22-all-completions) | |
245 | (emacs21 completion-emacs21-try-completion completion-emacs21-all-completions) | |
e2947429 SM |
246 | ;; (partial-completion |
247 | ;; completion-pcm--try-completion completion-pcm--all-completions) | |
248 | ) | |
249 | "List of available completion styles. | |
250 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS) | |
251 | where NAME is the name that should be used in `completion-styles' | |
252 | TRY-COMPLETION is the function that does the completion, and | |
253 | ALL-COMPLETIONS is the function that lists the completions.") | |
254 | ||
255 | (defcustom completion-styles '(basic) | |
256 | "List of completion styles to use." | |
257 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) | |
258 | completion-styles-alist))) | |
259 | :group 'minibuffer | |
260 | :version "23.1") | |
261 | ||
19c04f39 SM |
262 | (defun completion-try-completion (string table pred point) |
263 | "Try to complete STRING using completion table TABLE. | |
264 | Only the elements of table that satisfy predicate PRED are considered. | |
265 | POINT is the position of point within STRING. | |
266 | The return value can be either nil to indicate that there is no completion, | |
267 | t to indicate that STRING is the only possible completion, | |
268 | or a pair (STRING . NEWPOINT) of the completed result string together with | |
269 | a new position for point." | |
3911966b SM |
270 | ;; The property `completion-styles' indicates that this functional |
271 | ;; completion-table claims to take care of completion styles itself. | |
272 | ;; [I.e. It will most likely call us back at some point. ] | |
273 | (if (and (symbolp table) (get table 'completion-styles)) | |
19c04f39 SM |
274 | ;; Extended semantics for functional completion-tables: |
275 | ;; They accept a 4th argument `point' and when called with action=nil | |
276 | ;; and this 4th argument (a position inside `string'), they should | |
277 | ;; return instead of a string a pair (STRING . NEWPOINT). | |
278 | (funcall table string pred nil point) | |
e2947429 | 279 | (completion--some (lambda (style) |
2ed430f4 | 280 | (funcall (nth 1 (assq style completion-styles-alist)) |
19c04f39 | 281 | string table pred point)) |
e2947429 SM |
282 | completion-styles))) |
283 | ||
19c04f39 SM |
284 | (defun completion-all-completions (string table pred point) |
285 | "List the possible completions of STRING in completion table TABLE. | |
286 | Only the elements of table that satisfy predicate PRED are considered. | |
287 | POINT is the position of point within STRING. | |
288 | The return value is a list of completions and may contain the BASE-SIZE | |
289 | in the last `cdr'." | |
3911966b SM |
290 | ;; The property `completion-styles' indicates that this functional |
291 | ;; completion-table claims to take care of completion styles itself. | |
292 | ;; [I.e. It will most likely call us back at some point. ] | |
e2947429 | 293 | (let ((completion-all-completions-with-base-size t)) |
19c04f39 SM |
294 | (if (and (symbolp table) (get table 'completion-styles)) |
295 | ;; Extended semantics for functional completion-tables: | |
296 | ;; They accept a 4th argument `point' and when called with action=t | |
297 | ;; and this 4th argument (a position inside `string'), they may | |
298 | ;; return BASE-SIZE in the last `cdr'. | |
299 | (funcall table string pred t point) | |
e2947429 | 300 | (completion--some (lambda (style) |
2ed430f4 | 301 | (funcall (nth 2 (assq style completion-styles-alist)) |
19c04f39 | 302 | string table pred point)) |
e2947429 SM |
303 | completion-styles)))) |
304 | ||
ba5ff07b SM |
305 | (defun minibuffer--bitset (modified completions exact) |
306 | (logior (if modified 4 0) | |
307 | (if completions 2 0) | |
308 | (if exact 1 0))) | |
309 | ||
3911966b | 310 | (defun completion--do-completion (&optional try-completion-function) |
32bae13c | 311 | "Do the completion and return a summary of what happened. |
ba5ff07b SM |
312 | M = completion was performed, the text was Modified. |
313 | C = there were available Completions. | |
314 | E = after completion we now have an Exact match. | |
315 | ||
316 | MCE | |
317 | 000 0 no possible completion | |
318 | 001 1 was already an exact and unique completion | |
319 | 010 2 no completion happened | |
320 | 011 3 was already an exact completion | |
321 | 100 4 ??? impossible | |
322 | 101 5 ??? impossible | |
323 | 110 6 some completion happened | |
324 | 111 7 completed to an exact completion" | |
325 | (let* ((beg (field-beginning)) | |
19c04f39 | 326 | (end (field-end)) |
3911966b | 327 | (string (buffer-substring beg end)) |
19c04f39 SM |
328 | (comp (funcall (or try-completion-function |
329 | 'completion-try-completion) | |
330 | string | |
331 | minibuffer-completion-table | |
332 | minibuffer-completion-predicate | |
333 | (- (point) beg)))) | |
32bae13c | 334 | (cond |
19c04f39 | 335 | ((null comp) |
ba5ff07b | 336 | (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil)) |
19c04f39 | 337 | ((eq t comp) (minibuffer--bitset nil nil t)) ;Exact and unique match. |
32bae13c SM |
338 | (t |
339 | ;; `completed' should be t if some completion was done, which doesn't | |
340 | ;; include simply changing the case of the entered string. However, | |
341 | ;; for appearance, the string is rewritten if the case changes. | |
19c04f39 SM |
342 | (let* ((comp-pos (cdr comp)) |
343 | (completion (car comp)) | |
344 | (completed (not (eq t (compare-strings completion nil nil | |
345 | string nil nil t)))) | |
3911966b SM |
346 | (unchanged (eq t (compare-strings completion nil nil |
347 | string nil nil nil)))) | |
32bae13c | 348 | (unless unchanged |
ba5ff07b SM |
349 | |
350 | ;; Insert in minibuffer the chars we got. | |
3911966b SM |
351 | (goto-char end) |
352 | (insert completion) | |
19c04f39 SM |
353 | (delete-region beg end) |
354 | (goto-char (+ beg comp-pos))) | |
ba5ff07b | 355 | |
32bae13c SM |
356 | (if (not (or unchanged completed)) |
357 | ;; The case of the string changed, but that's all. We're not sure | |
358 | ;; whether this is a unique completion or not, so try again using | |
359 | ;; the real case (this shouldn't recurse again, because the next | |
360 | ;; time try-completion will return either t or the exact string). | |
3911966b | 361 | (completion--do-completion try-completion-function) |
32bae13c SM |
362 | |
363 | ;; It did find a match. Do we match some possibility exactly now? | |
19c04f39 | 364 | (let ((exact (test-completion completion |
32bae13c SM |
365 | minibuffer-completion-table |
366 | minibuffer-completion-predicate))) | |
ba5ff07b SM |
367 | (unless completed |
368 | ;; Show the completion table, if requested. | |
369 | (cond | |
370 | ((not exact) | |
371 | (if (case completion-auto-help | |
372 | (lazy (eq this-command last-command)) | |
373 | (t completion-auto-help)) | |
374 | (minibuffer-completion-help) | |
375 | (minibuffer-message "Next char not unique"))) | |
376 | ;; If the last exact completion and this one were the same, | |
377 | ;; it means we've already given a "Complete but not unique" | |
378 | ;; message and the user's hit TAB again, so now we give him help. | |
379 | ((eq this-command last-command) | |
380 | (if completion-auto-help (minibuffer-completion-help))))) | |
381 | ||
382 | (minibuffer--bitset completed t exact)))))))) | |
32bae13c SM |
383 | |
384 | (defun minibuffer-complete () | |
385 | "Complete the minibuffer contents as far as possible. | |
386 | Return nil if there is no valid completion, else t. | |
387 | If no characters can be completed, display a list of possible completions. | |
388 | If you repeat this command after it displayed such a list, | |
389 | scroll the window of possible completions." | |
390 | (interactive) | |
391 | ;; If the previous command was not this, | |
392 | ;; mark the completion buffer obsolete. | |
393 | (unless (eq this-command last-command) | |
394 | (setq minibuffer-scroll-window nil)) | |
395 | ||
396 | (let ((window minibuffer-scroll-window)) | |
397 | ;; If there's a fresh completion window with a live buffer, | |
398 | ;; and this command is repeated, scroll that window. | |
399 | (if (window-live-p window) | |
400 | (with-current-buffer (window-buffer window) | |
401 | (if (pos-visible-in-window-p (point-max) window) | |
402 | ;; If end is in view, scroll up to the beginning. | |
403 | (set-window-start window (point-min) nil) | |
404 | ;; Else scroll down one screen. | |
405 | (scroll-other-window)) | |
406 | nil) | |
407 | ||
3911966b | 408 | (case (completion--do-completion) |
ba5ff07b SM |
409 | (0 nil) |
410 | (1 (goto-char (field-end)) | |
411 | (minibuffer-message "Sole completion") | |
412 | t) | |
413 | (3 (goto-char (field-end)) | |
414 | (minibuffer-message "Complete, but not unique") | |
415 | t) | |
416 | (t t))))) | |
32bae13c SM |
417 | |
418 | (defun minibuffer-complete-and-exit () | |
419 | "If the minibuffer contents is a valid completion then exit. | |
420 | Otherwise try to complete it. If completion leads to a valid completion, | |
421 | a repetition of this command will exit." | |
422 | (interactive) | |
3911966b SM |
423 | (let ((beg (field-beginning)) |
424 | (end (field-end))) | |
425 | (cond | |
426 | ;; Allow user to specify null string | |
427 | ((= beg end) (exit-minibuffer)) | |
428 | ((test-completion (buffer-substring beg end) | |
429 | minibuffer-completion-table | |
430 | minibuffer-completion-predicate) | |
431 | (when completion-ignore-case | |
432 | ;; Fixup case of the field, if necessary. | |
b0a5a021 | 433 | (let* ((string (buffer-substring beg end)) |
3911966b SM |
434 | (compl (try-completion |
435 | string | |
436 | minibuffer-completion-table | |
437 | minibuffer-completion-predicate))) | |
438 | (when (and (stringp compl) | |
439 | ;; If it weren't for this piece of paranoia, I'd replace | |
440 | ;; the whole thing with a call to do-completion. | |
441 | (= (length string) (length compl))) | |
32bae13c SM |
442 | (goto-char end) |
443 | (insert compl) | |
3911966b SM |
444 | (delete-region beg end)))) |
445 | (exit-minibuffer)) | |
32bae13c | 446 | |
3911966b SM |
447 | ((eq minibuffer-completion-confirm 'confirm-only) |
448 | ;; The user is permitted to exit with an input that's rejected | |
449 | ;; by test-completion, but at the condition to confirm her choice. | |
450 | (if (eq last-command this-command) | |
451 | (exit-minibuffer) | |
452 | (minibuffer-message "Confirm") | |
453 | nil)) | |
32bae13c | 454 | |
3911966b SM |
455 | (t |
456 | ;; Call do-completion, but ignore errors. | |
457 | (case (condition-case nil | |
458 | (completion--do-completion) | |
459 | (error 1)) | |
460 | ((1 3) (exit-minibuffer)) | |
461 | (7 (if (not minibuffer-completion-confirm) | |
462 | (exit-minibuffer) | |
463 | (minibuffer-message "Confirm") | |
464 | nil)) | |
465 | (t nil)))))) | |
466 | ||
19c04f39 SM |
467 | (defun completion--try-word-completion (string table predicate point) |
468 | (let ((comp (completion-try-completion string table predicate point))) | |
469 | (if (not (consp comp)) | |
470 | comp | |
32bae13c | 471 | |
3911966b SM |
472 | ;; If completion finds next char not unique, |
473 | ;; consider adding a space or a hyphen. | |
19c04f39 | 474 | (when (= (length string) (length (car comp))) |
3911966b | 475 | (let ((exts '(" " "-")) |
19c04f39 SM |
476 | (before (substring string 0 point)) |
477 | (after (substring string point)) | |
478 | tem) | |
479 | (while (and exts (not (consp tem))) | |
3911966b | 480 | (setq tem (completion-try-completion |
19c04f39 SM |
481 | (concat before (pop exts) after) |
482 | table predicate (1+ point)))) | |
483 | (if (consp tem) (setq comp tem)))) | |
3911966b | 484 | |
32bae13c SM |
485 | ;; Completing a single word is actually more difficult than completing |
486 | ;; as much as possible, because we first have to find the "current | |
487 | ;; position" in `completion' in order to find the end of the word | |
488 | ;; we're completing. Normally, `string' is a prefix of `completion', | |
489 | ;; which makes it trivial to find the position, but with fancier | |
490 | ;; completion (plus env-var expansion, ...) `completion' might not | |
491 | ;; look anything like `string' at all. | |
19c04f39 SM |
492 | (let* ((comppoint (cdr comp)) |
493 | (completion (car comp)) | |
494 | (before (substring string 0 point)) | |
495 | (combined (concat before "\n" completion))) | |
496 | ;; Find in completion the longest text that was right before point. | |
497 | (when (string-match "\\(.+\\)\n.*?\\1" combined) | |
498 | (let* ((prefix (match-string 1 before)) | |
499 | ;; We used non-greedy match to make `rem' as long as possible. | |
500 | (rem (substring combined (match-end 0))) | |
501 | ;; Find in the remainder of completion the longest text | |
502 | ;; that was right after point. | |
503 | (after (substring string point)) | |
504 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" | |
505 | (concat after "\n" rem)) | |
506 | (match-string 1 after)))) | |
507 | ;; The general idea is to try and guess what text was inserted | |
508 | ;; at point by the completion. Problem is: if we guess wrong, | |
509 | ;; we may end up treating as "added by completion" text that was | |
510 | ;; actually painfully typed by the user. So if we then cut | |
511 | ;; after the first word, we may throw away things the | |
512 | ;; user wrote. So let's try to be as conservative as possible: | |
513 | ;; only cut after the first word, if we're reasonably sure that | |
514 | ;; our guess is correct. | |
515 | ;; Note: a quick survey on emacs-devel seemed to indicate that | |
516 | ;; nobody actually cares about the "word-at-a-time" feature of | |
517 | ;; minibuffer-complete-word, whose real raison-d'être is that it | |
518 | ;; tries to add "-" or " ". One more reason to only cut after | |
519 | ;; the first word, if we're really sure we're right. | |
520 | (when (and (or suffix (zerop (length after))) | |
521 | (string-match (concat | |
522 | ;; Make submatch 1 as small as possible | |
523 | ;; to reduce the risk of cutting | |
524 | ;; valuable text. | |
525 | ".*" (regexp-quote prefix) "\\(.*?\\)" | |
526 | (if suffix (regexp-quote suffix) "\\'")) | |
527 | completion) | |
528 | ;; The new point in `completion' should also be just | |
529 | ;; before the suffix, otherwise something more complex | |
530 | ;; is going on, and we're not sure where we are. | |
531 | (eq (match-end 1) comppoint) | |
532 | ;; (match-beginning 1)..comppoint is now the stretch | |
533 | ;; of text in `completion' that was completed at point. | |
534 | (string-match "\\W" completion (match-beginning 1)) | |
535 | ;; Is there really something to cut? | |
536 | (> comppoint (match-end 0))) | |
537 | ;; Cut after the first word. | |
538 | (let ((cutpos (match-end 0))) | |
539 | (setq completion (concat (substring completion 0 cutpos) | |
540 | (substring completion comppoint))) | |
541 | (setq comppoint cutpos))))) | |
542 | ||
543 | (cons completion comppoint))))) | |
ba5ff07b SM |
544 | |
545 | ||
546 | (defun minibuffer-complete-word () | |
547 | "Complete the minibuffer contents at most a single word. | |
548 | After one word is completed as much as possible, a space or hyphen | |
549 | is added, provided that matches some possible completion. | |
550 | Return nil if there is no valid completion, else t." | |
551 | (interactive) | |
3911966b | 552 | (case (completion--do-completion 'completion--try-word-completion) |
ba5ff07b SM |
553 | (0 nil) |
554 | (1 (goto-char (field-end)) | |
555 | (minibuffer-message "Sole completion") | |
556 | t) | |
557 | (3 (goto-char (field-end)) | |
558 | (minibuffer-message "Complete, but not unique") | |
559 | t) | |
560 | (t t))) | |
561 | ||
3911966b | 562 | (defun completion--insert-strings (strings) |
32bae13c SM |
563 | "Insert a list of STRINGS into the current buffer. |
564 | Uses columns to keep the listing readable but compact. | |
565 | It also eliminates runs of equal strings." | |
566 | (when (consp strings) | |
567 | (let* ((length (apply 'max | |
568 | (mapcar (lambda (s) | |
569 | (if (consp s) | |
570 | (+ (length (car s)) (length (cadr s))) | |
571 | (length s))) | |
572 | strings))) | |
573 | (window (get-buffer-window (current-buffer) 0)) | |
574 | (wwidth (if window (1- (window-width window)) 79)) | |
575 | (columns (min | |
576 | ;; At least 2 columns; at least 2 spaces between columns. | |
577 | (max 2 (/ wwidth (+ 2 length))) | |
578 | ;; Don't allocate more columns than we can fill. | |
579 | ;; Windows can't show less than 3 lines anyway. | |
580 | (max 1 (/ (length strings) 2)))) | |
581 | (colwidth (/ wwidth columns)) | |
582 | (column 0) | |
583 | (laststring nil)) | |
584 | ;; The insertion should be "sensible" no matter what choices were made | |
585 | ;; for the parameters above. | |
586 | (dolist (str strings) | |
587 | (unless (equal laststring str) ; Remove (consecutive) duplicates. | |
588 | (setq laststring str) | |
589 | (unless (bolp) | |
590 | (insert " \t") | |
591 | (setq column (+ column colwidth)) | |
592 | ;; Leave the space unpropertized so that in the case we're | |
593 | ;; already past the goal column, there is still | |
594 | ;; a space displayed. | |
595 | (set-text-properties (- (point) 1) (point) | |
596 | ;; We can't just set tab-width, because | |
597 | ;; completion-setup-function will kill all | |
598 | ;; local variables :-( | |
599 | `(display (space :align-to ,column)))) | |
600 | (when (< wwidth (+ (max colwidth | |
601 | (if (consp str) | |
602 | (+ (length (car str)) (length (cadr str))) | |
603 | (length str))) | |
604 | column)) | |
605 | (delete-char -2) (insert "\n") (setq column 0)) | |
606 | (if (not (consp str)) | |
607 | (put-text-property (point) (progn (insert str) (point)) | |
608 | 'mouse-face 'highlight) | |
609 | (put-text-property (point) (progn (insert (car str)) (point)) | |
610 | 'mouse-face 'highlight) | |
611 | (put-text-property (point) (progn (insert (cadr str)) (point)) | |
612 | 'mouse-face nil))))))) | |
613 | ||
614 | (defvar completion-common-substring) | |
615 | ||
21622c6d SM |
616 | (defvar completion-setup-hook nil |
617 | "Normal hook run at the end of setting up a completion list buffer. | |
618 | When this hook is run, the current buffer is the one in which the | |
619 | command to display the completion list buffer was run. | |
620 | The completion list buffer is available as the value of `standard-output'. | |
b95c7600 JB |
621 | The common prefix substring for completion may be available as the value |
622 | of `completion-common-substring'. See also `display-completion-list'.") | |
21622c6d | 623 | |
32bae13c SM |
624 | (defun display-completion-list (completions &optional common-substring) |
625 | "Display the list of completions, COMPLETIONS, using `standard-output'. | |
626 | Each element may be just a symbol or string | |
627 | or may be a list of two strings to be printed as if concatenated. | |
628 | If it is a list of two strings, the first is the actual completion | |
629 | alternative, the second serves as annotation. | |
630 | `standard-output' must be a buffer. | |
631 | The actual completion alternatives, as inserted, are given `mouse-face' | |
632 | properties of `highlight'. | |
633 | At the end, this runs the normal hook `completion-setup-hook'. | |
634 | It can find the completion buffer in `standard-output'. | |
635 | The optional second arg COMMON-SUBSTRING is a string. | |
636 | It is used to put faces, `completions-first-difference' and | |
b95c7600 | 637 | `completions-common-part' on the completion buffer. The |
32bae13c SM |
638 | `completions-common-part' face is put on the common substring |
639 | specified by COMMON-SUBSTRING. If COMMON-SUBSTRING is nil | |
640 | and the current buffer is not the minibuffer, the faces are not put. | |
641 | Internally, COMMON-SUBSTRING is bound to `completion-common-substring' | |
642 | during running `completion-setup-hook'." | |
643 | (if (not (bufferp standard-output)) | |
644 | ;; This *never* (ever) happens, so there's no point trying to be clever. | |
645 | (with-temp-buffer | |
646 | (let ((standard-output (current-buffer)) | |
647 | (completion-setup-hook nil)) | |
648 | (display-completion-list completions)) | |
649 | (princ (buffer-string))) | |
650 | ||
651 | (with-current-buffer standard-output | |
652 | (goto-char (point-max)) | |
653 | (if (null completions) | |
654 | (insert "There are no possible completions of what you have typed.") | |
e1bb0fe5 | 655 | |
32bae13c | 656 | (insert "Possible completions are:\n") |
e2947429 SM |
657 | (let ((last (last completions))) |
658 | ;; Get the base-size from the tail of the list. | |
659 | (set (make-local-variable 'completion-base-size) (or (cdr last) 0)) | |
660 | (setcdr last nil)) ;Make completions a properly nil-terminated list. | |
3911966b | 661 | (completion--insert-strings completions)))) |
e2947429 | 662 | |
32bae13c SM |
663 | (let ((completion-common-substring common-substring)) |
664 | (run-hooks 'completion-setup-hook)) | |
665 | nil) | |
666 | ||
667 | (defun minibuffer-completion-help () | |
668 | "Display a list of possible completions of the current minibuffer contents." | |
669 | (interactive) | |
670 | (message "Making completion list...") | |
671 | (let* ((string (field-string)) | |
3911966b | 672 | (completions (completion-all-completions |
32bae13c SM |
673 | string |
674 | minibuffer-completion-table | |
19c04f39 SM |
675 | minibuffer-completion-predicate |
676 | (- (point) (field-beginning))))) | |
32bae13c SM |
677 | (message nil) |
678 | (if (and completions | |
e2947429 SM |
679 | (or (consp (cdr completions)) |
680 | (not (equal (car completions) string)))) | |
32bae13c | 681 | (with-output-to-temp-buffer "*Completions*" |
e2947429 SM |
682 | (let* ((last (last completions)) |
683 | (base-size (cdr last))) | |
684 | ;; Remove the base-size tail because `sort' requires a properly | |
685 | ;; nil-terminated list. | |
686 | (when last (setcdr last nil)) | |
687 | (display-completion-list (nconc (sort completions 'string-lessp) | |
688 | base-size)))) | |
32bae13c SM |
689 | |
690 | ;; If there are no completions, or if the current input is already the | |
691 | ;; only possible completion, then hide (previous&stale) completions. | |
692 | (let ((window (and (get-buffer "*Completions*") | |
693 | (get-buffer-window "*Completions*" 0)))) | |
694 | (when (and (window-live-p window) (window-dedicated-p window)) | |
695 | (condition-case () | |
696 | (delete-window window) | |
697 | (error (iconify-frame (window-frame window)))))) | |
698 | (ding) | |
699 | (minibuffer-message | |
700 | (if completions "Sole completion" "No completions"))) | |
701 | nil)) | |
702 | ||
703 | (defun exit-minibuffer () | |
704 | "Terminate this minibuffer argument." | |
705 | (interactive) | |
706 | ;; If the command that uses this has made modifications in the minibuffer, | |
707 | ;; we don't want them to cause deactivation of the mark in the original | |
708 | ;; buffer. | |
709 | ;; A better solution would be to make deactivate-mark buffer-local | |
710 | ;; (or to turn it into a list of buffers, ...), but in the mean time, | |
711 | ;; this should do the trick in most cases. | |
ba5ff07b | 712 | (setq deactivate-mark nil) |
32bae13c SM |
713 | (throw 'exit nil)) |
714 | ||
715 | (defun self-insert-and-exit () | |
716 | "Terminate minibuffer input." | |
717 | (interactive) | |
718 | (if (characterp last-command-char) | |
719 | (call-interactively 'self-insert-command) | |
720 | (ding)) | |
721 | (exit-minibuffer)) | |
722 | ||
34b67b0f SM |
723 | (defun minibuffer--double-dollars (str) |
724 | (replace-regexp-in-string "\\$" "$$" str)) | |
725 | ||
21622c6d SM |
726 | (defun completion--make-envvar-table () |
727 | (mapcar (lambda (enventry) | |
728 | (substring enventry 0 (string-match "=" enventry))) | |
729 | process-environment)) | |
730 | ||
731 | (defun completion--embedded-envvar-table (string pred action) | |
732 | (when (string-match (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" | |
733 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'") | |
734 | string) | |
735 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) | |
017c22fe | 736 | (table (completion--make-envvar-table)) |
21622c6d SM |
737 | (prefix (substring string 0 beg))) |
738 | (if (eq (aref string (1- beg)) ?{) | |
739 | (setq table (apply-partially 'completion-table-with-terminator | |
740 | "}" table))) | |
741 | (completion-table-with-context prefix table | |
742 | (substring string beg) | |
743 | pred action)))) | |
017c22fe | 744 | |
f50e56f0 | 745 | (defun completion--file-name-table (string pred action) |
b95c7600 | 746 | "Internal subroutine for `read-file-name'. Do not call this." |
34b67b0f SM |
747 | (if (and (zerop (length string)) (eq 'lambda action)) |
748 | nil ; FIXME: why? | |
f50e56f0 SM |
749 | (let* ((dir (if (stringp pred) |
750 | ;; It used to be that `pred' was abused to pass `dir' | |
751 | ;; as an argument. | |
752 | (prog1 (expand-file-name pred) (setq pred nil)) | |
753 | default-directory)) | |
754 | (str (condition-case nil | |
21622c6d SM |
755 | (substitute-in-file-name string) |
756 | (error string))) | |
34b67b0f SM |
757 | (name (file-name-nondirectory str)) |
758 | (specdir (file-name-directory str)) | |
759 | (realdir (if specdir (expand-file-name specdir dir) | |
760 | (file-name-as-directory dir)))) | |
017c22fe | 761 | |
34b67b0f SM |
762 | (cond |
763 | ((null action) | |
764 | (let ((comp (file-name-completion name realdir | |
765 | read-file-name-predicate))) | |
766 | (if (stringp comp) | |
767 | ;; Requote the $s before returning the completion. | |
768 | (minibuffer--double-dollars (concat specdir comp)) | |
769 | ;; Requote the $s before checking for changes. | |
770 | (setq str (minibuffer--double-dollars str)) | |
771 | (if (string-equal string str) | |
772 | comp | |
773 | ;; If there's no real completion, but substitute-in-file-name | |
774 | ;; changed the string, then return the new string. | |
775 | str)))) | |
017c22fe | 776 | |
34b67b0f | 777 | ((eq action t) |
e2947429 SM |
778 | (let ((all (file-name-all-completions name realdir)) |
779 | ;; Actually, this is not always right in the presence of | |
780 | ;; envvars, but there's not much we can do, I think. | |
781 | (base-size (length (file-name-directory string)))) | |
782 | ||
783 | ;; Check the predicate, if necessary. | |
784 | (unless (memq read-file-name-predicate '(nil file-exists-p)) | |
34b67b0f SM |
785 | (let ((comp ()) |
786 | (pred | |
787 | (if (eq read-file-name-predicate 'file-directory-p) | |
788 | ;; Brute-force speed up for directory checking: | |
789 | ;; Discard strings which don't end in a slash. | |
790 | (lambda (s) | |
791 | (let ((len (length s))) | |
792 | (and (> len 0) (eq (aref s (1- len)) ?/)))) | |
793 | ;; Must do it the hard (and slow) way. | |
794 | read-file-name-predicate))) | |
795 | (let ((default-directory realdir)) | |
796 | (dolist (tem all) | |
797 | (if (funcall pred tem) (push tem comp)))) | |
e2947429 SM |
798 | (setq all (nreverse comp)))) |
799 | ||
88893215 SM |
800 | (if (and completion-all-completions-with-base-size (consp all)) |
801 | ;; Add base-size, but only if the list is non-empty. | |
802 | (nconc all base-size)) | |
803 | ||
804 | all)) | |
34b67b0f SM |
805 | |
806 | (t | |
807 | ;; Only other case actually used is ACTION = lambda. | |
808 | (let ((default-directory dir)) | |
809 | (funcall (or read-file-name-predicate 'file-exists-p) str))))))) | |
810 | ||
21622c6d | 811 | (defalias 'read-file-name-internal |
017c22fe | 812 | (completion-table-in-turn 'completion--embedded-envvar-table |
88893215 | 813 | 'completion--file-name-table) |
21622c6d | 814 | "Internal subroutine for `read-file-name'. Do not call this.") |
34b67b0f | 815 | |
dbd50d4b SM |
816 | (defvar read-file-name-function nil |
817 | "If this is non-nil, `read-file-name' does its work by calling this function.") | |
818 | ||
819 | (defvar read-file-name-predicate nil | |
820 | "Current predicate used by `read-file-name-internal'.") | |
821 | ||
822 | (defcustom read-file-name-completion-ignore-case | |
823 | (if (memq system-type '(ms-dos windows-nt darwin macos vax-vms axp-vms)) | |
824 | t nil) | |
825 | "Non-nil means when reading a file name completion ignores case." | |
826 | :group 'minibuffer | |
827 | :type 'boolean | |
828 | :version "22.1") | |
829 | ||
830 | (defcustom insert-default-directory t | |
831 | "Non-nil means when reading a filename start with default dir in minibuffer. | |
832 | ||
833 | When the initial minibuffer contents show a name of a file or a directory, | |
834 | typing RETURN without editing the initial contents is equivalent to typing | |
835 | the default file name. | |
836 | ||
837 | If this variable is non-nil, the minibuffer contents are always | |
838 | initially non-empty, and typing RETURN without editing will fetch the | |
839 | default name, if one is provided. Note however that this default name | |
840 | is not necessarily the same as initial contents inserted in the minibuffer, | |
841 | if the initial contents is just the default directory. | |
842 | ||
843 | If this variable is nil, the minibuffer often starts out empty. In | |
844 | that case you may have to explicitly fetch the next history element to | |
845 | request the default name; typing RETURN without editing will leave | |
846 | the minibuffer empty. | |
847 | ||
848 | For some commands, exiting with an empty minibuffer has a special meaning, | |
849 | such as making the current buffer visit no file in the case of | |
850 | `set-visited-file-name'." | |
851 | :group 'minibuffer | |
852 | :type 'boolean) | |
853 | ||
4e3870f5 GM |
854 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
855 | (declare-function x-file-dialog "xfns.c" | |
856 | (prompt dir &optional default-filename mustmatch only-dir-p)) | |
857 | ||
dbd50d4b SM |
858 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
859 | "Read file name, prompting with PROMPT and completing in directory DIR. | |
860 | Value is not expanded---you must call `expand-file-name' yourself. | |
861 | Default name to DEFAULT-FILENAME if user exits the minibuffer with | |
862 | the same non-empty string that was inserted by this function. | |
863 | (If DEFAULT-FILENAME is omitted, the visited file name is used, | |
864 | except that if INITIAL is specified, that combined with DIR is used.) | |
865 | If the user exits with an empty minibuffer, this function returns | |
866 | an empty string. (This can only happen if the user erased the | |
867 | pre-inserted contents or if `insert-default-directory' is nil.) | |
868 | Fourth arg MUSTMATCH non-nil means require existing file's name. | |
869 | Non-nil and non-t means also require confirmation after completion. | |
870 | Fifth arg INITIAL specifies text to start with. | |
871 | If optional sixth arg PREDICATE is non-nil, possible completions and | |
872 | the resulting file name must satisfy (funcall PREDICATE NAME). | |
873 | DIR should be an absolute directory name. It defaults to the value of | |
874 | `default-directory'. | |
875 | ||
876 | If this command was invoked with the mouse, use a file dialog box if | |
877 | `use-dialog-box' is non-nil, and the window system or X toolkit in use | |
878 | provides a file dialog box. | |
879 | ||
880 | See also `read-file-name-completion-ignore-case' | |
881 | and `read-file-name-function'." | |
882 | (unless dir (setq dir default-directory)) | |
883 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) | |
884 | (unless default-filename | |
885 | (setq default-filename (if initial (expand-file-name initial dir) | |
886 | buffer-file-name))) | |
887 | ;; If dir starts with user's homedir, change that to ~. | |
888 | (setq dir (abbreviate-file-name dir)) | |
889 | ;; Likewise for default-filename. | |
e8a5fe3e SM |
890 | (if default-filename |
891 | (setq default-filename (abbreviate-file-name default-filename))) | |
dbd50d4b SM |
892 | (let ((insdef (cond |
893 | ((and insert-default-directory (stringp dir)) | |
894 | (if initial | |
895 | (cons (minibuffer--double-dollars (concat dir initial)) | |
896 | (length (minibuffer--double-dollars dir))) | |
897 | (minibuffer--double-dollars dir))) | |
898 | (initial (cons (minibuffer--double-dollars initial) 0))))) | |
899 | ||
900 | (if read-file-name-function | |
901 | (funcall read-file-name-function | |
902 | prompt dir default-filename mustmatch initial predicate) | |
e8a5fe3e | 903 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
dbd50d4b SM |
904 | (minibuffer-completing-file-name t) |
905 | (read-file-name-predicate (or predicate 'file-exists-p)) | |
906 | (add-to-history nil)) | |
907 | ||
908 | (let* ((val | |
909 | (if (not (next-read-file-uses-dialog-p)) | |
e8a5fe3e SM |
910 | ;; We used to pass `dir' to `read-file-name-internal' by |
911 | ;; abusing the `predicate' argument. It's better to | |
912 | ;; just use `default-directory', but in order to avoid | |
913 | ;; changing `default-directory' in the current buffer, | |
914 | ;; we don't let-bind it. | |
915 | (lexical-let ((dir (file-name-as-directory | |
916 | (expand-file-name dir)))) | |
917 | (minibuffer-with-setup-hook | |
918 | (lambda () (setq default-directory dir)) | |
919 | (completing-read prompt 'read-file-name-internal | |
920 | nil mustmatch insdef 'file-name-history | |
921 | default-filename))) | |
dbd50d4b SM |
922 | ;; If DIR contains a file name, split it. |
923 | (let ((file (file-name-nondirectory dir))) | |
924 | (when (and default-filename (not (zerop (length file)))) | |
925 | (setq default-filename file) | |
926 | (setq dir (file-name-directory dir))) | |
927 | (if default-filename | |
928 | (setq default-filename | |
929 | (expand-file-name default-filename dir))) | |
930 | (setq add-to-history t) | |
931 | (x-file-dialog prompt dir default-filename mustmatch | |
932 | (eq predicate 'file-directory-p))))) | |
933 | ||
934 | (replace-in-history (eq (car-safe file-name-history) val))) | |
935 | ;; If completing-read returned the inserted default string itself | |
936 | ;; (rather than a new string with the same contents), | |
937 | ;; it has to mean that the user typed RET with the minibuffer empty. | |
938 | ;; In that case, we really want to return "" | |
939 | ;; so that commands such as set-visited-file-name can distinguish. | |
940 | (when (eq val default-filename) | |
941 | ;; In this case, completing-read has not added an element | |
942 | ;; to the history. Maybe we should. | |
943 | (if (not replace-in-history) | |
944 | (setq add-to-history t)) | |
945 | (setq val "")) | |
946 | (unless val (error "No file name specified")) | |
947 | ||
948 | (if (and default-filename | |
949 | (string-equal val (if (consp insdef) (car insdef) insdef))) | |
950 | (setq val default-filename)) | |
951 | (setq val (substitute-in-file-name val)) | |
952 | ||
953 | (if replace-in-history | |
954 | ;; Replace what Fcompleting_read added to the history | |
955 | ;; with what we will actually return. | |
956 | (let ((val1 (minibuffer--double-dollars val))) | |
957 | (if history-delete-duplicates | |
958 | (setcdr file-name-history | |
959 | (delete val1 (cdr file-name-history)))) | |
960 | (setcar file-name-history val1)) | |
961 | (if add-to-history | |
962 | ;; Add the value to the history--but not if it matches | |
963 | ;; the last value already there. | |
964 | (let ((val1 (minibuffer--double-dollars val))) | |
965 | (unless (and (consp file-name-history) | |
966 | (equal (car file-name-history) val1)) | |
967 | (setq file-name-history | |
968 | (cons val1 | |
969 | (if history-delete-duplicates | |
970 | (delete val1 file-name-history) | |
971 | file-name-history))))))) | |
972 | val))))) | |
973 | ||
8b04c0ae JL |
974 | (defun internal-complete-buffer-except (&optional buffer) |
975 | "Perform completion on all buffers excluding BUFFER. | |
976 | Like `internal-complete-buffer', but removes BUFFER from the completion list." | |
977 | (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer)))) | |
978 | (apply-partially 'completion-table-with-predicate | |
979 | 'internal-complete-buffer | |
980 | (lambda (name) | |
981 | (not (equal (if (consp name) (car name) name) except))) | |
982 | nil))) | |
983 | ||
19c04f39 SM |
984 | ;;; Old-style completion, used in Emacs-21. |
985 | ||
986 | (defun completion-emacs21-try-completion (string table pred point) | |
987 | (let ((completion (try-completion string table pred))) | |
988 | (if (stringp completion) | |
989 | (cons completion (length completion)) | |
990 | completion))) | |
991 | ||
992 | (defun completion-emacs21-all-completions (string table pred point) | |
993 | (all-completions string table pred t)) | |
994 | ||
995 | ;;; Basic completion, used in Emacs-22. | |
996 | ||
997 | (defun completion-emacs22-try-completion (string table pred point) | |
998 | (let ((suffix (substring string point)) | |
999 | (completion (try-completion (substring string 0 point) table pred))) | |
1000 | (if (not (stringp completion)) | |
1001 | completion | |
1002 | ;; Merge a trailing / in completion with a / after point. | |
1003 | ;; We used to only do it for word completion, but it seems to make | |
1004 | ;; sense for all completions. | |
1005 | (if (and (eq ?/ (aref completion (1- (length completion)))) | |
1006 | (not (zerop (length suffix))) | |
1007 | (eq ?/ (aref suffix 0))) | |
1008 | ;; This leaves point before the / . | |
1009 | ;; Should we maybe put it after the / ? --Stef | |
1010 | (setq completion (substring completion 0 -1))) | |
1011 | (cons (concat completion suffix) (length completion))))) | |
1012 | ||
1013 | (defun completion-emacs22-all-completions (string table pred point) | |
1014 | (all-completions (substring string 0 point) table pred t)) | |
1015 | ||
1016 | (defalias 'completion-basic-try-completion 'completion-emacs22-try-completion) | |
1017 | (defalias 'completion-basic-all-completions 'completion-emacs22-all-completions) | |
1018 | ||
32bae13c | 1019 | (provide 'minibuffer) |
dc6ee347 MB |
1020 | |
1021 | ;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f | |
32bae13c | 1022 | ;;; minibuffer.el ends here |