* minibuffer.el (completion-table-with-terminator): Properly implement
[bpt/emacs.git] / lisp / minibuffer.el
CommitLineData
32bae13c
SM
1;;; minibuffer.el --- Minibuffer completion functions
2
ae940284 3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
32bae13c
SM
4
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6
7;; This file is part of GNU Emacs.
8
eb3fa2cf 9;; GNU Emacs is free software: you can redistribute it and/or modify
32bae13c
SM
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
eb3fa2cf 14;; GNU Emacs is distributed in the hope that it will be useful,
32bae13c
SM
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
eb3fa2cf 20;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
32bae13c
SM
21
22;;; Commentary:
23
a38313e1
SM
24;; Names with "--" are for functions and variables that are meant to be for
25;; internal use only.
26
27;; Functional completion tables have an extended calling conventions:
a38313e1 28;; - The `action' can be (additionally to nil, t, and lambda) of the form
f8381803
SM
29;; (boundaries . SUFFIX) in which case it should return
30;; (boundaries START . END). See `completion-boundaries'.
a38313e1
SM
31;; Any other return value should be ignored (so we ignore values returned
32;; from completion tables that don't know about this new `action' form).
a38313e1
SM
33
34;;; Bugs:
35
eee6de73
SM
36;; - completion-all-sorted-completions list all the completions, whereas
37;; it should only lists the ones that `try-completion' would consider.
38;; E.g. it should honor completion-ignored-extensions.
a38313e1 39;; - choose-completion can't automatically figure out the boundaries
528c56e2
SM
40;; corresponding to the displayed completions because we only
41;; provide the start info but not the end info in
42;; completion-base-position.
43;; - choose-completion doesn't know how to quote the text it inserts.
44;; E.g. it fails to double the dollars in file-name completion, or
45;; to backslash-escape spaces and other chars in comint completion.
46;; - C-x C-f ~/*/sr ? should not list "~/./src".
47;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el
48;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
ba5ff07b 49
3911966b
SM
50;;; Todo:
51
ab22be48 52;; - make partial-complete-mode obsolete:
ab22be48 53;; - (?) <foo.h> style completion for file names.
528c56e2
SM
54;; This can't be done identically just by tweaking completion,
55;; because partial-completion-mode's behavior is to expand <string.h>
56;; to /usr/include/string.h only when exiting the minibuffer, at which
57;; point the completion code is actually not involved normally.
58;; Partial-completion-mode does it via a find-file-not-found-function.
59;; - special code for C-x C-f <> to visit the file ref'd at point
60;; via (require 'foo) or #include "foo". ffap seems like a better
61;; place for this feature (supplemented with major-mode-provided
62;; functions to find the file ref'd at point).
63
64;; - case-sensitivity currently confuses two issues:
ab22be48 65;; - whether or not a particular completion table should be case-sensitive
528c56e2 66;; (i.e. whether strings that differ only by case are semantically
ab22be48
SM
67;; equivalent)
68;; - whether the user wants completion to pay attention to case.
69;; e.g. we may want to make it possible for the user to say "first try
70;; completion case-sensitively, and if that fails, try to ignore case".
71
a38313e1 72;; - add support for ** to pcm.
3911966b
SM
73;; - Add vc-file-name-completion-table to read-file-name-internal.
74;; - A feature like completing-help.el.
eee6de73 75;; - make lisp/complete.el obsolete.
3911966b 76;; - Make the `hide-spaces' arg of all-completions obsolete?
32bae13c
SM
77
78;;; Code:
79
80(eval-when-compile (require 'cl))
81
21622c6d
SM
82;;; Completion table manipulation
83
a38313e1 84;; New completion-table operation.
f8381803
SM
85(defun completion-boundaries (string table pred suffix)
86 "Return the boundaries of the completions returned by TABLE for STRING.
a38313e1 87STRING is the string on which completion will be performed.
f8381803
SM
88SUFFIX is the string after point.
89The result is of the form (START . END) where START is the position
90in STRING of the beginning of the completion field and END is the position
91in SUFFIX of the end of the completion field.
f8381803
SM
92E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
93and for file names the result is the positions delimited by
a38313e1
SM
94the closest directory separators."
95 (let ((boundaries (if (functionp table)
f8381803 96 (funcall table string pred (cons 'boundaries suffix)))))
a38313e1
SM
97 (if (not (eq (car-safe boundaries) 'boundaries))
98 (setq boundaries nil))
99 (cons (or (cadr boundaries) 0)
f8381803 100 (or (cddr boundaries) (length suffix)))))
a38313e1 101
e2947429
SM
102(defun completion--some (fun xs)
103 "Apply FUN to each element of XS in turn.
104Return the first non-nil returned value.
105Like CL's `some'."
a38313e1
SM
106 (let ((firsterror nil)
107 res)
e2947429 108 (while (and (not res) xs)
a38313e1
SM
109 (condition-case err
110 (setq res (funcall fun (pop xs)))
111 (error (unless firsterror (setq firsterror err)) nil)))
112 (or res
113 (if firsterror (signal (car firsterror) (cdr firsterror))))))
e2947429 114
21622c6d
SM
115(defun complete-with-action (action table string pred)
116 "Perform completion ACTION.
117STRING is the string to complete.
118TABLE is the completion table, which should not be a function.
119PRED is a completion predicate.
120ACTION can be one of nil, t or `lambda'."
a38313e1
SM
121 (cond
122 ((functionp table) (funcall table string pred action))
123 ((eq (car-safe action) 'boundaries)
124 (cons 'boundaries (completion-boundaries string table pred (cdr action))))
125 (t
126 (funcall
127 (cond
128 ((null action) 'try-completion)
129 ((eq action t) 'all-completions)
130 (t 'test-completion))
131 string table pred))))
21622c6d
SM
132
133(defun completion-table-dynamic (fun)
134 "Use function FUN as a dynamic completion table.
135FUN is called with one argument, the string for which completion is required,
b95c7600
JB
136and it should return an alist containing all the intended possible completions.
137This alist may be a full list of possible completions so that FUN can ignore
138the value of its argument. If completion is performed in the minibuffer,
139FUN will be called in the buffer from which the minibuffer was entered.
21622c6d 140
e8061cd9 141The result of the `completion-table-dynamic' form is a function
d9aa6b33 142that can be used as the COLLECTION argument to `try-completion' and
b95c7600 143`all-completions'. See Info node `(elisp)Programmed Completion'."
21622c6d
SM
144 (lexical-let ((fun fun))
145 (lambda (string pred action)
146 (with-current-buffer (let ((win (minibuffer-selected-window)))
147 (if (window-live-p win) (window-buffer win)
148 (current-buffer)))
149 (complete-with-action action (funcall fun string) string pred)))))
150
151(defmacro lazy-completion-table (var fun)
152 "Initialize variable VAR as a lazy completion table.
153If the completion table VAR is used for the first time (e.g., by passing VAR
154as an argument to `try-completion'), the function FUN is called with no
155arguments. FUN must return the completion table that will be stored in VAR.
156If completion is requested in the minibuffer, FUN will be called in the buffer
157from which the minibuffer was entered. The return value of
158`lazy-completion-table' must be used to initialize the value of VAR.
159
160You should give VAR a non-nil `risky-local-variable' property."
69e018a7 161 (declare (debug (symbolp lambda-expr)))
21622c6d
SM
162 (let ((str (make-symbol "string")))
163 `(completion-table-dynamic
164 (lambda (,str)
165 (when (functionp ,var)
166 (setq ,var (,fun)))
167 ,var))))
168
169(defun completion-table-with-context (prefix table string pred action)
25c0d999 170 ;; TODO: add `suffix' maybe?
a38313e1 171 ;; Notice that `pred' may not be a function in some abusive cases.
34200787
SM
172 (when (functionp pred)
173 (setq pred
174 (lexical-let ((pred pred))
175 ;; Predicates are called differently depending on the nature of
176 ;; the completion table :-(
177 (cond
178 ((vectorp table) ;Obarray.
179 (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
180 ((hash-table-p table)
181 (lambda (s v) (funcall pred (concat prefix s))))
182 ((functionp table)
183 (lambda (s) (funcall pred (concat prefix s))))
184 (t ;Lists and alists.
185 (lambda (s)
186 (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
a38313e1
SM
187 (if (eq (car-safe action) 'boundaries)
188 (let* ((len (length prefix))
f8381803
SM
189 (bound (completion-boundaries string table pred (cdr action))))
190 (list* 'boundaries (+ (car bound) len) (cdr bound)))
a38313e1
SM
191 (let ((comp (complete-with-action action table string pred)))
192 (cond
193 ;; In case of try-completion, add the prefix.
194 ((stringp comp) (concat prefix comp))
a38313e1 195 (t comp)))))
21622c6d
SM
196
197(defun completion-table-with-terminator (terminator table string pred action)
528c56e2
SM
198 "Construct a completion table like TABLE but with an extra TERMINATOR.
199This is meant to be called in a curried way by first passing TERMINATOR
200and TABLE only (via `apply-partially').
201TABLE is a completion table, and TERMINATOR is a string appended to TABLE's
202completion if it is complete. TERMINATOR is also used to determine the
203completion suffix's boundary."
25c0d999 204 (cond
528c56e2
SM
205 ((eq (car-safe action) 'boundaries)
206 (let* ((suffix (cdr action))
207 (bounds (completion-boundaries string table pred suffix))
208 (max (string-match (regexp-quote terminator) suffix)))
209 (list* 'boundaries (car bounds)
210 (min (cdr bounds) (or max (length suffix))))))
25c0d999
SM
211 ((eq action nil)
212 (let ((comp (try-completion string table pred)))
88893215
SM
213 (if (eq comp t)
214 (concat string terminator)
215 (if (and (stringp comp)
528c56e2
SM
216 ;; FIXME: Try to avoid this second call, especially since
217 ;; it may be very inefficient (because `comp' made us
218 ;; jump to a new boundary, so we complete in that
219 ;; boundary with an empty start string).
220 ;; completion-boundaries might help.
25c0d999 221 (eq (try-completion comp table pred) t))
88893215 222 (concat comp terminator)
25c0d999 223 comp))))
a38313e1
SM
224 ((eq action t)
225 ;; FIXME: We generally want the `try' and `all' behaviors to be
226 ;; consistent so pcm can merge the `all' output to get the `try' output,
227 ;; but that sometimes clashes with the need for `all' output to look
228 ;; good in *Completions*.
125f7951
SM
229 ;; (mapcar (lambda (s) (concat s terminator))
230 ;; (all-completions string table pred))))
a38313e1 231 (all-completions string table pred))
25c0d999
SM
232 ;; completion-table-with-terminator is always used for
233 ;; "sub-completions" so it's only called if the terminator is missing,
234 ;; in which case `test-completion' should return nil.
235 ((eq action 'lambda) nil)))
236
237(defun completion-table-with-predicate (table pred1 strict string pred2 action)
238 "Make a completion table equivalent to TABLE but filtered through PRED1.
cf43708e 239PRED1 is a function of one argument which returns non-nil if and only if the
25c0d999
SM
240argument is an element of TABLE which should be considered for completion.
241STRING, PRED2, and ACTION are the usual arguments to completion tables,
242as described in `try-completion', `all-completions', and `test-completion'.
3911966b
SM
243If STRICT is t, the predicate always applies; if nil it only applies if
244it does not reduce the set of possible completions to nothing.
25c0d999
SM
245Note: TABLE needs to be a proper completion table which obeys predicates."
246 (cond
247 ((and (not strict) (eq action 'lambda))
248 ;; Ignore pred1 since it doesn't really have to apply anyway.
af48580e 249 (test-completion string table pred2))
25c0d999
SM
250 (t
251 (or (complete-with-action action table string
252 (if (null pred2) pred1
253 (lexical-let ((pred1 pred2) (pred2 pred2))
254 (lambda (x)
255 ;; Call `pred1' first, so that `pred2'
256 ;; really can't tell that `x' is in table.
257 (if (funcall pred1 x) (funcall pred2 x))))))
258 ;; If completion failed and we're not applying pred1 strictly, try
259 ;; again without pred1.
260 (and (not strict)
261 (complete-with-action action table string pred2))))))
21622c6d 262
e2947429
SM
263(defun completion-table-in-turn (&rest tables)
264 "Create a completion table that tries each table in TABLES in turn."
528c56e2
SM
265 ;; FIXME: the boundaries may come from TABLE1 even when the completion list
266 ;; is returned by TABLE2 (because TABLE1 returned an empty list).
e2947429 267 (lexical-let ((tables tables))
21622c6d 268 (lambda (string pred action)
e2947429
SM
269 (completion--some (lambda (table)
270 (complete-with-action action table string pred))
271 tables))))
272
25c0d999
SM
273;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
274;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
e2947429
SM
275(define-obsolete-function-alias
276 'complete-in-turn 'completion-table-in-turn "23.1")
25c0d999
SM
277(define-obsolete-function-alias
278 'dynamic-completion-table 'completion-table-dynamic "23.1")
21622c6d
SM
279
280;;; Minibuffer completion
281
ba5ff07b
SM
282(defgroup minibuffer nil
283 "Controlling the behavior of the minibuffer."
284 :link '(custom-manual "(emacs)Minibuffer")
285 :group 'environment)
286
32bae13c
SM
287(defun minibuffer-message (message &rest args)
288 "Temporarily display MESSAGE at the end of the minibuffer.
289The text is displayed for `minibuffer-message-timeout' seconds,
290or until the next input event arrives, whichever comes first.
291Enclose MESSAGE in [...] if this is not yet the case.
292If ARGS are provided, then pass MESSAGE through `format'."
ab22be48
SM
293 (if (not (minibufferp (current-buffer)))
294 (progn
295 (if args
296 (apply 'message message args)
297 (message "%s" message))
298 (prog1 (sit-for (or minibuffer-message-timeout 1000000))
299 (message nil)))
300 ;; Clear out any old echo-area message to make way for our new thing.
301 (message nil)
302 (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message))
303 ;; Make sure we can put-text-property.
304 (copy-sequence message)
305 (concat " [" message "]")))
306 (when args (setq message (apply 'format message args)))
307 (let ((ol (make-overlay (point-max) (point-max) nil t t))
308 ;; A quit during sit-for normally only interrupts the sit-for,
309 ;; but since minibuffer-message is used at the end of a command,
310 ;; at a time when the command has virtually finished already, a C-g
311 ;; should really cause an abort-recursive-edit instead (i.e. as if
312 ;; the C-g had been typed at top-level). Binding inhibit-quit here
313 ;; is an attempt to get that behavior.
314 (inhibit-quit t))
315 (unwind-protect
316 (progn
317 (unless (zerop (length message))
318 ;; The current C cursor code doesn't know to use the overlay's
319 ;; marker's stickiness to figure out whether to place the cursor
320 ;; before or after the string, so let's spoon-feed it the pos.
321 (put-text-property 0 1 'cursor t message))
322 (overlay-put ol 'after-string message)
323 (sit-for (or minibuffer-message-timeout 1000000)))
324 (delete-overlay ol)))))
32bae13c
SM
325
326(defun minibuffer-completion-contents ()
327 "Return the user input in a minibuffer before point as a string.
328That is what completion commands operate on."
329 (buffer-substring (field-beginning) (point)))
330
331(defun delete-minibuffer-contents ()
332 "Delete all user input in a minibuffer.
333If the current buffer is not a minibuffer, erase its entire contents."
8c9f211f
CY
334 ;; We used to do `delete-field' here, but when file name shadowing
335 ;; is on, the field doesn't cover the entire minibuffer contents.
336 (delete-region (minibuffer-prompt-end) (point-max)))
32bae13c 337
ba5ff07b
SM
338(defcustom completion-auto-help t
339 "Non-nil means automatically provide help for invalid completion input.
340If the value is t the *Completion* buffer is displayed whenever completion
341is requested but cannot be done.
342If the value is `lazy', the *Completions* buffer is only displayed after
343the second failed attempt to complete."
e1bb0fe5 344 :type '(choice (const nil) (const t) (const lazy))
ba5ff07b
SM
345 :group 'minibuffer)
346
e2947429 347(defvar completion-styles-alist
fcb68f70
SM
348 '((emacs21
349 completion-emacs21-try-completion completion-emacs21-all-completions
350 "Simple prefix-based completion.")
351 (emacs22
352 completion-emacs22-try-completion completion-emacs22-all-completions
353 "Prefix completion that only operates on the text before point.")
354 (basic
355 completion-basic-try-completion completion-basic-all-completions
356 "Completion of the prefix before point and the suffix after point.")
34200787 357 (partial-completion
fcb68f70
SM
358 completion-pcm-try-completion completion-pcm-all-completions
359 "Completion of multiple words, each one taken as a prefix.
360E.g. M-x l-c-h can complete to list-command-history
361and C-x C-f /u/m/s to /usr/monnier/src.")
362 (initials
363 completion-initials-try-completion completion-initials-all-completions
364 "Completion of acronyms and initialisms.
365E.g. can complete M-x lch to list-command-history
366and C-x C-f ~/sew to ~/src/emacs/work."))
e2947429 367 "List of available completion styles.
fcb68f70 368Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC):
26c548b0 369where NAME is the name that should be used in `completion-styles',
fcb68f70
SM
370TRY-COMPLETION is the function that does the completion (it should
371follow the same calling convention as `completion-try-completion'),
372ALL-COMPLETIONS is the function that lists the completions (it should
373follow the calling convention of `completion-all-completions'),
374and DOC describes the way this style of completion works.")
e2947429 375
68b113f6 376(defcustom completion-styles '(basic partial-completion emacs22)
265d4549
SM
377 "List of completion styles to use.
378The available styles are listed in `completion-styles-alist'."
e2947429
SM
379 :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
380 completion-styles-alist)))
381 :group 'minibuffer
382 :version "23.1")
383
19c04f39
SM
384(defun completion-try-completion (string table pred point)
385 "Try to complete STRING using completion table TABLE.
386Only the elements of table that satisfy predicate PRED are considered.
387POINT is the position of point within STRING.
388The return value can be either nil to indicate that there is no completion,
389t to indicate that STRING is the only possible completion,
390or a pair (STRING . NEWPOINT) of the completed result string together with
391a new position for point."
fcb68f70
SM
392 (completion--some (lambda (style)
393 (funcall (nth 1 (assq style completion-styles-alist))
394 string table pred point))
395 completion-styles))
e2947429 396
19c04f39
SM
397(defun completion-all-completions (string table pred point)
398 "List the possible completions of STRING in completion table TABLE.
399Only the elements of table that satisfy predicate PRED are considered.
400POINT is the position of point within STRING.
26c548b0 401The return value is a list of completions and may contain the base-size
19c04f39 402in the last `cdr'."
ab22be48
SM
403 ;; FIXME: We need to additionally return completion-extra-size (similar
404 ;; to completion-base-size but for the text after point).
fcb68f70
SM
405 (completion--some (lambda (style)
406 (funcall (nth 2 (assq style completion-styles-alist))
407 string table pred point))
408 completion-styles))
e2947429 409
ba5ff07b
SM
410(defun minibuffer--bitset (modified completions exact)
411 (logior (if modified 4 0)
412 (if completions 2 0)
413 (if exact 1 0)))
414
3911966b 415(defun completion--do-completion (&optional try-completion-function)
32bae13c 416 "Do the completion and return a summary of what happened.
ba5ff07b
SM
417M = completion was performed, the text was Modified.
418C = there were available Completions.
419E = after completion we now have an Exact match.
420
421 MCE
422 000 0 no possible completion
423 001 1 was already an exact and unique completion
424 010 2 no completion happened
425 011 3 was already an exact completion
426 100 4 ??? impossible
427 101 5 ??? impossible
428 110 6 some completion happened
429 111 7 completed to an exact completion"
430 (let* ((beg (field-beginning))
19c04f39 431 (end (field-end))
3911966b 432 (string (buffer-substring beg end))
19c04f39
SM
433 (comp (funcall (or try-completion-function
434 'completion-try-completion)
435 string
436 minibuffer-completion-table
437 minibuffer-completion-predicate
438 (- (point) beg))))
32bae13c 439 (cond
19c04f39 440 ((null comp)
890429cc 441 (minibuffer-hide-completions)
ba5ff07b 442 (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
265d4549 443 ((eq t comp)
890429cc 444 (minibuffer-hide-completions)
265d4549
SM
445 (goto-char (field-end))
446 (minibuffer--bitset nil nil t)) ;Exact and unique match.
32bae13c
SM
447 (t
448 ;; `completed' should be t if some completion was done, which doesn't
449 ;; include simply changing the case of the entered string. However,
450 ;; for appearance, the string is rewritten if the case changes.
19c04f39
SM
451 (let* ((comp-pos (cdr comp))
452 (completion (car comp))
453 (completed (not (eq t (compare-strings completion nil nil
454 string nil nil t))))
3911966b
SM
455 (unchanged (eq t (compare-strings completion nil nil
456 string nil nil nil))))
32bae13c 457 (unless unchanged
ba5ff07b
SM
458
459 ;; Insert in minibuffer the chars we got.
3911966b
SM
460 (goto-char end)
461 (insert completion)
81ff9458
SM
462 (delete-region beg end))
463 ;; Move point.
464 (goto-char (+ beg comp-pos))
ba5ff07b 465
32bae13c
SM
466 (if (not (or unchanged completed))
467 ;; The case of the string changed, but that's all. We're not sure
468 ;; whether this is a unique completion or not, so try again using
469 ;; the real case (this shouldn't recurse again, because the next
470 ;; time try-completion will return either t or the exact string).
3911966b 471 (completion--do-completion try-completion-function)
32bae13c
SM
472
473 ;; It did find a match. Do we match some possibility exactly now?
19c04f39 474 (let ((exact (test-completion completion
32bae13c
SM
475 minibuffer-completion-table
476 minibuffer-completion-predicate)))
890429cc
SM
477 (if completed
478 ;; We could also decide to refresh the completions,
479 ;; if they're displayed (and assuming there are
480 ;; completions left).
481 (minibuffer-hide-completions)
ba5ff07b
SM
482 ;; Show the completion table, if requested.
483 (cond
484 ((not exact)
485 (if (case completion-auto-help
486 (lazy (eq this-command last-command))
487 (t completion-auto-help))
488 (minibuffer-completion-help)
489 (minibuffer-message "Next char not unique")))
890429cc
SM
490 ;; If the last exact completion and this one were the same, it
491 ;; means we've already given a "Next char not unique" message
492 ;; and the user's hit TAB again, so now we give him help.
ba5ff07b
SM
493 ((eq this-command last-command)
494 (if completion-auto-help (minibuffer-completion-help)))))
495
496 (minibuffer--bitset completed t exact))))))))
32bae13c
SM
497
498(defun minibuffer-complete ()
499 "Complete the minibuffer contents as far as possible.
500Return nil if there is no valid completion, else t.
501If no characters can be completed, display a list of possible completions.
502If you repeat this command after it displayed such a list,
503scroll the window of possible completions."
504 (interactive)
505 ;; If the previous command was not this,
506 ;; mark the completion buffer obsolete.
507 (unless (eq this-command last-command)
508 (setq minibuffer-scroll-window nil))
509
510 (let ((window minibuffer-scroll-window))
511 ;; If there's a fresh completion window with a live buffer,
512 ;; and this command is repeated, scroll that window.
513 (if (window-live-p window)
514 (with-current-buffer (window-buffer window)
515 (if (pos-visible-in-window-p (point-max) window)
516 ;; If end is in view, scroll up to the beginning.
517 (set-window-start window (point-min) nil)
518 ;; Else scroll down one screen.
519 (scroll-other-window))
520 nil)
521
3911966b 522 (case (completion--do-completion)
a38313e1 523 (#b000 nil)
265d4549 524 (#b001 (minibuffer-message "Sole completion")
a38313e1 525 t)
265d4549 526 (#b011 (minibuffer-message "Complete, but not unique")
a38313e1
SM
527 t)
528 (t t)))))
32bae13c 529
14c24780
SM
530(defvar completion-all-sorted-completions nil)
531(make-variable-buffer-local 'completion-all-sorted-completions)
532
533(defun completion--flush-all-sorted-completions (&rest ignore)
534 (setq completion-all-sorted-completions nil))
535
536(defun completion-all-sorted-completions ()
537 (or completion-all-sorted-completions
538 (let* ((start (field-beginning))
539 (end (field-end))
540 (all (completion-all-completions (buffer-substring start end)
541 minibuffer-completion-table
542 minibuffer-completion-predicate
543 (- (point) start)))
544 (last (last all))
545 (base-size (or (cdr last) 0)))
546 (when last
547 (setcdr last nil)
548 ;; Prefer shorter completions.
549 (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
550 ;; Prefer recently used completions.
551 (let ((hist (symbol-value minibuffer-history-variable)))
552 (setq all (sort all (lambda (c1 c2)
553 (> (length (member c1 hist))
554 (length (member c2 hist)))))))
555 ;; Cache the result. This is not just for speed, but also so that
556 ;; repeated calls to minibuffer-force-complete can cycle through
557 ;; all possibilities.
558 (add-hook 'after-change-functions
559 'completion--flush-all-sorted-completions nil t)
560 (setq completion-all-sorted-completions
561 (nconc all base-size))))))
562
563(defun minibuffer-force-complete ()
564 "Complete the minibuffer to an exact match.
565Repeated uses step through the possible completions."
566 (interactive)
567 ;; FIXME: Need to deal with the extra-size issue here as well.
528c56e2
SM
568 ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
569 ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
14c24780
SM
570 (let* ((start (field-beginning))
571 (end (field-end))
572 (all (completion-all-sorted-completions)))
573 (if (not (consp all))
574 (minibuffer-message (if all "No more completions" "No completions"))
575 (goto-char end)
576 (insert (car all))
577 (delete-region (+ start (cdr (last all))) end)
578 ;; If completing file names, (car all) may be a directory, so we'd now
579 ;; have a new set of possible completions and might want to reset
580 ;; completion-all-sorted-completions to nil, but we prefer not to,
581 ;; so that repeated calls minibuffer-force-complete still cycle
582 ;; through the previous possible completions.
075518b5
SM
583 (let ((last (last all)))
584 (setcdr last (cons (car all) (cdr last)))
585 (setq completion-all-sorted-completions (cdr all))))))
14c24780 586
d1826585 587(defvar minibuffer-confirm-exit-commands
a25c543a 588 '(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word)
d1826585
MB
589 "A list of commands which cause an immediately following
590`minibuffer-complete-and-exit' to ask for extra confirmation.")
591
32bae13c 592(defun minibuffer-complete-and-exit ()
bec1e8a5
CY
593 "Exit if the minibuffer contains a valid completion.
594Otherwise, try to complete the minibuffer contents. If
595completion leads to a valid completion, a repetition of this
596command will exit.
597
598If `minibuffer-completion-confirm' is `confirm', do not try to
599 complete; instead, ask for confirmation and accept any input if
600 confirmed.
601If `minibuffer-completion-confirm' is `confirm-after-completion',
602 do not try to complete; instead, ask for confirmation if the
90810a8e
CY
603 preceding minibuffer command was a member of
604 `minibuffer-confirm-exit-commands', and accept the input
605 otherwise."
32bae13c 606 (interactive)
3911966b
SM
607 (let ((beg (field-beginning))
608 (end (field-end)))
609 (cond
610 ;; Allow user to specify null string
611 ((= beg end) (exit-minibuffer))
612 ((test-completion (buffer-substring beg end)
613 minibuffer-completion-table
614 minibuffer-completion-predicate)
615 (when completion-ignore-case
616 ;; Fixup case of the field, if necessary.
b0a5a021 617 (let* ((string (buffer-substring beg end))
3911966b
SM
618 (compl (try-completion
619 string
620 minibuffer-completion-table
621 minibuffer-completion-predicate)))
622 (when (and (stringp compl)
623 ;; If it weren't for this piece of paranoia, I'd replace
624 ;; the whole thing with a call to do-completion.
eee6de73
SM
625 ;; This is important, e.g. when the current minibuffer's
626 ;; content is a directory which only contains a single
627 ;; file, so `try-completion' actually completes to
628 ;; that file.
3911966b 629 (= (length string) (length compl)))
32bae13c
SM
630 (goto-char end)
631 (insert compl)
3911966b
SM
632 (delete-region beg end))))
633 (exit-minibuffer))
32bae13c 634
bec1e8a5 635 ((eq minibuffer-completion-confirm 'confirm)
3911966b 636 ;; The user is permitted to exit with an input that's rejected
bec1e8a5 637 ;; by test-completion, after confirming her choice.
3911966b
SM
638 (if (eq last-command this-command)
639 (exit-minibuffer)
640 (minibuffer-message "Confirm")
641 nil))
32bae13c 642
bec1e8a5
CY
643 ((eq minibuffer-completion-confirm 'confirm-after-completion)
644 ;; Similar to the above, but only if trying to exit immediately
645 ;; after typing TAB (this catches most minibuffer typos).
d1826585 646 (if (memq last-command minibuffer-confirm-exit-commands)
bec1e8a5
CY
647 (progn (minibuffer-message "Confirm")
648 nil)
649 (exit-minibuffer)))
650
3911966b
SM
651 (t
652 ;; Call do-completion, but ignore errors.
653 (case (condition-case nil
654 (completion--do-completion)
655 (error 1))
a38313e1
SM
656 ((#b001 #b011) (exit-minibuffer))
657 (#b111 (if (not minibuffer-completion-confirm)
658 (exit-minibuffer)
659 (minibuffer-message "Confirm")
660 nil))
3911966b
SM
661 (t nil))))))
662
19c04f39
SM
663(defun completion--try-word-completion (string table predicate point)
664 (let ((comp (completion-try-completion string table predicate point)))
665 (if (not (consp comp))
666 comp
32bae13c 667
3911966b
SM
668 ;; If completion finds next char not unique,
669 ;; consider adding a space or a hyphen.
19c04f39 670 (when (= (length string) (length (car comp)))
1afbbf85
SM
671 ;; Mark the added char with the `completion-word' property, so it
672 ;; can be handled specially by completion styles such as
673 ;; partial-completion.
674 ;; We used to remove `partial-completion' from completion-styles
675 ;; instead, but it was too blunt, leading to situations where SPC
676 ;; was the only insertable char at point but minibuffer-complete-word
677 ;; refused inserting it.
678 (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t))
679 '(" " "-")))
19c04f39
SM
680 (before (substring string 0 point))
681 (after (substring string point))
682 tem)
683 (while (and exts (not (consp tem)))
3911966b 684 (setq tem (completion-try-completion
19c04f39
SM
685 (concat before (pop exts) after)
686 table predicate (1+ point))))
687 (if (consp tem) (setq comp tem))))
3911966b 688
32bae13c
SM
689 ;; Completing a single word is actually more difficult than completing
690 ;; as much as possible, because we first have to find the "current
691 ;; position" in `completion' in order to find the end of the word
692 ;; we're completing. Normally, `string' is a prefix of `completion',
693 ;; which makes it trivial to find the position, but with fancier
694 ;; completion (plus env-var expansion, ...) `completion' might not
695 ;; look anything like `string' at all.
19c04f39
SM
696 (let* ((comppoint (cdr comp))
697 (completion (car comp))
698 (before (substring string 0 point))
699 (combined (concat before "\n" completion)))
700 ;; Find in completion the longest text that was right before point.
701 (when (string-match "\\(.+\\)\n.*?\\1" combined)
702 (let* ((prefix (match-string 1 before))
703 ;; We used non-greedy match to make `rem' as long as possible.
704 (rem (substring combined (match-end 0)))
705 ;; Find in the remainder of completion the longest text
706 ;; that was right after point.
707 (after (substring string point))
708 (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1"
709 (concat after "\n" rem))
710 (match-string 1 after))))
711 ;; The general idea is to try and guess what text was inserted
712 ;; at point by the completion. Problem is: if we guess wrong,
713 ;; we may end up treating as "added by completion" text that was
714 ;; actually painfully typed by the user. So if we then cut
715 ;; after the first word, we may throw away things the
716 ;; user wrote. So let's try to be as conservative as possible:
717 ;; only cut after the first word, if we're reasonably sure that
718 ;; our guess is correct.
719 ;; Note: a quick survey on emacs-devel seemed to indicate that
720 ;; nobody actually cares about the "word-at-a-time" feature of
721 ;; minibuffer-complete-word, whose real raison-d'être is that it
722 ;; tries to add "-" or " ". One more reason to only cut after
723 ;; the first word, if we're really sure we're right.
724 (when (and (or suffix (zerop (length after)))
725 (string-match (concat
726 ;; Make submatch 1 as small as possible
727 ;; to reduce the risk of cutting
728 ;; valuable text.
729 ".*" (regexp-quote prefix) "\\(.*?\\)"
730 (if suffix (regexp-quote suffix) "\\'"))
731 completion)
732 ;; The new point in `completion' should also be just
733 ;; before the suffix, otherwise something more complex
734 ;; is going on, and we're not sure where we are.
735 (eq (match-end 1) comppoint)
736 ;; (match-beginning 1)..comppoint is now the stretch
737 ;; of text in `completion' that was completed at point.
738 (string-match "\\W" completion (match-beginning 1))
739 ;; Is there really something to cut?
740 (> comppoint (match-end 0)))
741 ;; Cut after the first word.
742 (let ((cutpos (match-end 0)))
743 (setq completion (concat (substring completion 0 cutpos)
744 (substring completion comppoint)))
745 (setq comppoint cutpos)))))
746
747 (cons completion comppoint)))))
ba5ff07b
SM
748
749
750(defun minibuffer-complete-word ()
751 "Complete the minibuffer contents at most a single word.
752After one word is completed as much as possible, a space or hyphen
753is added, provided that matches some possible completion.
754Return nil if there is no valid completion, else t."
755 (interactive)
3911966b 756 (case (completion--do-completion 'completion--try-word-completion)
a38313e1 757 (#b000 nil)
265d4549 758 (#b001 (minibuffer-message "Sole completion")
a38313e1 759 t)
265d4549 760 (#b011 (minibuffer-message "Complete, but not unique")
a38313e1
SM
761 t)
762 (t t)))
ba5ff07b 763
890429cc
SM
764(defface completions-annotations '((t :inherit italic))
765 "Face to use for annotations in the *Completions* buffer.")
766
3911966b 767(defun completion--insert-strings (strings)
32bae13c
SM
768 "Insert a list of STRINGS into the current buffer.
769Uses columns to keep the listing readable but compact.
770It also eliminates runs of equal strings."
771 (when (consp strings)
772 (let* ((length (apply 'max
773 (mapcar (lambda (s)
774 (if (consp s)
e5b5b82d
SM
775 (+ (string-width (car s))
776 (string-width (cadr s)))
777 (string-width s)))
32bae13c
SM
778 strings)))
779 (window (get-buffer-window (current-buffer) 0))
780 (wwidth (if window (1- (window-width window)) 79))
781 (columns (min
782 ;; At least 2 columns; at least 2 spaces between columns.
783 (max 2 (/ wwidth (+ 2 length)))
784 ;; Don't allocate more columns than we can fill.
785 ;; Windows can't show less than 3 lines anyway.
786 (max 1 (/ (length strings) 2))))
787 (colwidth (/ wwidth columns))
788 (column 0)
789 (laststring nil))
790 ;; The insertion should be "sensible" no matter what choices were made
791 ;; for the parameters above.
792 (dolist (str strings)
f87ff539 793 (unless (equal laststring str) ; Remove (consecutive) duplicates.
32bae13c 794 (setq laststring str)
f87ff539
SM
795 (let ((length (if (consp str)
796 (+ (string-width (car str))
797 (string-width (cadr str)))
798 (string-width str))))
799 (unless (bolp)
800 (if (< wwidth (+ (max colwidth length) column))
801 ;; No space for `str' at point, move to next line.
802 (progn (insert "\n") (setq column 0))
803 (insert " \t")
804 ;; Leave the space unpropertized so that in the case we're
805 ;; already past the goal column, there is still
806 ;; a space displayed.
807 (set-text-properties (- (point) 1) (point)
808 ;; We can't just set tab-width, because
809 ;; completion-setup-function will kill all
810 ;; local variables :-(
811 `(display (space :align-to ,column)))
812 nil))
813 (if (not (consp str))
814 (put-text-property (point) (progn (insert str) (point))
815 'mouse-face 'highlight)
816 (put-text-property (point) (progn (insert (car str)) (point))
817 'mouse-face 'highlight)
890429cc
SM
818 (add-text-properties (point) (progn (insert (cadr str)) (point))
819 '(mouse-face nil
820 face completions-annotations)))
f87ff539
SM
821 ;; Next column to align to.
822 (setq column (+ column
823 ;; Round up to a whole number of columns.
824 (* colwidth (ceiling length colwidth))))))))))
32bae13c 825
6138158d
SM
826(defvar completion-common-substring nil)
827(make-obsolete-variable 'completion-common-substring nil "23.1")
32bae13c 828
21622c6d
SM
829(defvar completion-setup-hook nil
830 "Normal hook run at the end of setting up a completion list buffer.
831When this hook is run, the current buffer is the one in which the
832command to display the completion list buffer was run.
833The completion list buffer is available as the value of `standard-output'.
6138158d
SM
834See also `display-completion-list'.")
835
836(defface completions-first-difference
837 '((t (:inherit bold)))
838 "Face put on the first uncommon character in completions in *Completions* buffer."
839 :group 'completion)
840
841(defface completions-common-part
842 '((t (:inherit default)))
843 "Face put on the common prefix substring in completions in *Completions* buffer.
844The idea of `completions-common-part' is that you can use it to
845make the common parts less visible than normal, so that the rest
846of the differing parts is, by contrast, slightly highlighted."
847 :group 'completion)
848
125f7951 849(defun completion-hilit-commonality (completions prefix-len base-size)
6138158d 850 (when completions
125f7951 851 (let ((com-str-len (- prefix-len (or base-size 0))))
6138158d
SM
852 (nconc
853 (mapcar
457d37ba
SM
854 (lambda (elem)
855 (let ((str
856 ;; Don't modify the string itself, but a copy, since the
857 ;; the string may be read-only or used for other purposes.
858 ;; Furthermore, since `completions' may come from
859 ;; display-completion-list, `elem' may be a list.
860 (if (consp elem)
861 (car (setq elem (cons (copy-sequence (car elem))
862 (cdr elem))))
863 (setq elem (copy-sequence elem)))))
1bba1cfc
SM
864 (put-text-property 0
865 ;; If completion-boundaries returns incorrect
866 ;; values, all-completions may return strings
867 ;; that don't contain the prefix.
868 (min com-str-len (length str))
457d37ba
SM
869 'font-lock-face 'completions-common-part
870 str)
871 (if (> (length str) com-str-len)
872 (put-text-property com-str-len (1+ com-str-len)
873 'font-lock-face 'completions-first-difference
874 str)))
875 elem)
6138158d
SM
876 completions)
877 base-size))))
21622c6d 878
7bc7f64d 879(defun display-completion-list (completions &optional common-substring)
32bae13c
SM
880 "Display the list of completions, COMPLETIONS, using `standard-output'.
881Each element may be just a symbol or string
882or may be a list of two strings to be printed as if concatenated.
883If it is a list of two strings, the first is the actual completion
884alternative, the second serves as annotation.
885`standard-output' must be a buffer.
886The actual completion alternatives, as inserted, are given `mouse-face'
887properties of `highlight'.
888At the end, this runs the normal hook `completion-setup-hook'.
889It can find the completion buffer in `standard-output'.
7ce8dff2 890
72444d02 891The obsolete optional arg COMMON-SUBSTRING, if non-nil, should be a string
7ce8dff2
CY
892specifying a common substring for adding the faces
893`completions-first-difference' and `completions-common-part' to
7bc7f64d 894the completions buffer."
6138158d
SM
895 (if common-substring
896 (setq completions (completion-hilit-commonality
125f7951
SM
897 completions (length common-substring)
898 ;; We don't know the base-size.
899 nil)))
32bae13c
SM
900 (if (not (bufferp standard-output))
901 ;; This *never* (ever) happens, so there's no point trying to be clever.
902 (with-temp-buffer
903 (let ((standard-output (current-buffer))
904 (completion-setup-hook nil))
7bc7f64d 905 (display-completion-list completions common-substring))
32bae13c
SM
906 (princ (buffer-string)))
907
d5e63715
SM
908 (with-current-buffer standard-output
909 (goto-char (point-max))
910 (if (null completions)
911 (insert "There are no possible completions of what you have typed.")
912 (insert "Possible completions are:\n")
913 (completion--insert-strings completions))))
e2947429 914
6138158d
SM
915 ;; The hilit used to be applied via completion-setup-hook, so there
916 ;; may still be some code that uses completion-common-substring.
7ce8dff2
CY
917 (with-no-warnings
918 (let ((completion-common-substring common-substring))
919 (run-hooks 'completion-setup-hook)))
32bae13c
SM
920 nil)
921
ab22be48
SM
922(defvar completion-annotate-function
923 nil
924 ;; Note: there's a lot of scope as for when to add annotations and
925 ;; what annotations to add. E.g. completing-help.el allowed adding
926 ;; the first line of docstrings to M-x completion. But there's
927 ;; a tension, since such annotations, while useful at times, can
928 ;; actually drown the useful information.
929 ;; So completion-annotate-function should be used parsimoniously, or
930 ;; else only used upon a user's request (e.g. we could add a command
931 ;; to completion-list-mode to add annotations to the current
932 ;; completions).
933 "Function to add annotations in the *Completions* buffer.
934The function takes a completion and should either return nil, or a string that
935will be displayed next to the completion. The function can access the
936completion table and predicates via `minibuffer-completion-table' and related
937variables.")
938
32bae13c
SM
939(defun minibuffer-completion-help ()
940 "Display a list of possible completions of the current minibuffer contents."
941 (interactive)
942 (message "Making completion list...")
d5e63715
SM
943 (let* ((start (field-beginning))
944 (string (field-string))
3911966b 945 (completions (completion-all-completions
32bae13c
SM
946 string
947 minibuffer-completion-table
19c04f39
SM
948 minibuffer-completion-predicate
949 (- (point) (field-beginning)))))
32bae13c
SM
950 (message nil)
951 (if (and completions
e2947429
SM
952 (or (consp (cdr completions))
953 (not (equal (car completions) string))))
32bae13c 954 (with-output-to-temp-buffer "*Completions*"
e2947429
SM
955 (let* ((last (last completions))
956 (base-size (cdr last)))
957 ;; Remove the base-size tail because `sort' requires a properly
958 ;; nil-terminated list.
959 (when last (setcdr last nil))
ab22be48
SM
960 (setq completions (sort completions 'string-lessp))
961 (when completion-annotate-function
962 (setq completions
963 (mapcar (lambda (s)
964 (let ((ann
965 (funcall completion-annotate-function s)))
966 (if ann (list s ann) s)))
967 completions)))
d5e63715
SM
968 (with-current-buffer standard-output
969 (set (make-local-variable 'completion-base-position)
970 ;; FIXME: We should provide the END part as well, but
971 ;; currently completion-all-completions does not give
972 ;; us the necessary information.
973 (list (+ start base-size) nil)))
974 (display-completion-list completions)))
32bae13c
SM
975
976 ;; If there are no completions, or if the current input is already the
977 ;; only possible completion, then hide (previous&stale) completions.
978 (let ((window (and (get-buffer "*Completions*")
979 (get-buffer-window "*Completions*" 0))))
980 (when (and (window-live-p window) (window-dedicated-p window))
981 (condition-case ()
982 (delete-window window)
983 (error (iconify-frame (window-frame window))))))
984 (ding)
985 (minibuffer-message
986 (if completions "Sole completion" "No completions")))
987 nil))
988
890429cc
SM
989(defun minibuffer-hide-completions ()
990 "Get rid of an out-of-date *Completions* buffer."
991 ;; FIXME: We could/should use minibuffer-scroll-window here, but it
992 ;; can also point to the minibuffer-parent-window, so it's a bit tricky.
993 (let ((win (get-buffer-window "*Completions*" 0)))
994 (if win (with-selected-window win (bury-buffer)))))
995
32bae13c
SM
996(defun exit-minibuffer ()
997 "Terminate this minibuffer argument."
998 (interactive)
999 ;; If the command that uses this has made modifications in the minibuffer,
1000 ;; we don't want them to cause deactivation of the mark in the original
1001 ;; buffer.
1002 ;; A better solution would be to make deactivate-mark buffer-local
1003 ;; (or to turn it into a list of buffers, ...), but in the mean time,
1004 ;; this should do the trick in most cases.
ba5ff07b 1005 (setq deactivate-mark nil)
32bae13c
SM
1006 (throw 'exit nil))
1007
1008(defun self-insert-and-exit ()
1009 "Terminate minibuffer input."
1010 (interactive)
8989a920 1011 (if (characterp last-command-event)
32bae13c
SM
1012 (call-interactively 'self-insert-command)
1013 (ding))
1014 (exit-minibuffer))
1015
a38313e1
SM
1016;;; Key bindings.
1017
8ba31f36
SM
1018(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
1019 'minibuffer-local-filename-must-match-map "23.1")
1020
a38313e1
SM
1021(let ((map minibuffer-local-map))
1022 (define-key map "\C-g" 'abort-recursive-edit)
1023 (define-key map "\r" 'exit-minibuffer)
1024 (define-key map "\n" 'exit-minibuffer))
1025
1026(let ((map minibuffer-local-completion-map))
1027 (define-key map "\t" 'minibuffer-complete)
14c24780
SM
1028 ;; M-TAB is already abused for many other purposes, so we should find
1029 ;; another binding for it.
1030 ;; (define-key map "\e\t" 'minibuffer-force-complete)
a38313e1
SM
1031 (define-key map " " 'minibuffer-complete-word)
1032 (define-key map "?" 'minibuffer-completion-help))
1033
1034(let ((map minibuffer-local-must-match-map))
1035 (define-key map "\r" 'minibuffer-complete-and-exit)
1036 (define-key map "\n" 'minibuffer-complete-and-exit))
1037
1038(let ((map minibuffer-local-filename-completion-map))
1039 (define-key map " " nil))
8ba31f36 1040(let ((map minibuffer-local-filename-must-match-map))
a38313e1
SM
1041 (define-key map " " nil))
1042
1043(let ((map minibuffer-local-ns-map))
1044 (define-key map " " 'exit-minibuffer)
1045 (define-key map "\t" 'exit-minibuffer)
1046 (define-key map "?" 'self-insert-and-exit))
1047
1048;;; Completion tables.
1049
34b67b0f
SM
1050(defun minibuffer--double-dollars (str)
1051 (replace-regexp-in-string "\\$" "$$" str))
1052
21622c6d
SM
1053(defun completion--make-envvar-table ()
1054 (mapcar (lambda (enventry)
9f3618b5 1055 (substring enventry 0 (string-match-p "=" enventry)))
21622c6d
SM
1056 process-environment))
1057
a38313e1
SM
1058(defconst completion--embedded-envvar-re
1059 (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
1060 "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
1061
21622c6d 1062(defun completion--embedded-envvar-table (string pred action)
528c56e2
SM
1063 (when (string-match completion--embedded-envvar-re string)
1064 (let* ((beg (or (match-beginning 2) (match-beginning 1)))
1065 (table (completion--make-envvar-table))
1066 (prefix (substring string 0 beg)))
1067 (if (eq (car-safe action) 'boundaries)
1068 ;; Only return boundaries if there's something to complete,
1069 ;; since otherwise when we're used in
1070 ;; completion-table-in-turn, we could return boundaries and
1071 ;; let some subsequent table return a list of completions.
1072 ;; FIXME: Maybe it should rather be fixed in
1073 ;; completion-table-in-turn instead, but it's difficult to
1074 ;; do it efficiently there.
1075 (when (try-completion prefix table pred)
1076 ;; Compute the boundaries of the subfield to which this
1077 ;; completion applies.
1078 (let ((suffix (cdr action)))
1079 (list* 'boundaries
1080 (or (match-beginning 2) (match-beginning 1))
1081 (when (string-match "[^[:alnum:]_]" suffix)
1082 (match-beginning 0)))))
a38313e1
SM
1083 (if (eq (aref string (1- beg)) ?{)
1084 (setq table (apply-partially 'completion-table-with-terminator
1085 "}" table)))
ab22be48
SM
1086 ;; Even if file-name completion is case-insensitive, we want
1087 ;; envvar completion to be case-sensitive.
1088 (let ((completion-ignore-case nil))
1089 (completion-table-with-context
1090 prefix table (substring string beg) pred action))))))
017c22fe 1091
528c56e2
SM
1092(defun completion-file-name-table (string pred action)
1093 "Completion table for file names."
1094 (ignore-errors
a38313e1 1095 (cond
a38313e1 1096 ((eq (car-safe action) 'boundaries)
f8381803 1097 (let ((start (length (file-name-directory string)))
9f3618b5 1098 (end (string-match-p "/" (cdr action))))
a38313e1 1099 (list* 'boundaries start end)))
d9aa6b33 1100
528c56e2
SM
1101 ((eq action 'lambda)
1102 (if (zerop (length string))
1103 nil ;Not sure why it's here, but it probably doesn't harm.
1104 (funcall (or pred 'file-exists-p) string)))
1105
a38313e1 1106 (t
528c56e2
SM
1107 (let* ((name (file-name-nondirectory string))
1108 (specdir (file-name-directory string))
1109 (realdir (or specdir default-directory)))
017c22fe 1110
34b67b0f
SM
1111 (cond
1112 ((null action)
528c56e2
SM
1113 (let ((comp (file-name-completion name realdir pred)))
1114 (if (stringp comp)
1115 (concat specdir comp)
1116 comp)))
017c22fe 1117
34b67b0f 1118 ((eq action t)
125f7951 1119 (let ((all (file-name-all-completions name realdir)))
e2947429
SM
1120
1121 ;; Check the predicate, if necessary.
528c56e2 1122 (unless (memq pred '(nil file-exists-p))
34b67b0f
SM
1123 (let ((comp ())
1124 (pred
528c56e2 1125 (if (eq pred 'file-directory-p)
34b67b0f
SM
1126 ;; Brute-force speed up for directory checking:
1127 ;; Discard strings which don't end in a slash.
1128 (lambda (s)
1129 (let ((len (length s)))
1130 (and (> len 0) (eq (aref s (1- len)) ?/))))
1131 ;; Must do it the hard (and slow) way.
528c56e2
SM
1132 pred)))
1133 (let ((default-directory (expand-file-name realdir)))
34b67b0f
SM
1134 (dolist (tem all)
1135 (if (funcall pred tem) (push tem comp))))
e2947429
SM
1136 (setq all (nreverse comp))))
1137
528c56e2
SM
1138 all))))))))
1139
1140(defvar read-file-name-predicate nil
1141 "Current predicate used by `read-file-name-internal'.")
1142(make-obsolete-variable 'read-file-name-predicate
1143 "use the regular PRED argument" "23.2")
1144
1145(defun completion--file-name-table (string pred action)
1146 "Internal subroutine for `read-file-name'. Do not call this.
1147This is a completion table for file names, like `completion-file-name-table'
1148except that it passes the file name through `substitute-in-file-name'."
1149 (cond
1150 ((eq (car-safe action) 'boundaries)
1151 ;; For the boundaries, we can't really delegate to
1152 ;; completion-file-name-table and then fix them up, because it
1153 ;; would require us to track the relationship between `str' and
1154 ;; `string', which is difficult. And in any case, if
1155 ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba", there's
1156 ;; no way for us to return proper boundaries info, because the
1157 ;; boundary is not (yet) in `string'.
1158 (let ((start (length (file-name-directory string)))
1159 (end (string-match-p "/" (cdr action))))
1160 (list* 'boundaries start end)))
34b67b0f
SM
1161
1162 (t
528c56e2
SM
1163 (let* ((default-directory
1164 (if (stringp pred)
1165 ;; It used to be that `pred' was abused to pass `dir'
1166 ;; as an argument.
1167 (prog1 (file-name-as-directory (expand-file-name pred))
1168 (setq pred nil))
1169 default-directory))
1170 (str (condition-case nil
1171 (substitute-in-file-name string)
1172 (error string)))
1173 (comp (completion-file-name-table
1174 str (or pred read-file-name-predicate) action)))
1175
1176 (cond
1177 ((stringp comp)
1178 ;; Requote the $s before returning the completion.
1179 (minibuffer--double-dollars comp))
1180 ((and (null action) comp
1181 ;; Requote the $s before checking for changes.
1182 (setq str (minibuffer--double-dollars str))
1183 (not (string-equal string str)))
1184 ;; If there's no real completion, but substitute-in-file-name
1185 ;; changed the string, then return the new string.
1186 str)
1187 (t comp))))))
34b67b0f 1188
21622c6d 1189(defalias 'read-file-name-internal
017c22fe 1190 (completion-table-in-turn 'completion--embedded-envvar-table
88893215 1191 'completion--file-name-table)
21622c6d 1192 "Internal subroutine for `read-file-name'. Do not call this.")
34b67b0f 1193
dbd50d4b
SM
1194(defvar read-file-name-function nil
1195 "If this is non-nil, `read-file-name' does its work by calling this function.")
1196
dbd50d4b 1197(defcustom read-file-name-completion-ignore-case
9f6336e8 1198 (if (memq system-type '(ms-dos windows-nt darwin cygwin))
dbd50d4b
SM
1199 t nil)
1200 "Non-nil means when reading a file name completion ignores case."
1201 :group 'minibuffer
1202 :type 'boolean
1203 :version "22.1")
1204
1205(defcustom insert-default-directory t
1206 "Non-nil means when reading a filename start with default dir in minibuffer.
1207
1208When the initial minibuffer contents show a name of a file or a directory,
1209typing RETURN without editing the initial contents is equivalent to typing
1210the default file name.
1211
1212If this variable is non-nil, the minibuffer contents are always
1213initially non-empty, and typing RETURN without editing will fetch the
1214default name, if one is provided. Note however that this default name
1215is not necessarily the same as initial contents inserted in the minibuffer,
1216if the initial contents is just the default directory.
1217
1218If this variable is nil, the minibuffer often starts out empty. In
1219that case you may have to explicitly fetch the next history element to
1220request the default name; typing RETURN without editing will leave
1221the minibuffer empty.
1222
1223For some commands, exiting with an empty minibuffer has a special meaning,
1224such as making the current buffer visit no file in the case of
1225`set-visited-file-name'."
1226 :group 'minibuffer
1227 :type 'boolean)
1228
4e3870f5
GM
1229;; Not always defined, but only called if next-read-file-uses-dialog-p says so.
1230(declare-function x-file-dialog "xfns.c"
1231 (prompt dir &optional default-filename mustmatch only-dir-p))
1232
dbd50d4b
SM
1233(defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
1234 "Read file name, prompting with PROMPT and completing in directory DIR.
1235Value is not expanded---you must call `expand-file-name' yourself.
1236Default name to DEFAULT-FILENAME if user exits the minibuffer with
1237the same non-empty string that was inserted by this function.
1238 (If DEFAULT-FILENAME is omitted, the visited file name is used,
1239 except that if INITIAL is specified, that combined with DIR is used.)
1240If the user exits with an empty minibuffer, this function returns
1241an empty string. (This can only happen if the user erased the
1242pre-inserted contents or if `insert-default-directory' is nil.)
846b6eba
CY
1243
1244Fourth arg MUSTMATCH can take the following values:
1245- nil means that the user can exit with any input.
1246- t means that the user is not allowed to exit unless
1247 the input is (or completes to) an existing file.
1248- `confirm' means that the user can exit with any input, but she needs
1249 to confirm her choice if the input is not an existing file.
1250- `confirm-after-completion' means that the user can exit with any
1251 input, but she needs to confirm her choice if she called
1252 `minibuffer-complete' right before `minibuffer-complete-and-exit'
1253 and the input is not an existing file.
1254- anything else behaves like t except that typing RET does not exit if it
1255 does non-null completion.
1256
dbd50d4b 1257Fifth arg INITIAL specifies text to start with.
846b6eba 1258
dbd50d4b
SM
1259If optional sixth arg PREDICATE is non-nil, possible completions and
1260the resulting file name must satisfy (funcall PREDICATE NAME).
1261DIR should be an absolute directory name. It defaults to the value of
1262`default-directory'.
1263
846b6eba
CY
1264If this command was invoked with the mouse, use a graphical file
1265dialog if `use-dialog-box' is non-nil, and the window system or X
1266toolkit in use provides a file dialog box. For graphical file
2aafe808
JR
1267dialogs, any the special values of MUSTMATCH; `confirm' and
1268`confirm-after-completion' are treated as equivalent to nil.
dbd50d4b
SM
1269
1270See also `read-file-name-completion-ignore-case'
1271and `read-file-name-function'."
1272 (unless dir (setq dir default-directory))
1273 (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
1274 (unless default-filename
1275 (setq default-filename (if initial (expand-file-name initial dir)
1276 buffer-file-name)))
1277 ;; If dir starts with user's homedir, change that to ~.
1278 (setq dir (abbreviate-file-name dir))
1279 ;; Likewise for default-filename.
e8a5fe3e
SM
1280 (if default-filename
1281 (setq default-filename (abbreviate-file-name default-filename)))
dbd50d4b
SM
1282 (let ((insdef (cond
1283 ((and insert-default-directory (stringp dir))
1284 (if initial
1285 (cons (minibuffer--double-dollars (concat dir initial))
1286 (length (minibuffer--double-dollars dir)))
1287 (minibuffer--double-dollars dir)))
1288 (initial (cons (minibuffer--double-dollars initial) 0)))))
1289
1290 (if read-file-name-function
1291 (funcall read-file-name-function
1292 prompt dir default-filename mustmatch initial predicate)
e8a5fe3e 1293 (let ((completion-ignore-case read-file-name-completion-ignore-case)
dbd50d4b 1294 (minibuffer-completing-file-name t)
528c56e2 1295 (pred (or predicate 'file-exists-p))
dbd50d4b
SM
1296 (add-to-history nil))
1297
1298 (let* ((val
1299 (if (not (next-read-file-uses-dialog-p))
e8a5fe3e
SM
1300 ;; We used to pass `dir' to `read-file-name-internal' by
1301 ;; abusing the `predicate' argument. It's better to
1302 ;; just use `default-directory', but in order to avoid
1303 ;; changing `default-directory' in the current buffer,
1304 ;; we don't let-bind it.
1305 (lexical-let ((dir (file-name-as-directory
1306 (expand-file-name dir))))
1307 (minibuffer-with-setup-hook
1308 (lambda () (setq default-directory dir))
1309 (completing-read prompt 'read-file-name-internal
528c56e2
SM
1310 pred mustmatch insdef
1311 'file-name-history default-filename)))
6462af0d
JR
1312 ;; If DEFAULT-FILENAME not supplied and DIR contains
1313 ;; a file name, split it.
2aafe808
JR
1314 (let ((file (file-name-nondirectory dir))
1315 ;; When using a dialog, revert to nil and non-nil
1316 ;; interpretation of mustmatch. confirm options
1317 ;; need to be interpreted as nil, otherwise
1318 ;; it is impossible to create new files using
1319 ;; dialogs with the default settings.
1320 (dialog-mustmatch
528c56e2
SM
1321 (not (memq mustmatch
1322 '(nil confirm confirm-after-completion)))))
6462af0d
JR
1323 (when (and (not default-filename)
1324 (not (zerop (length file))))
dbd50d4b
SM
1325 (setq default-filename file)
1326 (setq dir (file-name-directory dir)))
1327 (if default-filename
1328 (setq default-filename
1329 (expand-file-name default-filename dir)))
1330 (setq add-to-history t)
2aafe808
JR
1331 (x-file-dialog prompt dir default-filename
1332 dialog-mustmatch
dbd50d4b
SM
1333 (eq predicate 'file-directory-p)))))
1334
1335 (replace-in-history (eq (car-safe file-name-history) val)))
1336 ;; If completing-read returned the inserted default string itself
1337 ;; (rather than a new string with the same contents),
1338 ;; it has to mean that the user typed RET with the minibuffer empty.
1339 ;; In that case, we really want to return ""
1340 ;; so that commands such as set-visited-file-name can distinguish.
1341 (when (eq val default-filename)
1342 ;; In this case, completing-read has not added an element
1343 ;; to the history. Maybe we should.
1344 (if (not replace-in-history)
1345 (setq add-to-history t))
1346 (setq val ""))
1347 (unless val (error "No file name specified"))
1348
1349 (if (and default-filename
1350 (string-equal val (if (consp insdef) (car insdef) insdef)))
1351 (setq val default-filename))
1352 (setq val (substitute-in-file-name val))
1353
1354 (if replace-in-history
1355 ;; Replace what Fcompleting_read added to the history
7346a407
CY
1356 ;; with what we will actually return. As an exception,
1357 ;; if that's the same as the second item in
1358 ;; file-name-history, it's really a repeat (Bug#4657).
dbd50d4b
SM
1359 (let ((val1 (minibuffer--double-dollars val)))
1360 (if history-delete-duplicates
1361 (setcdr file-name-history
1362 (delete val1 (cdr file-name-history))))
7346a407
CY
1363 (if (string= val1 (cadr file-name-history))
1364 (pop file-name-history)
1365 (setcar file-name-history val1)))
dbd50d4b
SM
1366 (if add-to-history
1367 ;; Add the value to the history--but not if it matches
1368 ;; the last value already there.
1369 (let ((val1 (minibuffer--double-dollars val)))
1370 (unless (and (consp file-name-history)
1371 (equal (car file-name-history) val1))
1372 (setq file-name-history
1373 (cons val1
1374 (if history-delete-duplicates
1375 (delete val1 file-name-history)
1376 file-name-history)))))))
1377 val)))))
1378
8b04c0ae
JL
1379(defun internal-complete-buffer-except (&optional buffer)
1380 "Perform completion on all buffers excluding BUFFER.
e35b3063 1381BUFFER nil or omitted means use the current buffer.
8b04c0ae
JL
1382Like `internal-complete-buffer', but removes BUFFER from the completion list."
1383 (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer))))
1384 (apply-partially 'completion-table-with-predicate
1385 'internal-complete-buffer
1386 (lambda (name)
1387 (not (equal (if (consp name) (car name) name) except)))
1388 nil)))
1389
eee6de73 1390;;; Old-style completion, used in Emacs-21 and Emacs-22.
19c04f39
SM
1391
1392(defun completion-emacs21-try-completion (string table pred point)
1393 (let ((completion (try-completion string table pred)))
1394 (if (stringp completion)
1395 (cons completion (length completion))
1396 completion)))
1397
1398(defun completion-emacs21-all-completions (string table pred point)
6138158d 1399 (completion-hilit-commonality
eee6de73 1400 (all-completions string table pred)
125f7951
SM
1401 (length string)
1402 (car (completion-boundaries string table pred ""))))
19c04f39 1403
19c04f39
SM
1404(defun completion-emacs22-try-completion (string table pred point)
1405 (let ((suffix (substring string point))
1406 (completion (try-completion (substring string 0 point) table pred)))
1407 (if (not (stringp completion))
1408 completion
1409 ;; Merge a trailing / in completion with a / after point.
1410 ;; We used to only do it for word completion, but it seems to make
1411 ;; sense for all completions.
34200787
SM
1412 ;; Actually, claiming this feature was part of Emacs-22 completion
1413 ;; is pushing it a bit: it was only done in minibuffer-completion-word,
1414 ;; which was (by default) not bound during file completion, where such
1415 ;; slashes are most likely to occur.
1416 (if (and (not (zerop (length completion)))
1417 (eq ?/ (aref completion (1- (length completion))))
19c04f39
SM
1418 (not (zerop (length suffix)))
1419 (eq ?/ (aref suffix 0)))
34200787
SM
1420 ;; This leaves point after the / .
1421 (setq suffix (substring suffix 1)))
19c04f39
SM
1422 (cons (concat completion suffix) (length completion)))))
1423
1424(defun completion-emacs22-all-completions (string table pred point)
125f7951
SM
1425 (let ((beforepoint (substring string 0 point)))
1426 (completion-hilit-commonality
1427 (all-completions beforepoint table pred)
1428 point
1429 (car (completion-boundaries beforepoint table pred "")))))
19c04f39 1430
eee6de73
SM
1431;;; Basic completion.
1432
1433(defun completion--merge-suffix (completion point suffix)
1434 "Merge end of COMPLETION with beginning of SUFFIX.
1435Simple generalization of the \"merge trailing /\" done in Emacs-22.
1436Return the new suffix."
1437 (if (and (not (zerop (length suffix)))
1438 (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix)
1439 ;; Make sure we don't compress things to less
1440 ;; than we started with.
1441 point)
1442 ;; Just make sure we didn't match some other \n.
1443 (eq (match-end 1) (length completion)))
1444 (substring suffix (- (match-end 1) (match-beginning 1)))
1445 ;; Nothing to merge.
1446 suffix))
1447
34200787 1448(defun completion-basic-try-completion (string table pred point)
eee6de73
SM
1449 (let* ((beforepoint (substring string 0 point))
1450 (afterpoint (substring string point))
86011bf2
SM
1451 (bounds (completion-boundaries beforepoint table pred afterpoint)))
1452 (if (zerop (cdr bounds))
1453 ;; `try-completion' may return a subtly different result
1454 ;; than `all+merge', so try to use it whenever possible.
1455 (let ((completion (try-completion beforepoint table pred)))
1456 (if (not (stringp completion))
1457 completion
1458 (cons
1459 (concat completion
1460 (completion--merge-suffix completion point afterpoint))
1461 (length completion))))
1462 (let* ((suffix (substring afterpoint (cdr bounds)))
1463 (prefix (substring beforepoint 0 (car bounds)))
1464 (pattern (delete
1465 "" (list (substring beforepoint (car bounds))
1466 'point
1467 (substring afterpoint 0 (cdr bounds)))))
1468 (all (completion-pcm--all-completions prefix pattern table pred)))
1469 (if minibuffer-completing-file-name
1470 (setq all (completion-pcm--filename-try-filter all)))
1471 (completion-pcm--merge-try pattern all prefix suffix)))))
1472
1473(defun completion-basic-all-completions (string table pred point)
1474 (let* ((beforepoint (substring string 0 point))
1475 (afterpoint (substring string point))
1476 (bounds (completion-boundaries beforepoint table pred afterpoint))
1477 (suffix (substring afterpoint (cdr bounds)))
1478 (prefix (substring beforepoint 0 (car bounds)))
1479 (pattern (delete
1480 "" (list (substring beforepoint (car bounds))
1481 'point
1482 (substring afterpoint 0 (cdr bounds)))))
1483 (all (completion-pcm--all-completions prefix pattern table pred)))
125f7951 1484 (completion-hilit-commonality all point (car bounds))))
19c04f39 1485
34200787
SM
1486;;; Partial-completion-mode style completion.
1487
890429cc
SM
1488(defvar completion-pcm--delim-wild-regex nil
1489 "Regular expression matching delimiters controlling the partial-completion.
1490Typically, this regular expression simply matches a delimiter, meaning
1491that completion can add something at (match-beginning 0), but if it has
1492a submatch 1, then completion can add something at (match-end 1).
1493This is used when the delimiter needs to be of size zero (e.g. the transition
1494from lowercase to uppercase characters).")
34200787
SM
1495
1496(defun completion-pcm--prepare-delim-re (delims)
1497 (setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
1498
1499(defcustom completion-pcm-word-delimiters "-_. "
1500 "A string of characters treated as word delimiters for completion.
1501Some arcane rules:
1502If `]' is in this string, it must come first.
1503If `^' is in this string, it must not come first.
1504If `-' is in this string, it must come first or right after `]'.
1505In other words, if S is this string, then `[S]' must be a valid Emacs regular
1506expression (not containing character ranges like `a-z')."
1507 :set (lambda (symbol value)
1508 (set-default symbol value)
1509 ;; Refresh other vars.
1510 (completion-pcm--prepare-delim-re value))
1511 :initialize 'custom-initialize-reset
26c548b0 1512 :group 'minibuffer
34200787
SM
1513 :type 'string)
1514
1515(defun completion-pcm--pattern-trivial-p (pattern)
1bba1cfc
SM
1516 (and (stringp (car pattern))
1517 ;; It can be followed by `point' and "" and still be trivial.
1518 (let ((trivial t))
1519 (dolist (elem (cdr pattern))
1520 (unless (member elem '(point ""))
1521 (setq trivial nil)))
1522 trivial)))
34200787 1523
a38313e1
SM
1524(defun completion-pcm--string->pattern (string &optional point)
1525 "Split STRING into a pattern.
34200787
SM
1526A pattern is a list where each element is either a string
1527or a symbol chosen among `any', `star', `point'."
a38313e1
SM
1528 (if (and point (< point (length string)))
1529 (let ((prefix (substring string 0 point))
1530 (suffix (substring string point)))
34200787
SM
1531 (append (completion-pcm--string->pattern prefix)
1532 '(point)
1533 (completion-pcm--string->pattern suffix)))
1534 (let ((pattern nil)
1535 (p 0)
1536 (p0 0))
26c548b0 1537
890429cc
SM
1538 (while (and (setq p (string-match completion-pcm--delim-wild-regex
1539 string p))
1afbbf85
SM
1540 ;; If the char was added by minibuffer-complete-word, then
1541 ;; don't treat it as a delimiter, otherwise "M-x SPC"
1542 ;; ends up inserting a "-" rather than listing
1543 ;; all completions.
1544 (not (get-text-property p 'completion-try-word string)))
890429cc
SM
1545 ;; Usually, completion-pcm--delim-wild-regex matches a delimiter,
1546 ;; meaning that something can be added *before* it, but it can also
1547 ;; match a prefix and postfix, in which case something can be added
1548 ;; in-between (e.g. match [[:lower:]][[:upper:]]).
1549 ;; This is determined by the presence of a submatch-1 which delimits
1550 ;; the prefix.
1551 (if (match-end 1) (setq p (match-end 1)))
a38313e1
SM
1552 (push (substring string p0 p) pattern)
1553 (if (eq (aref string p) ?*)
34200787
SM
1554 (progn
1555 (push 'star pattern)
1556 (setq p0 (1+ p)))
1557 (push 'any pattern)
1558 (setq p0 p))
1559 (incf p))
1560
1561 ;; An empty string might be erroneously added at the beginning.
1562 ;; It should be avoided properly, but it's so easy to remove it here.
a38313e1 1563 (delete "" (nreverse (cons (substring string p0) pattern))))))
34200787
SM
1564
1565(defun completion-pcm--pattern->regex (pattern &optional group)
a38313e1 1566 (let ((re
ab22be48
SM
1567 (concat "\\`"
1568 (mapconcat
1569 (lambda (x)
1570 (case x
15c72e1d
SM
1571 ((star any point)
1572 (if (if (consp group) (memq x group) group)
ab22be48
SM
1573 "\\(.*?\\)" ".*?"))
1574 (t (regexp-quote x))))
1575 pattern
15c72e1d 1576 ""))))
a38313e1
SM
1577 ;; Avoid pathological backtracking.
1578 (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re)
1579 (setq re (replace-match "" t t re 1)))
1580 re))
34200787 1581
a38313e1 1582(defun completion-pcm--all-completions (prefix pattern table pred)
34200787 1583 "Find all completions for PATTERN in TABLE obeying PRED.
26c548b0 1584PATTERN is as returned by `completion-pcm--string->pattern'."
125f7951
SM
1585 ;; (assert (= (car (completion-boundaries prefix table pred ""))
1586 ;; (length prefix)))
34200787
SM
1587 ;; Find an initial list of possible completions.
1588 (if (completion-pcm--pattern-trivial-p pattern)
1589
1590 ;; Minibuffer contains no delimiters -- simple case!
125f7951 1591 (all-completions (concat prefix (car pattern)) table pred)
26c548b0 1592
34200787
SM
1593 ;; Use all-completions to do an initial cull. This is a big win,
1594 ;; since all-completions is written in C!
1595 (let* (;; Convert search pattern to a standard regular expression.
1596 (regex (completion-pcm--pattern->regex pattern))
15c72e1d
SM
1597 (case-fold-search completion-ignore-case)
1598 (completion-regexp-list (cons regex completion-regexp-list))
34200787 1599 (compl (all-completions
a38313e1 1600 (concat prefix (if (stringp (car pattern)) (car pattern) ""))
125f7951 1601 table pred)))
34200787
SM
1602 (if (not (functionp table))
1603 ;; The internal functions already obeyed completion-regexp-list.
1604 compl
15c72e1d 1605 (let ((poss ()))
34200787 1606 (dolist (c compl)
9f3618b5 1607 (when (string-match-p regex c) (push c poss)))
34200787
SM
1608 poss)))))
1609
7372b09c
SM
1610(defun completion-pcm--hilit-commonality (pattern completions)
1611 (when completions
1612 (let* ((re (completion-pcm--pattern->regex pattern '(point)))
1bba1cfc 1613 (case-fold-search completion-ignore-case))
7372b09c 1614 ;; Remove base-size during mapcar, and add it back later.
1bba1cfc
SM
1615 (mapcar
1616 (lambda (str)
1617 ;; Don't modify the string itself.
1618 (setq str (copy-sequence str))
1619 (unless (string-match re str)
1620 (error "Internal error: %s does not match %s" re str))
1621 (let ((pos (or (match-beginning 1) (match-end 0))))
1622 (put-text-property 0 pos
1623 'font-lock-face 'completions-common-part
1624 str)
1625 (if (> (length str) pos)
1626 (put-text-property pos (1+ pos)
1627 'font-lock-face 'completions-first-difference
1628 str)))
1629 str)
1630 completions))))
7372b09c 1631
eee6de73
SM
1632(defun completion-pcm--find-all-completions (string table pred point
1633 &optional filter)
1634 "Find all completions for STRING at POINT in TABLE, satisfying PRED.
1635POINT is a position inside STRING.
1636FILTER is a function applied to the return value, that can be used, e.g. to
1637filter out additional entries (because TABLE migth not obey PRED)."
1638 (unless filter (setq filter 'identity))
f8381803
SM
1639 (let* ((beforepoint (substring string 0 point))
1640 (afterpoint (substring string point))
1641 (bounds (completion-boundaries beforepoint table pred afterpoint))
1642 (prefix (substring beforepoint 0 (car bounds)))
1643 (suffix (substring afterpoint (cdr bounds)))
a38313e1 1644 firsterror)
f8381803
SM
1645 (setq string (substring string (car bounds) (+ point (cdr bounds))))
1646 (let* ((relpoint (- point (car bounds)))
1647 (pattern (completion-pcm--string->pattern string relpoint))
a38313e1 1648 (all (condition-case err
eee6de73
SM
1649 (funcall filter
1650 (completion-pcm--all-completions
1651 prefix pattern table pred))
a38313e1
SM
1652 (error (unless firsterror (setq firsterror err)) nil))))
1653 (when (and (null all)
1654 (> (car bounds) 0)
1655 (null (ignore-errors (try-completion prefix table pred))))
1656 ;; The prefix has no completions at all, so we should try and fix
1657 ;; that first.
1658 (let ((substring (substring prefix 0 -1)))
1659 (destructuring-bind (subpat suball subprefix subsuffix)
1660 (completion-pcm--find-all-completions
eee6de73 1661 substring table pred (length substring) filter)
a38313e1
SM
1662 (let ((sep (aref prefix (1- (length prefix))))
1663 ;; Text that goes between the new submatches and the
1664 ;; completion substring.
1665 (between nil))
1666 ;; Eliminate submatches that don't end with the separator.
1667 (dolist (submatch (prog1 suball (setq suball ())))
1668 (when (eq sep (aref submatch (1- (length submatch))))
1669 (push submatch suball)))
1670 (when suball
1671 ;; Update the boundaries and corresponding pattern.
1672 ;; We assume that all submatches result in the same boundaries
1673 ;; since we wouldn't know how to merge them otherwise anyway.
f8381803
SM
1674 ;; FIXME: COMPLETE REWRITE!!!
1675 (let* ((newbeforepoint
1676 (concat subprefix (car suball)
1677 (substring string 0 relpoint)))
1678 (leftbound (+ (length subprefix) (length (car suball))))
a38313e1 1679 (newbounds (completion-boundaries
f8381803
SM
1680 newbeforepoint table pred afterpoint)))
1681 (unless (or (and (eq (cdr bounds) (cdr newbounds))
1682 (eq (car newbounds) leftbound))
a38313e1
SM
1683 ;; Refuse new boundaries if they step over
1684 ;; the submatch.
f8381803 1685 (< (car newbounds) leftbound))
a38313e1
SM
1686 ;; The new completed prefix does change the boundaries
1687 ;; of the completed substring.
f8381803
SM
1688 (setq suffix (substring afterpoint (cdr newbounds)))
1689 (setq string
1690 (concat (substring newbeforepoint (car newbounds))
1691 (substring afterpoint 0 (cdr newbounds))))
1692 (setq between (substring newbeforepoint leftbound
a38313e1
SM
1693 (car newbounds)))
1694 (setq pattern (completion-pcm--string->pattern
f8381803
SM
1695 string
1696 (- (length newbeforepoint)
1697 (car newbounds)))))
a38313e1
SM
1698 (dolist (submatch suball)
1699 (setq all (nconc (mapcar
1700 (lambda (s) (concat submatch between s))
eee6de73
SM
1701 (funcall filter
1702 (completion-pcm--all-completions
1703 (concat subprefix submatch between)
1704 pattern table pred)))
a38313e1 1705 all)))
c63028e1
SM
1706 ;; FIXME: This can come in handy for try-completion,
1707 ;; but isn't right for all-completions, since it lists
1708 ;; invalid completions.
1709 ;; (unless all
1710 ;; ;; Even though we found expansions in the prefix, none
1711 ;; ;; leads to a valid completion.
1712 ;; ;; Let's keep the expansions, tho.
1713 ;; (dolist (submatch suball)
1714 ;; (push (concat submatch between newsubstring) all)))
1715 ))
a38313e1
SM
1716 (setq pattern (append subpat (list 'any (string sep))
1717 (if between (list between)) pattern))
1718 (setq prefix subprefix)))))
1719 (if (and (null all) firsterror)
1720 (signal (car firsterror) (cdr firsterror))
1721 (list pattern all prefix suffix)))))
1722
34200787 1723(defun completion-pcm-all-completions (string table pred point)
a38313e1
SM
1724 (destructuring-bind (pattern all &optional prefix suffix)
1725 (completion-pcm--find-all-completions string table pred point)
d4e88786
SM
1726 (when all
1727 (nconc (completion-pcm--hilit-commonality pattern all)
1728 (length prefix)))))
34200787
SM
1729
1730(defun completion-pcm--merge-completions (strs pattern)
1731 "Extract the commonality in STRS, with the help of PATTERN."
681e0e7c
SM
1732 ;; When completing while ignoring case, we want to try and avoid
1733 ;; completing "fo" to "foO" when completing against "FOO" (bug#4219).
1734 ;; So we try and make sure that the string we return is all made up
1735 ;; of text from the completions rather than part from the
1736 ;; completions and part from the input.
1737 ;; FIXME: This reduces the problems of inconsistent capitalization
1738 ;; but it doesn't fully fix it: we may still end up completing
1739 ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against
1740 ;; '("foo-barr" "FOO-BARD").
34200787
SM
1741 (cond
1742 ((null (cdr strs)) (list (car strs)))
1743 (t
1744 (let ((re (completion-pcm--pattern->regex pattern 'group))
1745 (ccs ())) ;Chopped completions.
1746
1747 ;; First chop each string into the parts corresponding to each
1748 ;; non-constant element of `pattern', using regexp-matching.
1749 (let ((case-fold-search completion-ignore-case))
1750 (dolist (str strs)
1751 (unless (string-match re str)
1752 (error "Internal error: %s doesn't match %s" str re))
1753 (let ((chopped ())
681e0e7c
SM
1754 (last 0)
1755 (i 1)
1756 next)
1757 (while (setq next (match-end i))
1758 (push (substring str last next) chopped)
1759 (setq last next)
34200787
SM
1760 (setq i (1+ i)))
1761 ;; Add the text corresponding to the implicit trailing `any'.
681e0e7c 1762 (push (substring str last) chopped)
34200787
SM
1763 (push (nreverse chopped) ccs))))
1764
1765 ;; Then for each of those non-constant elements, extract the
1766 ;; commonality between them.
681e0e7c
SM
1767 (let ((res ())
1768 (fixed ""))
1769 ;; Make the implicit trailing `any' explicit.
34200787
SM
1770 (dolist (elem (append pattern '(any)))
1771 (if (stringp elem)
681e0e7c 1772 (setq fixed (concat fixed elem))
34200787
SM
1773 (let ((comps ()))
1774 (dolist (cc (prog1 ccs (setq ccs nil)))
1775 (push (car cc) comps)
1776 (push (cdr cc) ccs))
681e0e7c
SM
1777 ;; Might improve the likelihood to avoid choosing
1778 ;; different capitalizations in different parts.
1779 ;; In practice, it doesn't seem to make any difference.
1780 (setq ccs (nreverse ccs))
1781 (let* ((prefix (try-completion fixed comps))
1782 (unique (or (and (eq prefix t) (setq prefix fixed))
34200787
SM
1783 (eq t (try-completion prefix comps)))))
1784 (unless (equal prefix "") (push prefix res))
1785 ;; If there's only one completion, `elem' is not useful
1786 ;; any more: it can only match the empty string.
1787 ;; FIXME: in some cases, it may be necessary to turn an
1788 ;; `any' into a `star' because the surrounding context has
1789 ;; changed such that string->pattern wouldn't add an `any'
1790 ;; here any more.
681e0e7c
SM
1791 (unless unique (push elem res))
1792 (setq fixed "")))))
34200787
SM
1793 ;; We return it in reverse order.
1794 res)))))
1795
1796(defun completion-pcm--pattern->string (pattern)
1797 (mapconcat (lambda (x) (cond
1798 ((stringp x) x)
1799 ((eq x 'star) "*")
1800 ((eq x 'any) "")
1801 ((eq x 'point) "")))
1802 pattern
1803 ""))
1804
eee6de73
SM
1805;; We want to provide the functionality of `try', but we use `all'
1806;; and then merge it. In most cases, this works perfectly, but
1807;; if the completion table doesn't consider the same completions in
1808;; `try' as in `all', then we have a problem. The most common such
1809;; case is for filename completion where completion-ignored-extensions
1810;; is only obeyed by the `try' code. We paper over the difference
1811;; here. Note that it is not quite right either: if the completion
1812;; table uses completion-table-in-turn, this filtering may take place
1813;; too late to correctly fallback from the first to the
1814;; second alternative.
1815(defun completion-pcm--filename-try-filter (all)
1816 "Filter to adjust `all' file completion to the behavior of `try'."
34200787 1817 (when all
eee6de73
SM
1818 (let ((try ())
1819 (re (concat "\\(?:\\`\\.\\.?/\\|"
1820 (regexp-opt completion-ignored-extensions)
1821 "\\)\\'")))
1822 (dolist (f all)
9f3618b5 1823 (unless (string-match-p re f) (push f try)))
eee6de73 1824 (or try all))))
9f3618b5 1825
eee6de73
SM
1826
1827(defun completion-pcm--merge-try (pattern all prefix suffix)
1828 (cond
1829 ((not (consp all)) all)
1830 ((and (not (consp (cdr all))) ;Only one completion.
1831 ;; Ignore completion-ignore-case here.
1832 (equal (completion-pcm--pattern->string pattern) (car all)))
1833 t)
1834 (t
34200787 1835 (let* ((mergedpat (completion-pcm--merge-completions all pattern))
81ff9458
SM
1836 ;; `mergedpat' is in reverse order. Place new point (by
1837 ;; order of preference) either at the old point, or at
1838 ;; the last place where there's something to choose, or
1839 ;; at the very end.
1840 (pointpat (or (memq 'point mergedpat) (memq 'any mergedpat)
b00942d0 1841 mergedpat))
81ff9458 1842 ;; New pos from the start.
34200787 1843 (newpos (length (completion-pcm--pattern->string pointpat)))
81ff9458 1844 ;; Do it afterwards because it changes `pointpat' by sideeffect.
34200787 1845 (merged (completion-pcm--pattern->string (nreverse mergedpat))))
eee6de73
SM
1846
1847 (setq suffix (completion--merge-suffix merged newpos suffix))
a38313e1 1848 (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
34200787 1849
eee6de73
SM
1850(defun completion-pcm-try-completion (string table pred point)
1851 (destructuring-bind (pattern all prefix suffix)
1852 (completion-pcm--find-all-completions
1853 string table pred point
1854 (if minibuffer-completing-file-name
1855 'completion-pcm--filename-try-filter))
1856 (completion-pcm--merge-try pattern all prefix suffix)))
1857
fcb68f70
SM
1858;;; Initials completion
1859;; Complete /ums to /usr/monnier/src or lch to list-command-history.
1860
1861(defun completion-initials-expand (str table pred)
1862 (unless (or (zerop (length str))
6e2ca895 1863 (string-match completion-pcm--delim-wild-regex str))
fcb68f70
SM
1864 (let ((bounds (completion-boundaries str table pred "")))
1865 (if (zerop (car bounds))
1866 (mapconcat 'string str "-")
1867 ;; If there's a boundary, it's trickier. The main use-case
1868 ;; we consider here is file-name completion. We'd like
1869 ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e.
1870 ;; But at the same time, we don't want /usr/share/ae to expand
1871 ;; to /usr/share/a/e just because we mistyped "ae" for "ar",
1872 ;; so we probably don't want initials to touch anything that
1873 ;; looks like /usr/share/foo. As a heuristic, we just check that
1874 ;; the text before the boundary char is at most 1 char.
1875 ;; This allows both ~/eee and /eee and not much more.
1876 ;; FIXME: It sadly also disallows the use of ~/eee when that's
1877 ;; embedded within something else (e.g. "(~/eee" in Info node
1878 ;; completion or "ancestor:/eee" in bzr-revision completion).
1879 (when (< (car bounds) 3)
1880 (let ((sep (substring str (1- (car bounds)) (car bounds))))
1881 ;; FIXME: the above string-match checks the whole string, whereas
1882 ;; we end up only caring about the after-boundary part.
1883 (concat (substring str 0 (car bounds))
1884 (mapconcat 'string (substring str (car bounds)) sep))))))))
1885
1886(defun completion-initials-all-completions (string table pred point)
1887 (let ((newstr (completion-initials-expand string table pred)))
1888 (when newstr
1889 (completion-pcm-all-completions newstr table pred (length newstr)))))
1890
1891(defun completion-initials-try-completion (string table pred point)
1892 (let ((newstr (completion-initials-expand string table pred)))
1893 (when newstr
1894 (completion-pcm-try-completion newstr table pred (length newstr)))))
1895
34200787 1896
32bae13c 1897(provide 'minibuffer)
dc6ee347
MB
1898
1899;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
32bae13c 1900;;; minibuffer.el ends here