Some documenting of load-prefer-newer
[bpt/emacs.git] / lisp / minibuffer.el
CommitLineData
a647cb26 1;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
32bae13c 2
ab422c4d 3;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
32bae13c
SM
4
5;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
bd78fa1d 6;; Package: emacs
32bae13c
SM
7
8;; This file is part of GNU Emacs.
9
eb3fa2cf 10;; GNU Emacs is free software: you can redistribute it and/or modify
32bae13c
SM
11;; it under the terms of the GNU General Public License as published by
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
14
eb3fa2cf 15;; GNU Emacs is distributed in the hope that it will be useful,
32bae13c
SM
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
19
20;; You should have received a copy of the GNU General Public License
eb3fa2cf 21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
32bae13c
SM
22
23;;; Commentary:
24
a38313e1
SM
25;; Names with "--" are for functions and variables that are meant to be for
26;; internal use only.
27
28;; Functional completion tables have an extended calling conventions:
30a23501
SM
29;; The `action' can be (additionally to nil, t, and lambda) of the form
30;; - (boundaries . SUFFIX) in which case it should return
f8381803 31;; (boundaries START . END). See `completion-boundaries'.
a38313e1
SM
32;; Any other return value should be ignored (so we ignore values returned
33;; from completion tables that don't know about this new `action' form).
30a23501
SM
34;; - `metadata' in which case it should return (metadata . ALIST) where
35;; ALIST is the metadata of this table. See `completion-metadata'.
36;; Any other return value should be ignored (so we ignore values returned
37;; from completion tables that don't know about this new `action' form).
a38313e1
SM
38
39;;; Bugs:
40
67982e2b 41;; - completion-all-sorted-completions lists all the completions, whereas
eee6de73
SM
42;; it should only lists the ones that `try-completion' would consider.
43;; E.g. it should honor completion-ignored-extensions.
a38313e1 44;; - choose-completion can't automatically figure out the boundaries
528c56e2
SM
45;; corresponding to the displayed completions because we only
46;; provide the start info but not the end info in
47;; completion-base-position.
528c56e2
SM
48;; - C-x C-f ~/*/sr ? should not list "~/./src".
49;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el
50;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
ba5ff07b 51
3911966b
SM
52;;; Todo:
53
3b11e6ac
SM
54;; - Make *Completions* readable even if some of the completion
55;; entries have LF chars or spaces in them (including at
56;; beginning/end) or are very long.
a2a25d24 57;; - for M-x, cycle-sort commands that have no key binding first.
2dbaa080
SM
58;; - Make things like icomplete-mode or lightning-completion work with
59;; completion-in-region-mode.
620c53a6 60;; - extend `metadata':
365b9a62
SM
61;; - indicate how to turn all-completion's output into
62;; try-completion's output: e.g. completion-ignored-extensions.
ef24141c 63;; maybe that could be merged with the "quote" operation.
365b9a62
SM
64;; - indicate that `all-completions' doesn't do prefix-completion
65;; but just returns some list that relates in some other way to
66;; the provided string (as is the case in filecache.el), in which
67;; case partial-completion (for example) doesn't make any sense
68;; and neither does the completions-first-difference highlight.
902a6d8d
SM
69;; - indicate how to display the completions in *Completions* (turn
70;; \n into something else, add special boundaries between
71;; completions). E.g. when completing from the kill-ring.
365b9a62 72
528c56e2 73;; - case-sensitivity currently confuses two issues:
ab22be48 74;; - whether or not a particular completion table should be case-sensitive
528c56e2 75;; (i.e. whether strings that differ only by case are semantically
ab22be48
SM
76;; equivalent)
77;; - whether the user wants completion to pay attention to case.
78;; e.g. we may want to make it possible for the user to say "first try
79;; completion case-sensitively, and if that fails, try to ignore case".
3b11e6ac
SM
80;; Maybe the trick is that we should distinguish completion-ignore-case in
81;; try/all-completions (obey user's preference) from its use in
82;; test-completion (obey the underlying object's semantics).
ab22be48 83
a38313e1 84;; - add support for ** to pcm.
3911966b
SM
85;; - Add vc-file-name-completion-table to read-file-name-internal.
86;; - A feature like completing-help.el.
32bae13c
SM
87
88;;; Code:
89
f58e0fd5 90(eval-when-compile (require 'cl-lib))
32bae13c 91
21622c6d
SM
92;;; Completion table manipulation
93
a38313e1 94;; New completion-table operation.
f8381803
SM
95(defun completion-boundaries (string table pred suffix)
96 "Return the boundaries of the completions returned by TABLE for STRING.
a38313e1 97STRING is the string on which completion will be performed.
f8381803
SM
98SUFFIX is the string after point.
99The result is of the form (START . END) where START is the position
100in STRING of the beginning of the completion field and END is the position
101in SUFFIX of the end of the completion field.
f8381803
SM
102E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
103and for file names the result is the positions delimited by
a38313e1
SM
104the closest directory separators."
105 (let ((boundaries (if (functionp table)
30a23501
SM
106 (funcall table string pred
107 (cons 'boundaries suffix)))))
a38313e1
SM
108 (if (not (eq (car-safe boundaries) 'boundaries))
109 (setq boundaries nil))
110 (cons (or (cadr boundaries) 0)
f8381803 111 (or (cddr boundaries) (length suffix)))))
a38313e1 112
620c53a6
SM
113(defun completion-metadata (string table pred)
114 "Return the metadata of elements to complete at the end of STRING.
115This metadata is an alist. Currently understood keys are:
116- `category': the kind of objects returned by `all-completions'.
117 Used by `completion-category-overrides'.
118- `annotation-function': function to add annotations in *Completions*.
119 Takes one argument (STRING), which is a possible completion and
120 returns a string to append to STRING.
121- `display-sort-function': function to sort entries in *Completions*.
122 Takes one argument (COMPLETIONS) and should return a new list
123 of completions. Can operate destructively.
124- `cycle-sort-function': function to sort entries when cycling.
30a23501
SM
125 Works like `display-sort-function'.
126The metadata of a completion table should be constant between two boundaries."
620c53a6
SM
127 (let ((metadata (if (functionp table)
128 (funcall table string pred 'metadata))))
129 (if (eq (car-safe metadata) 'metadata)
4cb3bfa0
SM
130 metadata
131 '(metadata))))
620c53a6
SM
132
133(defun completion--field-metadata (field-start)
134 (completion-metadata (buffer-substring-no-properties field-start (point))
135 minibuffer-completion-table
136 minibuffer-completion-predicate))
137
138(defun completion-metadata-get (metadata prop)
139 (cdr (assq prop metadata)))
140
e2947429
SM
141(defun completion--some (fun xs)
142 "Apply FUN to each element of XS in turn.
143Return the first non-nil returned value.
144Like CL's `some'."
a647cb26
SM
145 (let ((firsterror nil)
146 res)
e2947429 147 (while (and (not res) xs)
67982e2b 148 (condition-case-unless-debug err
a38313e1
SM
149 (setq res (funcall fun (pop xs)))
150 (error (unless firsterror (setq firsterror err)) nil)))
151 (or res
152 (if firsterror (signal (car firsterror) (cdr firsterror))))))
e2947429 153
21622c6d
SM
154(defun complete-with-action (action table string pred)
155 "Perform completion ACTION.
156STRING is the string to complete.
dbbc2e69 157TABLE is the completion table.
21622c6d
SM
158PRED is a completion predicate.
159ACTION can be one of nil, t or `lambda'."
a38313e1
SM
160 (cond
161 ((functionp table) (funcall table string pred action))
30a23501
SM
162 ((eq (car-safe action) 'boundaries) nil)
163 ((eq action 'metadata) nil)
a38313e1
SM
164 (t
165 (funcall
166 (cond
167 ((null action) 'try-completion)
168 ((eq action t) 'all-completions)
169 (t 'test-completion))
170 string table pred))))
21622c6d
SM
171
172(defun completion-table-dynamic (fun)
173 "Use function FUN as a dynamic completion table.
174FUN is called with one argument, the string for which completion is required,
b95c7600
JB
175and it should return an alist containing all the intended possible completions.
176This alist may be a full list of possible completions so that FUN can ignore
177the value of its argument. If completion is performed in the minibuffer,
178FUN will be called in the buffer from which the minibuffer was entered.
21622c6d 179
e8061cd9 180The result of the `completion-table-dynamic' form is a function
d9aa6b33 181that can be used as the COLLECTION argument to `try-completion' and
b95c7600 182`all-completions'. See Info node `(elisp)Programmed Completion'."
a647cb26 183 (lambda (string pred action)
30a23501 184 (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
03408648
SM
185 ;; `fun' is not supposed to return another function but a plain old
186 ;; completion table, whose boundaries are always trivial.
187 nil
188 (with-current-buffer (let ((win (minibuffer-selected-window)))
189 (if (window-live-p win) (window-buffer win)
190 (current-buffer)))
191 (complete-with-action action (funcall fun string) string pred)))))
21622c6d 192
16588fad
DG
193(defun completion-table-with-cache (fun &optional ignore-case)
194 "Create dynamic completion table from FUN, with cache.
195This wraps `completion-table-dynamic', but saves the last
196argument-result pair from FUN, so that several lookups with the
197same argument (or with an argument that starts with the first one)
198only need to call FUN once. Most useful when FUN performs a relatively
199slow operation, such as calling an external process (see Bug#11906).
200When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
201 (let* (last-arg last-result
202 (new-fun
203 (lambda (arg)
204 (if (and last-arg (string-prefix-p last-arg arg ignore-case))
205 last-result
206 (prog1
207 (setq last-result (funcall fun arg))
208 (setq last-arg arg))))))
209 (completion-table-dynamic new-fun)))
210
21622c6d
SM
211(defmacro lazy-completion-table (var fun)
212 "Initialize variable VAR as a lazy completion table.
213If the completion table VAR is used for the first time (e.g., by passing VAR
214as an argument to `try-completion'), the function FUN is called with no
215arguments. FUN must return the completion table that will be stored in VAR.
216If completion is requested in the minibuffer, FUN will be called in the buffer
217from which the minibuffer was entered. The return value of
218`lazy-completion-table' must be used to initialize the value of VAR.
219
220You should give VAR a non-nil `risky-local-variable' property."
69e018a7 221 (declare (debug (symbolp lambda-expr)))
21622c6d
SM
222 (let ((str (make-symbol "string")))
223 `(completion-table-dynamic
224 (lambda (,str)
225 (when (functionp ,var)
0d42eb3e 226 (setq ,var (funcall #',fun)))
21622c6d
SM
227 ,var))))
228
3dc61a09
SM
229(defun completion-table-case-fold (table &optional dont-fold)
230 "Return new completion TABLE that is case insensitive.
231If DONT-FOLD is non-nil, return a completion table that is
232case sensitive instead."
233 (lambda (string pred action)
234 (let ((completion-ignore-case (not dont-fold)))
235 (complete-with-action action table string pred))))
e2784c87 236
ef24141c 237(defun completion-table-subvert (table s1 s2)
96d03571 238 "Return a completion table from TABLE with S1 replaced by S2.
ef24141c 239The result is a completion table which completes strings of the
9011078f
BG
240form (concat S1 S) in the same way as TABLE completes strings of
241the form (concat S2 S)."
ef24141c
SM
242 (lambda (string pred action)
243 (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
244 completion-ignore-case))
245 (concat s2 (substring string (length s1)))))
246 (res (if str (complete-with-action action table str pred))))
247 (when res
248 (cond
249 ((eq (car-safe action) 'boundaries)
250 (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
f58e0fd5
SM
251 `(boundaries
252 ,(max (length s1)
253 (+ beg (- (length s1) (length s2))))
254 . ,(and (eq (car-safe res) 'boundaries) (cddr res)))))
ef24141c
SM
255 ((stringp res)
256 (if (eq t (compare-strings res 0 (length s2) s2 nil nil
257 completion-ignore-case))
258 (concat s1 (substring res (length s2)))))
259 ((eq action t)
260 (let ((bounds (completion-boundaries str table pred "")))
261 (if (>= (car bounds) (length s2))
262 res
263 (let ((re (concat "\\`"
264 (regexp-quote (substring s2 (car bounds))))))
265 (delq nil
266 (mapcar (lambda (c)
267 (if (string-match re c)
268 (substring c (match-end 0))))
269 res))))))
270 ;; E.g. action=nil and it's the only completion.
271 (res))))))
272
21622c6d 273(defun completion-table-with-context (prefix table string pred action)
25c0d999 274 ;; TODO: add `suffix' maybe?
b291b572
SM
275 (let ((pred
276 (if (not (functionp pred))
277 ;; Notice that `pred' may not be a function in some abusive cases.
278 pred
279 ;; Predicates are called differently depending on the nature of
280 ;; the completion table :-(
281 (cond
282 ((vectorp table) ;Obarray.
283 (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
284 ((hash-table-p table)
285 (lambda (s _v) (funcall pred (concat prefix s))))
286 ((functionp table)
287 (lambda (s) (funcall pred (concat prefix s))))
288 (t ;Lists and alists.
289 (lambda (s)
290 (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
291 (if (eq (car-safe action) 'boundaries)
292 (let* ((len (length prefix))
293 (bound (completion-boundaries string table pred (cdr action))))
f58e0fd5 294 `(boundaries ,(+ (car bound) len) . ,(cdr bound)))
b291b572
SM
295 (let ((comp (complete-with-action action table string pred)))
296 (cond
297 ;; In case of try-completion, add the prefix.
298 ((stringp comp) (concat prefix comp))
299 (t comp))))))
21622c6d
SM
300
301(defun completion-table-with-terminator (terminator table string pred action)
528c56e2
SM
302 "Construct a completion table like TABLE but with an extra TERMINATOR.
303This is meant to be called in a curried way by first passing TERMINATOR
304and TABLE only (via `apply-partially').
305TABLE is a completion table, and TERMINATOR is a string appended to TABLE's
306completion if it is complete. TERMINATOR is also used to determine the
a452eee8
SM
307completion suffix's boundary.
308TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP)
309in which case TERMINATOR-REGEXP is a regular expression whose submatch
310number 1 should match TERMINATOR. This is used when there is a need to
311distinguish occurrences of the TERMINATOR strings which are really terminators
c0a193ea
SM
312from others (e.g. escaped). In this form, the car of TERMINATOR can also be,
313instead of a string, a function that takes the completion and returns the
314\"terminated\" string."
3e2d70fd
SM
315 ;; FIXME: This implementation is not right since it only adds the terminator
316 ;; in try-completion, so any completion-style that builds the completion via
317 ;; all-completions won't get the terminator, and selecting an entry in
318 ;; *Completions* won't get the terminator added either.
25c0d999 319 (cond
528c56e2
SM
320 ((eq (car-safe action) 'boundaries)
321 (let* ((suffix (cdr action))
322 (bounds (completion-boundaries string table pred suffix))
a452eee8
SM
323 (terminator-regexp (if (consp terminator)
324 (cdr terminator) (regexp-quote terminator)))
c0a193ea
SM
325 (max (and terminator-regexp
326 (string-match terminator-regexp suffix))))
f58e0fd5
SM
327 `(boundaries ,(car bounds)
328 . ,(min (cdr bounds) (or max (length suffix))))))
25c0d999
SM
329 ((eq action nil)
330 (let ((comp (try-completion string table pred)))
a452eee8 331 (if (consp terminator) (setq terminator (car terminator)))
88893215 332 (if (eq comp t)
c0a193ea
SM
333 (if (functionp terminator)
334 (funcall terminator string)
335 (concat string terminator))
336 (if (and (stringp comp) (not (zerop (length comp)))
337 ;; Try to avoid the second call to try-completion, since
528c56e2
SM
338 ;; it may be very inefficient (because `comp' made us
339 ;; jump to a new boundary, so we complete in that
340 ;; boundary with an empty start string).
c0a193ea
SM
341 (let ((newbounds (completion-boundaries comp table pred "")))
342 (< (car newbounds) (length comp)))
25c0d999 343 (eq (try-completion comp table pred) t))
c0a193ea
SM
344 (if (functionp terminator)
345 (funcall terminator comp)
346 (concat comp terminator))
25c0d999 347 comp))))
30a23501
SM
348 ;; completion-table-with-terminator is always used for
349 ;; "sub-completions" so it's only called if the terminator is missing,
350 ;; in which case `test-completion' should return nil.
351 ((eq action 'lambda) nil)
352 (t
a38313e1
SM
353 ;; FIXME: We generally want the `try' and `all' behaviors to be
354 ;; consistent so pcm can merge the `all' output to get the `try' output,
355 ;; but that sometimes clashes with the need for `all' output to look
356 ;; good in *Completions*.
125f7951
SM
357 ;; (mapcar (lambda (s) (concat s terminator))
358 ;; (all-completions string table pred))))
30a23501 359 (complete-with-action action table string pred))))
25c0d999
SM
360
361(defun completion-table-with-predicate (table pred1 strict string pred2 action)
362 "Make a completion table equivalent to TABLE but filtered through PRED1.
cf43708e 363PRED1 is a function of one argument which returns non-nil if and only if the
25c0d999
SM
364argument is an element of TABLE which should be considered for completion.
365STRING, PRED2, and ACTION are the usual arguments to completion tables,
366as described in `try-completion', `all-completions', and `test-completion'.
3911966b
SM
367If STRICT is t, the predicate always applies; if nil it only applies if
368it does not reduce the set of possible completions to nothing.
25c0d999
SM
369Note: TABLE needs to be a proper completion table which obeys predicates."
370 (cond
371 ((and (not strict) (eq action 'lambda))
372 ;; Ignore pred1 since it doesn't really have to apply anyway.
af48580e 373 (test-completion string table pred2))
25c0d999
SM
374 (t
375 (or (complete-with-action action table string
78054a46
SM
376 (if (not (and pred1 pred2))
377 (or pred1 pred2)
a647cb26
SM
378 (lambda (x)
379 ;; Call `pred1' first, so that `pred2'
380 ;; really can't tell that `x' is in table.
78054a46 381 (and (funcall pred1 x) (funcall pred2 x)))))
25c0d999
SM
382 ;; If completion failed and we're not applying pred1 strictly, try
383 ;; again without pred1.
78054a46 384 (and (not strict) pred1 pred2
25c0d999 385 (complete-with-action action table string pred2))))))
21622c6d 386
e2947429
SM
387(defun completion-table-in-turn (&rest tables)
388 "Create a completion table that tries each table in TABLES in turn."
528c56e2
SM
389 ;; FIXME: the boundaries may come from TABLE1 even when the completion list
390 ;; is returned by TABLE2 (because TABLE1 returned an empty list).
a647cb26
SM
391 (lambda (string pred action)
392 (completion--some (lambda (table)
393 (complete-with-action action table string pred))
394 tables)))
e2947429 395
ef24141c
SM
396(defun completion-table-with-quoting (table unquote requote)
397 ;; A difficult part of completion-with-quoting is to map positions in the
398 ;; quoted string to equivalent positions in the unquoted string and
399 ;; vice-versa. There is no efficient and reliable algorithm that works for
400 ;; arbitrary quote and unquote functions.
401 ;; So to map from quoted positions to unquoted positions, we simply assume
402 ;; that `concat' and `unquote' commute (which tends to be the case).
403 ;; And we ask `requote' to do the work of mapping from unquoted positions
404 ;; back to quoted positions.
86957a0c
SM
405 ;; FIXME: For some forms of "quoting" such as the truncation behavior of
406 ;; substitute-in-file-name, it would be desirable not to requote completely.
ef24141c
SM
407 "Return a new completion table operating on quoted text.
408TABLE operates on the unquoted text.
409UNQUOTE is a function that takes a string and returns a new unquoted string.
410REQUOTE is a function of 2 args (UPOS QSTR) where
411 QSTR is a string entered by the user (and hence indicating
412 the user's preferred form of quoting); and
413 UPOS is a position within the unquoted form of QSTR.
414REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the
415position corresponding to UPOS but in QSTR, and QFUN is a function
416of one argument (a string) which returns that argument appropriately quoted
417for use at QPOS."
418 ;; FIXME: One problem with the current setup is that `qfun' doesn't know if
419 ;; its argument is "the end of the completion", so if the quoting used double
420 ;; quotes (for example), we end up completing "fo" to "foobar and throwing
421 ;; away the closing double quote.
422 (lambda (string pred action)
423 (cond
424 ((eq action 'metadata)
425 (append (completion-metadata string table pred)
426 '((completion--unquote-requote . t))))
427
428 ((eq action 'lambda) ;;test-completion
429 (let ((ustring (funcall unquote string)))
430 (test-completion ustring table pred)))
431
432 ((eq (car-safe action) 'boundaries)
433 (let* ((ustring (funcall unquote string))
434 (qsuffix (cdr action))
435 (ufull (if (zerop (length qsuffix)) ustring
436 (funcall unquote (concat string qsuffix))))
f58e0fd5 437 (_ (cl-assert (string-prefix-p ustring ufull)))
ef24141c
SM
438 (usuffix (substring ufull (length ustring)))
439 (boundaries (completion-boundaries ustring table pred usuffix))
440 (qlboundary (car (funcall requote (car boundaries) string)))
441 (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
442 (let* ((urfullboundary
443 (+ (cdr boundaries) (length ustring))))
444 (- (car (funcall requote urfullboundary
445 (concat string qsuffix)))
446 (length string))))))
f58e0fd5 447 `(boundaries ,qlboundary . ,qrboundary)))
ef24141c 448
6eac8dc9
SM
449 ;; In "normal" use a c-t-with-quoting completion table should never be
450 ;; called with action in (t nil) because `completion--unquote' should have
451 ;; been called before and would have returned a different completion table
452 ;; to apply to the unquoted text. But there's still a lot of code around
453 ;; that likes to use all/try-completions directly, so we do our best to
454 ;; handle those calls as well as we can.
455
ef24141c
SM
456 ((eq action nil) ;;try-completion
457 (let* ((ustring (funcall unquote string))
458 (completion (try-completion ustring table pred)))
459 ;; Most forms of quoting allow several ways to quote the same string.
460 ;; So here we could simply requote `completion' in a kind of
461 ;; "canonical" quoted form without paying attention to the way
462 ;; `string' was quoted. But since we have to solve the more complex
463 ;; problems of "pay attention to the original quoting" for
464 ;; all-completions, we may as well use it here, since it provides
465 ;; a nicer behavior.
466 (if (not (stringp completion)) completion
467 (car (completion--twq-try
468 string ustring completion 0 unquote requote)))))
469
470 ((eq action t) ;;all-completions
471 ;; When all-completions is used for completion-try/all-completions
472 ;; (e.g. for `pcm' style), we can't do the job properly here because
473 ;; the caller will match our output against some pattern derived from
474 ;; the user's (quoted) input, and we don't have access to that
475 ;; pattern, so we can't know how to requote our output so that it
476 ;; matches the quoting used in the pattern. It is to fix this
477 ;; fundamental problem that we have to introduce the new
478 ;; unquote-requote method so that completion-try/all-completions can
479 ;; pass the unquoted string to the style functions.
480 (pcase-let*
481 ((ustring (funcall unquote string))
482 (completions (all-completions ustring table pred))
6eac8dc9
SM
483 (boundary (car (completion-boundaries ustring table pred "")))
484 (completions
485 (completion--twq-all
486 string ustring completions boundary unquote requote))
487 (last (last completions)))
488 (when (consp last) (setcdr last nil))
489 completions))
6b11952a 490
ef24141c
SM
491 ((eq action 'completion--unquote)
492 (let ((ustring (funcall unquote string))
493 (uprefix (funcall unquote (substring string 0 pred))))
494 ;; We presume (more or less) that `concat' and `unquote' commute.
f58e0fd5 495 (cl-assert (string-prefix-p uprefix ustring))
ef24141c
SM
496 (list ustring table (length uprefix)
497 (lambda (unquoted-result op)
498 (pcase op
f58e0fd5 499 (1 ;;try
ef24141c
SM
500 (if (not (stringp (car-safe unquoted-result)))
501 unquoted-result
502 (completion--twq-try
503 string ustring
504 (car unquoted-result) (cdr unquoted-result)
505 unquote requote)))
f58e0fd5 506 (2 ;;all
ef24141c
SM
507 (let* ((last (last unquoted-result))
508 (base (or (cdr last) 0)))
509 (when last
510 (setcdr last nil)
511 (completion--twq-all string ustring
512 unquoted-result base
513 unquote requote))))))))))))
514
515(defun completion--twq-try (string ustring completion point
516 unquote requote)
e33c6771 517 ;; Basically two cases: either the new result is
ef24141c
SM
518 ;; - commonprefix1 <point> morecommonprefix <qpos> suffix
519 ;; - commonprefix <qpos> newprefix <point> suffix
520 (pcase-let*
521 ((prefix (fill-common-string-prefix ustring completion))
522 (suffix (substring completion (max point (length prefix))))
523 (`(,qpos . ,qfun) (funcall requote (length prefix) string))
524 (qstr1 (if (> point (length prefix))
525 (funcall qfun (substring completion (length prefix) point))))
526 (qsuffix (funcall qfun suffix))
527 (qstring (concat (substring string 0 qpos) qstr1 qsuffix))
528 (qpoint
529 (cond
530 ((zerop point) 0)
531 ((> point (length prefix)) (+ qpos (length qstr1)))
532 (t (car (funcall requote point string))))))
533 ;; Make sure `requote' worked.
e33c6771
SM
534 (if (equal (funcall unquote qstring) completion)
535 (cons qstring qpoint)
536 ;; If requote failed (e.g. because sifn-requote did not handle
537 ;; Tramp's "/foo:/bar//baz -> /foo:/baz" truncation), then at least
538 ;; try requote properly.
539 (let ((qstr (funcall qfun completion)))
540 (cons qstr (length qstr))))))
ef24141c 541
036dfb8b
SM
542(defun completion--string-equal-p (s1 s2)
543 (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
544
ef24141c 545(defun completion--twq-all (string ustring completions boundary
51646b62 546 _unquote requote)
ef24141c
SM
547 (when completions
548 (pcase-let*
549 ((prefix
550 (let ((completion-regexp-list nil))
551 (try-completion "" (cons (substring ustring boundary)
552 completions))))
553 (`(,qfullpos . ,qfun)
554 (funcall requote (+ boundary (length prefix)) string))
555 (qfullprefix (substring string 0 qfullpos))
b9383404
SM
556 ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where
557 ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/".
558 ;;(cl-assert (completion--string-equal-p
559 ;; (funcall unquote qfullprefix)
560 ;; (concat (substring ustring 0 boundary) prefix))
561 ;; t))
ef24141c 562 (qboundary (car (funcall requote boundary string)))
f58e0fd5 563 (_ (cl-assert (<= qboundary qfullpos)))
ef24141c
SM
564 ;; FIXME: this split/quote/concat business messes up the carefully
565 ;; placed completions-common-part and completions-first-difference
566 ;; faces. We could try within the mapcar loop to search for the
567 ;; boundaries of those faces, pass them to `requote' to find their
568 ;; equivalent positions in the quoted output and re-add the faces:
569 ;; this might actually lead to correct results but would be
570 ;; pretty expensive.
571 ;; The better solution is to not quote the *Completions* display,
572 ;; which nicely circumvents the problem. The solution I used here
573 ;; instead is to hope that `qfun' preserves the text-properties and
574 ;; presume that the `first-difference' is not within the `prefix';
575 ;; this presumption is not always true, but at least in practice it is
576 ;; true in most cases.
577 (qprefix (propertize (substring qfullprefix qboundary)
578 'face 'completions-common-part)))
579
580 ;; Here we choose to quote all elements returned, but a better option
581 ;; would be to return unquoted elements together with a function to
582 ;; requote them, so that *Completions* can show nicer unquoted values
583 ;; which only get quoted when needed by choose-completion.
584 (nconc
585 (mapcar (lambda (completion)
f58e0fd5 586 (cl-assert (string-prefix-p prefix completion 'ignore-case) t)
ef24141c
SM
587 (let* ((new (substring completion (length prefix)))
588 (qnew (funcall qfun new))
158bc55c
SB
589 (qprefix
590 (if (not completion-ignore-case)
591 qprefix
592 ;; Make qprefix inherit the case from `completion'.
593 (let* ((rest (substring completion
594 0 (length prefix)))
595 (qrest (funcall qfun rest)))
596 (if (completion--string-equal-p qprefix qrest)
597 (propertize qrest 'face
598 'completions-common-part)
599 qprefix))))
ef24141c 600 (qcompletion (concat qprefix qnew)))
b9383404
SM
601 ;; FIXME: Similarly here, Cygwin's mapping trips this
602 ;; assertion.
603 ;;(cl-assert
604 ;; (completion--string-equal-p
605 ;; (funcall unquote
606 ;; (concat (substring string 0 qboundary)
607 ;; qcompletion))
608 ;; (concat (substring ustring 0 boundary)
609 ;; completion))
610 ;; t)
ef24141c
SM
611 qcompletion))
612 completions)
613 qboundary))))
614
25c0d999
SM
615;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
616;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
e2947429
SM
617(define-obsolete-function-alias
618 'complete-in-turn 'completion-table-in-turn "23.1")
25c0d999
SM
619(define-obsolete-function-alias
620 'dynamic-completion-table 'completion-table-dynamic "23.1")
21622c6d
SM
621
622;;; Minibuffer completion
623
ba5ff07b
SM
624(defgroup minibuffer nil
625 "Controlling the behavior of the minibuffer."
626 :link '(custom-manual "(emacs)Minibuffer")
627 :group 'environment)
628
32bae13c
SM
629(defun minibuffer-message (message &rest args)
630 "Temporarily display MESSAGE at the end of the minibuffer.
631The text is displayed for `minibuffer-message-timeout' seconds,
632or until the next input event arrives, whichever comes first.
633Enclose MESSAGE in [...] if this is not yet the case.
634If ARGS are provided, then pass MESSAGE through `format'."
ab22be48
SM
635 (if (not (minibufferp (current-buffer)))
636 (progn
637 (if args
638 (apply 'message message args)
639 (message "%s" message))
640 (prog1 (sit-for (or minibuffer-message-timeout 1000000))
641 (message nil)))
642 ;; Clear out any old echo-area message to make way for our new thing.
643 (message nil)
67982e2b
SM
644 (setq message (if (and (null args)
645 (string-match-p "\\` *\\[.+\\]\\'" message))
ab22be48
SM
646 ;; Make sure we can put-text-property.
647 (copy-sequence message)
648 (concat " [" message "]")))
649 (when args (setq message (apply 'format message args)))
650 (let ((ol (make-overlay (point-max) (point-max) nil t t))
651 ;; A quit during sit-for normally only interrupts the sit-for,
652 ;; but since minibuffer-message is used at the end of a command,
653 ;; at a time when the command has virtually finished already, a C-g
654 ;; should really cause an abort-recursive-edit instead (i.e. as if
655 ;; the C-g had been typed at top-level). Binding inhibit-quit here
656 ;; is an attempt to get that behavior.
657 (inhibit-quit t))
658 (unwind-protect
659 (progn
660 (unless (zerop (length message))
661 ;; The current C cursor code doesn't know to use the overlay's
662 ;; marker's stickiness to figure out whether to place the cursor
663 ;; before or after the string, so let's spoon-feed it the pos.
664 (put-text-property 0 1 'cursor t message))
665 (overlay-put ol 'after-string message)
666 (sit-for (or minibuffer-message-timeout 1000000)))
667 (delete-overlay ol)))))
32bae13c
SM
668
669(defun minibuffer-completion-contents ()
670 "Return the user input in a minibuffer before point as a string.
1d829c64
SM
671In Emacs-22, that was what completion commands operated on."
672 (declare (obsolete nil "24.4"))
67982e2b 673 (buffer-substring (minibuffer-prompt-end) (point)))
32bae13c
SM
674
675(defun delete-minibuffer-contents ()
676 "Delete all user input in a minibuffer.
677If the current buffer is not a minibuffer, erase its entire contents."
d39109c3 678 (interactive)
8c9f211f
CY
679 ;; We used to do `delete-field' here, but when file name shadowing
680 ;; is on, the field doesn't cover the entire minibuffer contents.
681 (delete-region (minibuffer-prompt-end) (point-max)))
32bae13c 682
369e974d
CY
683(defvar completion-show-inline-help t
684 "If non-nil, print helpful inline messages during completion.")
685
ba5ff07b
SM
686(defcustom completion-auto-help t
687 "Non-nil means automatically provide help for invalid completion input.
688If the value is t the *Completion* buffer is displayed whenever completion
689is requested but cannot be done.
690If the value is `lazy', the *Completions* buffer is only displayed after
691the second failed attempt to complete."
67982e2b 692 :type '(choice (const nil) (const t) (const lazy)))
ba5ff07b 693
2f7f4bee 694(defconst completion-styles-alist
fcb68f70
SM
695 '((emacs21
696 completion-emacs21-try-completion completion-emacs21-all-completions
79d74ac5
SM
697 "Simple prefix-based completion.
698I.e. when completing \"foo_bar\" (where _ is the position of point),
699it will consider all completions candidates matching the glob
700pattern \"foobar*\".")
fcb68f70
SM
701 (emacs22
702 completion-emacs22-try-completion completion-emacs22-all-completions
79d74ac5
SM
703 "Prefix completion that only operates on the text before point.
704I.e. when completing \"foo_bar\" (where _ is the position of point),
705it will consider all completions candidates matching the glob
706pattern \"foo*\" and will add back \"bar\" to the end of it.")
fcb68f70
SM
707 (basic
708 completion-basic-try-completion completion-basic-all-completions
79d74ac5
SM
709 "Completion of the prefix before point and the suffix after point.
710I.e. when completing \"foo_bar\" (where _ is the position of point),
711it will consider all completions candidates matching the glob
712pattern \"foo*bar*\".")
34200787 713 (partial-completion
fcb68f70
SM
714 completion-pcm-try-completion completion-pcm-all-completions
715 "Completion of multiple words, each one taken as a prefix.
79d74ac5
SM
716I.e. when completing \"l-co_h\" (where _ is the position of point),
717it will consider all completions candidates matching the glob
718pattern \"l*-co*h*\".
719Furthermore, for completions that are done step by step in subfields,
720the method is applied to all the preceding fields that do not yet match.
721E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src.
722Additionally the user can use the char \"*\" as a glob pattern.")
56d365a9
SM
723 (substring
724 completion-substring-try-completion completion-substring-all-completions
725 "Completion of the string taken as a substring.
726I.e. when completing \"foo_bar\" (where _ is the position of point),
727it will consider all completions candidates matching the glob
728pattern \"*foo*bar*\".")
fcb68f70
SM
729 (initials
730 completion-initials-try-completion completion-initials-all-completions
731 "Completion of acronyms and initialisms.
732E.g. can complete M-x lch to list-command-history
733and C-x C-f ~/sew to ~/src/emacs/work."))
e2947429 734 "List of available completion styles.
fcb68f70 735Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC):
26c548b0 736where NAME is the name that should be used in `completion-styles',
fcb68f70
SM
737TRY-COMPLETION is the function that does the completion (it should
738follow the same calling convention as `completion-try-completion'),
739ALL-COMPLETIONS is the function that lists the completions (it should
740follow the calling convention of `completion-all-completions'),
741and DOC describes the way this style of completion works.")
e2947429 742
3dc61a09
SM
743(defconst completion--styles-type
744 `(repeat :tag "insert a new menu to add more styles"
745 (choice ,@(mapcar (lambda (x) (list 'const (car x)))
746 completion-styles-alist))))
747(defconst completion--cycling-threshold-type
748 '(choice (const :tag "No cycling" nil)
749 (const :tag "Always cycle" t)
750 (integer :tag "Threshold")))
751
79d74ac5
SM
752(defcustom completion-styles
753 ;; First, use `basic' because prefix completion has been the standard
754 ;; for "ever" and works well in most cases, so using it first
755 ;; ensures that we obey previous behavior in most cases.
756 '(basic
757 ;; Then use `partial-completion' because it has proven to
758 ;; be a very convenient extension.
759 partial-completion
760 ;; Finally use `emacs22' so as to maintain (in many/most cases)
761 ;; the previous behavior that when completing "foobar" with point
762 ;; between "foo" and "bar" the completion try to complete "foo"
763 ;; and simply add "bar" to the end of the result.
764 emacs22)
265d4549 765 "List of completion styles to use.
693fbdb6
EZ
766The available styles are listed in `completion-styles-alist'.
767
768Note that `completion-category-overrides' may override these
769styles for specific categories, such as files, buffers, etc."
3dc61a09 770 :type completion--styles-type
e2947429
SM
771 :version "23.1")
772
620c53a6
SM
773(defcustom completion-category-overrides
774 '((buffer (styles . (basic substring))))
693fbdb6 775 "List of `completion-styles' overrides for specific categories.
620c53a6
SM
776Each override has the shape (CATEGORY . ALIST) where ALIST is
777an association list that can specify properties such as:
778- `styles': the list of `completion-styles' to use for that category.
49fe4321
GM
779- `cycle': the `completion-cycle-threshold' to use for that category.
780Categories are symbols such as `buffer' and `file', used when
781completing buffer and file names, respectively."
2bed3f04 782 :version "24.1"
8ea0a993
SB
783 :type `(alist :key-type (choice :tag "Category"
784 (const buffer)
620c53a6 785 (const file)
3dc61a09 786 (const unicode-name)
55f197b2 787 (const bookmark)
620c53a6
SM
788 symbol)
789 :value-type
8ea0a993
SB
790 (set :tag "Properties to override"
791 (cons :tag "Completion Styles"
792 (const :tag "Select a style from the menu;" styles)
3dc61a09 793 ,completion--styles-type)
8ea0a993
SB
794 (cons :tag "Completion Cycling"
795 (const :tag "Select one value from the menu." cycle)
3dc61a09 796 ,completion--cycling-threshold-type))))
620c53a6
SM
797
798(defun completion--styles (metadata)
799 (let* ((cat (completion-metadata-get metadata 'category))
800 (over (assq 'styles (cdr (assq cat completion-category-overrides)))))
801 (if over
802 (delete-dups (append (cdr over) (copy-sequence completion-styles)))
803 completion-styles)))
804
ef24141c
SM
805(defun completion--nth-completion (n string table pred point metadata)
806 "Call the Nth method of completion styles."
807 (unless metadata
808 (setq metadata
809 (completion-metadata (substring string 0 point) table pred)))
810 ;; We provide special support for quoting/unquoting here because it cannot
811 ;; reliably be done within the normal completion-table routines: Completion
812 ;; styles such as `substring' or `partial-completion' need to match the
813 ;; output of all-completions with the user's input, and since most/all
814 ;; quoting mechanisms allow several equivalent quoted forms, the
815 ;; completion-style can't do this matching (e.g. `substring' doesn't know
816 ;; that "\a\b\e" is a valid (quoted) substring of "label").
817 ;; The quote/unquote function needs to come from the completion table (rather
818 ;; than from completion-extra-properties) because it may apply only to some
819 ;; part of the string (e.g. substitute-in-file-name).
820 (let ((requote
821 (when (completion-metadata-get metadata 'completion--unquote-requote)
822 (let ((new (funcall table string point 'completion--unquote)))
823 (setq string (pop new))
824 (setq table (pop new))
825 (setq point (pop new))
826 (pop new))))
827 (result
828 (completion--some (lambda (style)
829 (funcall (nth n (assq style
830 completion-styles-alist))
831 string table pred point))
832 (completion--styles metadata))))
833 (if requote
834 (funcall requote result n)
835 result)))
836
4cb3bfa0 837(defun completion-try-completion (string table pred point &optional metadata)
19c04f39
SM
838 "Try to complete STRING using completion table TABLE.
839Only the elements of table that satisfy predicate PRED are considered.
840POINT is the position of point within STRING.
841The return value can be either nil to indicate that there is no completion,
842t to indicate that STRING is the only possible completion,
ef24141c 843or a pair (NEWSTRING . NEWPOINT) of the completed result string together with
19c04f39 844a new position for point."
ef24141c 845 (completion--nth-completion 1 string table pred point metadata))
e2947429 846
4cb3bfa0 847(defun completion-all-completions (string table pred point &optional metadata)
19c04f39
SM
848 "List the possible completions of STRING in completion table TABLE.
849Only the elements of table that satisfy predicate PRED are considered.
850POINT is the position of point within STRING.
26c548b0 851The return value is a list of completions and may contain the base-size
19c04f39 852in the last `cdr'."
365b9a62
SM
853 ;; FIXME: We need to additionally return the info needed for the
854 ;; second part of completion-base-position.
ef24141c 855 (completion--nth-completion 2 string table pred point metadata))
e2947429 856
ba5ff07b
SM
857(defun minibuffer--bitset (modified completions exact)
858 (logior (if modified 4 0)
859 (if completions 2 0)
860 (if exact 1 0)))
861
c53b9c3b
SM
862(defun completion--replace (beg end newtext)
863 "Replace the buffer text between BEG and END with NEWTEXT.
864Moves point to the end of the new text."
1d00653d
SM
865 ;; The properties on `newtext' include things like
866 ;; completions-first-difference, which we don't want to include
867 ;; upon insertion.
868 (set-text-properties 0 (length newtext) nil newtext)
55586d2a 869 ;; Maybe this should be in subr.el.
c53b9c3b
SM
870 ;; You'd think this is trivial to do, but details matter if you want
871 ;; to keep markers "at the right place" and be robust in the face of
872 ;; after-change-functions that may themselves modify the buffer.
55586d2a
SM
873 (let ((prefix-len 0))
874 ;; Don't touch markers in the shared prefix (if any).
875 (while (and (< prefix-len (length newtext))
876 (< (+ beg prefix-len) end)
877 (eq (char-after (+ beg prefix-len))
878 (aref newtext prefix-len)))
879 (setq prefix-len (1+ prefix-len)))
880 (unless (zerop prefix-len)
881 (setq beg (+ beg prefix-len))
882 (setq newtext (substring newtext prefix-len))))
883 (let ((suffix-len 0))
884 ;; Don't touch markers in the shared suffix (if any).
885 (while (and (< suffix-len (length newtext))
886 (< beg (- end suffix-len))
887 (eq (char-before (- end suffix-len))
888 (aref newtext (- (length newtext) suffix-len 1))))
889 (setq suffix-len (1+ suffix-len)))
890 (unless (zerop suffix-len)
891 (setq end (- end suffix-len))
8348910a
SM
892 (setq newtext (substring newtext 0 (- suffix-len))))
893 (goto-char beg)
6cad7ba3
JS
894 (let ((length (- end beg))) ;Read `end' before we insert the text.
895 (insert-and-inherit newtext)
896 (delete-region (point) (+ (point) length)))
8348910a 897 (forward-char suffix-len)))
c53b9c3b 898
902a6d8d
SM
899(defcustom completion-cycle-threshold nil
900 "Number of completion candidates below which cycling is used.
67982e2b 901Depending on this setting `completion-in-region' may use cycling,
902a6d8d
SM
902like `minibuffer-force-complete'.
903If nil, cycling is never used.
904If t, cycling is always used.
281c9d2b
GM
905If an integer, cycling is used so long as there are not more
906completion candidates than this number."
2bed3f04 907 :version "24.1"
3dc61a09 908 :type completion--cycling-threshold-type)
902a6d8d 909
620c53a6
SM
910(defun completion--cycle-threshold (metadata)
911 (let* ((cat (completion-metadata-get metadata 'category))
912 (over (assq 'cycle (cdr (assq cat completion-category-overrides)))))
913 (if over (cdr over) completion-cycle-threshold)))
914
67982e2b 915(defvar-local completion-all-sorted-completions nil)
d92df117 916(defvar-local completion--all-sorted-completions-location nil)
6175cd08
SM
917(defvar completion-cycling nil)
918
b7e270a2
SM
919(defvar completion-fail-discreetly nil
920 "If non-nil, stay quiet when there is no match.")
921
ef80fc09
SM
922(defun completion--message (msg)
923 (if completion-show-inline-help
924 (minibuffer-message msg)))
925
67982e2b
SM
926(defun completion--do-completion (beg end &optional
927 try-completion-function expect-exact)
32bae13c 928 "Do the completion and return a summary of what happened.
ba5ff07b
SM
929M = completion was performed, the text was Modified.
930C = there were available Completions.
931E = after completion we now have an Exact match.
932
933 MCE
934 000 0 no possible completion
935 001 1 was already an exact and unique completion
936 010 2 no completion happened
937 011 3 was already an exact completion
938 100 4 ??? impossible
939 101 5 ??? impossible
940 110 6 some completion happened
a2a25d24
SM
941 111 7 completed to an exact completion
942
943TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'.
944EXPECT-EXACT, if non-nil, means that there is no need to tell the user
945when the buffer's text is already an exact match."
67982e2b 946 (let* ((string (buffer-substring beg end))
620c53a6 947 (md (completion--field-metadata beg))
a647cb26
SM
948 (comp (funcall (or try-completion-function
949 'completion-try-completion)
950 string
951 minibuffer-completion-table
952 minibuffer-completion-predicate
620c53a6
SM
953 (- (point) beg)
954 md)))
32bae13c 955 (cond
19c04f39 956 ((null comp)
890429cc 957 (minibuffer-hide-completions)
ef80fc09 958 (unless completion-fail-discreetly
369e974d 959 (ding)
ef80fc09 960 (completion--message "No match"))
b7e270a2 961 (minibuffer--bitset nil nil nil))
265d4549 962 ((eq t comp)
890429cc 963 (minibuffer-hide-completions)
a2a25d24
SM
964 (goto-char end)
965 (completion--done string 'finished
966 (unless expect-exact "Sole completion"))
6175cd08 967 (minibuffer--bitset nil nil t)) ;Exact and unique match.
32bae13c
SM
968 (t
969 ;; `completed' should be t if some completion was done, which doesn't
970 ;; include simply changing the case of the entered string. However,
971 ;; for appearance, the string is rewritten if the case changes.
a647cb26
SM
972 (let* ((comp-pos (cdr comp))
973 (completion (car comp))
974 (completed (not (eq t (compare-strings completion nil nil
975 string nil nil t))))
976 (unchanged (eq t (compare-strings completion nil nil
977 string nil nil nil))))
c53b9c3b 978 (if unchanged
397ae226 979 (goto-char end)
c53b9c3b 980 ;; Insert in minibuffer the chars we got.
67982e2b
SM
981 (completion--replace beg end completion)
982 (setq end (+ beg (length completion))))
c53b9c3b
SM
983 ;; Move point to its completion-mandated destination.
984 (forward-char (- comp-pos (length completion)))
ba5ff07b 985
32bae13c 986 (if (not (or unchanged completed))
6175cd08
SM
987 ;; The case of the string changed, but that's all. We're not sure
988 ;; whether this is a unique completion or not, so try again using
989 ;; the real case (this shouldn't recurse again, because the next
990 ;; time try-completion will return either t or the exact string).
67982e2b
SM
991 (completion--do-completion beg end
992 try-completion-function expect-exact)
32bae13c
SM
993
994 ;; It did find a match. Do we match some possibility exactly now?
620c53a6 995 (let* ((exact (test-completion completion
3e88618b
SM
996 minibuffer-completion-table
997 minibuffer-completion-predicate))
620c53a6 998 (threshold (completion--cycle-threshold md))
3e88618b
SM
999 (comps
1000 ;; Check to see if we want to do cycling. We do it
1001 ;; here, after having performed the normal completion,
1002 ;; so as to take advantage of the difference between
1003 ;; try-completion and all-completions, for things
1004 ;; like completion-ignored-extensions.
620c53a6 1005 (when (and threshold
3e88618b
SM
1006 ;; Check that the completion didn't make
1007 ;; us jump to a different boundary.
1008 (or (not completed)
1009 (< (car (completion-boundaries
1010 (substring completion 0 comp-pos)
1011 minibuffer-completion-table
1012 minibuffer-completion-predicate
902a6d8d
SM
1013 ""))
1014 comp-pos)))
67982e2b 1015 (completion-all-sorted-completions beg end))))
6175cd08 1016 (completion--flush-all-sorted-completions)
902a6d8d 1017 (cond
6175cd08
SM
1018 ((and (consp (cdr comps)) ;; There's something to cycle.
1019 (not (ignore-errors
902a6d8d
SM
1020 ;; This signal an (intended) error if comps is too
1021 ;; short or if completion-cycle-threshold is t.
620c53a6 1022 (consp (nthcdr threshold comps)))))
281c9d2b 1023 ;; Not more than completion-cycle-threshold remaining
902a6d8d
SM
1024 ;; completions: let's cycle.
1025 (setq completed t exact t)
67982e2b
SM
1026 (completion--cache-all-sorted-completions beg end comps)
1027 (minibuffer-force-complete beg end))
902a6d8d 1028 (completed
6175cd08
SM
1029 ;; We could also decide to refresh the completions,
1030 ;; if they're displayed (and assuming there are
1031 ;; completions left).
a2a25d24
SM
1032 (minibuffer-hide-completions)
1033 (if exact
1034 ;; If completion did not put point at end of field,
1035 ;; it's a sign that completion is not finished.
1036 (completion--done completion
1037 (if (< comp-pos (length completion))
1038 'exact 'unknown))))
6175cd08
SM
1039 ;; Show the completion table, if requested.
1040 ((not exact)
f58e0fd5
SM
1041 (if (pcase completion-auto-help
1042 (`lazy (eq this-command last-command))
1043 (_ completion-auto-help))
67982e2b 1044 (minibuffer-completion-help beg end)
ef80fc09 1045 (completion--message "Next char not unique")))
6175cd08 1046 ;; If the last exact completion and this one were the same, it
ef80fc09 1047 ;; means we've already given a "Complete, but not unique" message
6175cd08 1048 ;; and the user's hit TAB again, so now we give him help.
a2a25d24
SM
1049 (t
1050 (if (and (eq this-command last-command) completion-auto-help)
67982e2b 1051 (minibuffer-completion-help beg end))
a2a25d24
SM
1052 (completion--done completion 'exact
1053 (unless expect-exact
1054 "Complete, but not unique"))))
ba5ff07b
SM
1055
1056 (minibuffer--bitset completed t exact))))))))
32bae13c
SM
1057
1058(defun minibuffer-complete ()
1059 "Complete the minibuffer contents as far as possible.
1060Return nil if there is no valid completion, else t.
1061If no characters can be completed, display a list of possible completions.
1062If you repeat this command after it displayed such a list,
1063scroll the window of possible completions."
1064 (interactive)
67982e2b
SM
1065 (completion-in-region (minibuffer-prompt-end) (point-max)
1066 minibuffer-completion-table
1067 minibuffer-completion-predicate))
1068
1069(defun completion--in-region-1 (beg end)
32bae13c
SM
1070 ;; If the previous command was not this,
1071 ;; mark the completion buffer obsolete.
dbbc2e69
SM
1072 (setq this-command 'completion-at-point)
1073 (unless (eq 'completion-at-point last-command)
6175cd08 1074 (completion--flush-all-sorted-completions)
32bae13c
SM
1075 (setq minibuffer-scroll-window nil))
1076
902a6d8d 1077 (cond
03408648
SM
1078 ;; If there's a fresh completion window with a live buffer,
1079 ;; and this command is repeated, scroll that window.
21e8fe2f
SM
1080 ((and (window-live-p minibuffer-scroll-window)
1081 (eq t (frame-visible-p (window-frame minibuffer-scroll-window))))
902a6d8d 1082 (let ((window minibuffer-scroll-window))
03408648
SM
1083 (with-current-buffer (window-buffer window)
1084 (if (pos-visible-in-window-p (point-max) window)
1085 ;; If end is in view, scroll up to the beginning.
1086 (set-window-start window (point-min) nil)
1087 ;; Else scroll down one screen.
c484f866
JS
1088 (with-selected-window window
1089 (scroll-up)))
902a6d8d
SM
1090 nil)))
1091 ;; If we're cycling, keep on cycling.
6175cd08 1092 ((and completion-cycling completion-all-sorted-completions)
67982e2b 1093 (minibuffer-force-complete beg end)
902a6d8d 1094 t)
67982e2b 1095 (t (pcase (completion--do-completion beg end)
a38313e1 1096 (#b000 nil)
f58e0fd5 1097 (_ t)))))
32bae13c 1098
67982e2b 1099(defun completion--cache-all-sorted-completions (beg end comps)
3e88618b 1100 (add-hook 'after-change-functions
d92df117
SM
1101 'completion--flush-all-sorted-completions nil t)
1102 (setq completion--all-sorted-completions-location
67982e2b 1103 (cons (copy-marker beg) (copy-marker end)))
3e88618b
SM
1104 (setq completion-all-sorted-completions comps))
1105
5c788776 1106(defun completion--flush-all-sorted-completions (&optional start end _len)
d92df117
SM
1107 (unless (and start end
1108 (or (> start (cdr completion--all-sorted-completions-location))
1109 (< end (car completion--all-sorted-completions-location))))
1110 (remove-hook 'after-change-functions
1111 'completion--flush-all-sorted-completions t)
1112 (setq completion-cycling nil)
1113 (setq completion-all-sorted-completions nil)))
14c24780 1114
30a23501
SM
1115(defun completion--metadata (string base md-at-point table pred)
1116 ;; Like completion-metadata, but for the specific case of getting the
1117 ;; metadata at `base', which tends to trigger pathological behavior for old
1118 ;; completion tables which don't understand `metadata'.
1119 (let ((bounds (completion-boundaries string table pred "")))
1120 (if (eq (car bounds) base) md-at-point
1121 (completion-metadata (substring string 0 base) table pred))))
1122
39587580 1123(defun completion-all-sorted-completions (&optional start end)
14c24780 1124 (or completion-all-sorted-completions
67982e2b
SM
1125 (let* ((start (or start (minibuffer-prompt-end)))
1126 (end (or end (point-max)))
620c53a6 1127 (string (buffer-substring start end))
30a23501 1128 (md (completion--field-metadata start))
620c53a6
SM
1129 (all (completion-all-completions
1130 string
1131 minibuffer-completion-table
1132 minibuffer-completion-predicate
1133 (- (point) start)
30a23501 1134 md))
14c24780 1135 (last (last all))
620c53a6 1136 (base-size (or (cdr last) 0))
30a23501
SM
1137 (all-md (completion--metadata (buffer-substring-no-properties
1138 start (point))
1139 base-size md
1140 minibuffer-completion-table
1141 minibuffer-completion-predicate))
620c53a6 1142 (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
14c24780
SM
1143 (when last
1144 (setcdr last nil)
cc37e70f
J
1145
1146 ;; Delete duplicates: do it after setting last's cdr to nil (so
1147 ;; it's a proper list), and be careful to reset `last' since it
1148 ;; may be a different cons-cell.
1149 (setq all (delete-dups all))
1150 (setq last (last all))
1151
620c53a6
SM
1152 (setq all (if sort-fun (funcall sort-fun all)
1153 ;; Prefer shorter completions, by default.
1154 (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
14c24780 1155 ;; Prefer recently used completions.
a2a25d24
SM
1156 (when (minibufferp)
1157 (let ((hist (symbol-value minibuffer-history-variable)))
1158 (setq all (sort all (lambda (c1 c2)
1159 (> (length (member c1 hist))
1160 (length (member c2 hist))))))))
14c24780
SM
1161 ;; Cache the result. This is not just for speed, but also so that
1162 ;; repeated calls to minibuffer-force-complete can cycle through
1163 ;; all possibilities.
67982e2b
SM
1164 (completion--cache-all-sorted-completions
1165 start end (nconc all base-size))))))
14c24780 1166
cc37e70f
J
1167(defun minibuffer-force-complete-and-exit ()
1168 "Complete the minibuffer with first of the matches and exit."
1169 (interactive)
1170 (minibuffer-force-complete)
67982e2b
SM
1171 (completion--complete-and-exit
1172 (minibuffer-prompt-end) (point-max) #'exit-minibuffer
cc37e70f
J
1173 ;; If the previous completion completed to an element which fails
1174 ;; test-completion, then we shouldn't exit, but that should be rare.
1175 (lambda () (minibuffer-message "Incomplete"))))
1176
67982e2b 1177(defun minibuffer-force-complete (&optional start end)
14c24780
SM
1178 "Complete the minibuffer to an exact match.
1179Repeated uses step through the possible completions."
1180 (interactive)
21e8fe2f 1181 (setq minibuffer-scroll-window nil)
14c24780 1182 ;; FIXME: Need to deal with the extra-size issue here as well.
528c56e2
SM
1183 ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
1184 ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
67982e2b
SM
1185 (let* ((start (copy-marker (or start (minibuffer-prompt-end))))
1186 (end (or end (point-max)))
620c53a6 1187 ;; (md (completion--field-metadata start))
67982e2b 1188 (all (completion-all-sorted-completions start end))
a2a25d24
SM
1189 (base (+ start (or (cdr (last all)) 0))))
1190 (cond
1191 ((not (consp all))
ef80fc09 1192 (completion--message
a2a25d24
SM
1193 (if all "No more completions" "No completions")))
1194 ((not (consp (cdr all)))
414a8595
SM
1195 (let ((done (equal (car all) (buffer-substring-no-properties base end))))
1196 (unless done (completion--replace base end (car all)))
a2a25d24 1197 (completion--done (buffer-substring-no-properties start (point))
414a8595 1198 'finished (when done "Sole completion"))))
a2a25d24 1199 (t
a2a25d24 1200 (completion--replace base end (car all))
67982e2b 1201 (setq end (+ base (length (car all))))
a2a25d24 1202 (completion--done (buffer-substring-no-properties start (point)) 'sole)
3e88618b
SM
1203 ;; Set cycling after modifying the buffer since the flush hook resets it.
1204 (setq completion-cycling t)
67982e2b 1205 (setq this-command 'completion-at-point) ;For completion-in-region.
14c24780
SM
1206 ;; If completing file names, (car all) may be a directory, so we'd now
1207 ;; have a new set of possible completions and might want to reset
1208 ;; completion-all-sorted-completions to nil, but we prefer not to,
1209 ;; so that repeated calls minibuffer-force-complete still cycle
1210 ;; through the previous possible completions.
075518b5
SM
1211 (let ((last (last all)))
1212 (setcdr last (cons (car all) (cdr last)))
67982e2b 1213 (completion--cache-all-sorted-completions start end (cdr all)))
8e808318
SM
1214 ;; Make sure repeated uses cycle, even though completion--done might
1215 ;; have added a space or something that moved us outside of the field.
1216 ;; (bug#12221).
1217 (let* ((table minibuffer-completion-table)
1218 (pred minibuffer-completion-predicate)
1219 (extra-prop completion-extra-properties)
1220 (cmd
1221 (lambda () "Cycle through the possible completions."
1222 (interactive)
1223 (let ((completion-extra-properties extra-prop))
1224 (completion-in-region start (point) table pred)))))
1225 (set-temporary-overlay-map
1226 (let ((map (make-sparse-keymap)))
1227 (define-key map [remap completion-at-point] cmd)
1228 (define-key map (vector last-command-event) cmd)
1229 map)))))))
14c24780 1230
d1826585 1231(defvar minibuffer-confirm-exit-commands
ec55c5e0
SM
1232 '(completion-at-point minibuffer-complete
1233 minibuffer-complete-word PC-complete PC-complete-word)
d1826585
MB
1234 "A list of commands which cause an immediately following
1235`minibuffer-complete-and-exit' to ask for extra confirmation.")
1236
32bae13c 1237(defun minibuffer-complete-and-exit ()
bec1e8a5
CY
1238 "Exit if the minibuffer contains a valid completion.
1239Otherwise, try to complete the minibuffer contents. If
1240completion leads to a valid completion, a repetition of this
1241command will exit.
1242
1243If `minibuffer-completion-confirm' is `confirm', do not try to
1244 complete; instead, ask for confirmation and accept any input if
1245 confirmed.
1246If `minibuffer-completion-confirm' is `confirm-after-completion',
1247 do not try to complete; instead, ask for confirmation if the
90810a8e
CY
1248 preceding minibuffer command was a member of
1249 `minibuffer-confirm-exit-commands', and accept the input
1250 otherwise."
32bae13c 1251 (interactive)
67982e2b
SM
1252 (completion-complete-and-exit (minibuffer-prompt-end) (point-max)
1253 #'exit-minibuffer))
1254
1255(defun completion-complete-and-exit (beg end exit-function)
1256 (completion--complete-and-exit
1257 beg end exit-function
cc37e70f
J
1258 (lambda ()
1259 (pcase (condition-case nil
67982e2b
SM
1260 (completion--do-completion beg end
1261 nil 'expect-exact)
cc37e70f 1262 (error 1))
67982e2b 1263 ((or #b001 #b011) (funcall exit-function))
cc37e70f 1264 (#b111 (if (not minibuffer-completion-confirm)
67982e2b 1265 (funcall exit-function)
cc37e70f
J
1266 (minibuffer-message "Confirm")
1267 nil))
1268 (_ nil)))))
1269
67982e2b
SM
1270(defun completion--complete-and-exit (beg end
1271 exit-function completion-function)
cc37e70f
J
1272 "Exit from `require-match' minibuffer.
1273COMPLETION-FUNCTION is called if the current buffer's content does not
1274appear to be a match."
3911966b
SM
1275 (cond
1276 ;; Allow user to specify null string
67982e2b 1277 ((= beg end) (funcall exit-function))
3911966b
SM
1278 ((test-completion (buffer-substring beg end)
1279 minibuffer-completion-table
1280 minibuffer-completion-predicate)
365b9a62
SM
1281 ;; FIXME: completion-ignore-case has various slightly
1282 ;; incompatible meanings. E.g. it can reflect whether the user
1283 ;; wants completion to pay attention to case, or whether the
1284 ;; string will be used in a context where case is significant.
1285 ;; E.g. usually try-completion should obey the first, whereas
1286 ;; test-completion should obey the second.
3911966b
SM
1287 (when completion-ignore-case
1288 ;; Fixup case of the field, if necessary.
b0a5a021 1289 (let* ((string (buffer-substring beg end))
3911966b
SM
1290 (compl (try-completion
1291 string
1292 minibuffer-completion-table
1293 minibuffer-completion-predicate)))
365b9a62 1294 (when (and (stringp compl) (not (equal string compl))
3911966b
SM
1295 ;; If it weren't for this piece of paranoia, I'd replace
1296 ;; the whole thing with a call to do-completion.
eee6de73
SM
1297 ;; This is important, e.g. when the current minibuffer's
1298 ;; content is a directory which only contains a single
1299 ;; file, so `try-completion' actually completes to
1300 ;; that file.
3911966b 1301 (= (length string) (length compl)))
96a8a0df 1302 (completion--replace beg end compl))))
67982e2b 1303 (funcall exit-function))
32bae13c 1304
365b9a62 1305 ((memq minibuffer-completion-confirm '(confirm confirm-after-completion))
3911966b 1306 ;; The user is permitted to exit with an input that's rejected
bec1e8a5 1307 ;; by test-completion, after confirming her choice.
365b9a62
SM
1308 (if (or (eq last-command this-command)
1309 ;; For `confirm-after-completion' we only ask for confirmation
1310 ;; if trying to exit immediately after typing TAB (this
1311 ;; catches most minibuffer typos).
1312 (and (eq minibuffer-completion-confirm 'confirm-after-completion)
1313 (not (memq last-command minibuffer-confirm-exit-commands))))
67982e2b 1314 (funcall exit-function)
3911966b
SM
1315 (minibuffer-message "Confirm")
1316 nil))
32bae13c 1317
3911966b
SM
1318 (t
1319 ;; Call do-completion, but ignore errors.
67982e2b 1320 (funcall completion-function))))
3911966b 1321
620c53a6
SM
1322(defun completion--try-word-completion (string table predicate point md)
1323 (let ((comp (completion-try-completion string table predicate point md)))
19c04f39
SM
1324 (if (not (consp comp))
1325 comp
32bae13c 1326
3911966b
SM
1327 ;; If completion finds next char not unique,
1328 ;; consider adding a space or a hyphen.
19c04f39 1329 (when (= (length string) (length (car comp)))
1afbbf85
SM
1330 ;; Mark the added char with the `completion-word' property, so it
1331 ;; can be handled specially by completion styles such as
1332 ;; partial-completion.
1333 ;; We used to remove `partial-completion' from completion-styles
1334 ;; instead, but it was too blunt, leading to situations where SPC
1335 ;; was the only insertable char at point but minibuffer-complete-word
1336 ;; refused inserting it.
1337 (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t))
1338 '(" " "-")))
19c04f39
SM
1339 (before (substring string 0 point))
1340 (after (substring string point))
1341 tem)
1342 (while (and exts (not (consp tem)))
3911966b 1343 (setq tem (completion-try-completion
19c04f39 1344 (concat before (pop exts) after)
620c53a6 1345 table predicate (1+ point) md)))
19c04f39 1346 (if (consp tem) (setq comp tem))))
3911966b 1347
32bae13c
SM
1348 ;; Completing a single word is actually more difficult than completing
1349 ;; as much as possible, because we first have to find the "current
1350 ;; position" in `completion' in order to find the end of the word
1351 ;; we're completing. Normally, `string' is a prefix of `completion',
1352 ;; which makes it trivial to find the position, but with fancier
1353 ;; completion (plus env-var expansion, ...) `completion' might not
1354 ;; look anything like `string' at all.
19c04f39
SM
1355 (let* ((comppoint (cdr comp))
1356 (completion (car comp))
1357 (before (substring string 0 point))
1358 (combined (concat before "\n" completion)))
1359 ;; Find in completion the longest text that was right before point.
1360 (when (string-match "\\(.+\\)\n.*?\\1" combined)
1361 (let* ((prefix (match-string 1 before))
1362 ;; We used non-greedy match to make `rem' as long as possible.
1363 (rem (substring combined (match-end 0)))
1364 ;; Find in the remainder of completion the longest text
1365 ;; that was right after point.
1366 (after (substring string point))
1367 (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1"
1368 (concat after "\n" rem))
1369 (match-string 1 after))))
1370 ;; The general idea is to try and guess what text was inserted
1371 ;; at point by the completion. Problem is: if we guess wrong,
1372 ;; we may end up treating as "added by completion" text that was
1373 ;; actually painfully typed by the user. So if we then cut
1374 ;; after the first word, we may throw away things the
1375 ;; user wrote. So let's try to be as conservative as possible:
1376 ;; only cut after the first word, if we're reasonably sure that
1377 ;; our guess is correct.
1378 ;; Note: a quick survey on emacs-devel seemed to indicate that
1379 ;; nobody actually cares about the "word-at-a-time" feature of
1380 ;; minibuffer-complete-word, whose real raison-d'être is that it
1381 ;; tries to add "-" or " ". One more reason to only cut after
1382 ;; the first word, if we're really sure we're right.
1383 (when (and (or suffix (zerop (length after)))
1384 (string-match (concat
1385 ;; Make submatch 1 as small as possible
1386 ;; to reduce the risk of cutting
1387 ;; valuable text.
1388 ".*" (regexp-quote prefix) "\\(.*?\\)"
1389 (if suffix (regexp-quote suffix) "\\'"))
1390 completion)
1391 ;; The new point in `completion' should also be just
1392 ;; before the suffix, otherwise something more complex
1393 ;; is going on, and we're not sure where we are.
1394 (eq (match-end 1) comppoint)
1395 ;; (match-beginning 1)..comppoint is now the stretch
1396 ;; of text in `completion' that was completed at point.
1397 (string-match "\\W" completion (match-beginning 1))
1398 ;; Is there really something to cut?
1399 (> comppoint (match-end 0)))
1400 ;; Cut after the first word.
1401 (let ((cutpos (match-end 0)))
1402 (setq completion (concat (substring completion 0 cutpos)
1403 (substring completion comppoint)))
1404 (setq comppoint cutpos)))))
1405
1406 (cons completion comppoint)))))
ba5ff07b
SM
1407
1408
1409(defun minibuffer-complete-word ()
1410 "Complete the minibuffer contents at most a single word.
1411After one word is completed as much as possible, a space or hyphen
1412is added, provided that matches some possible completion.
1413Return nil if there is no valid completion, else t."
1414 (interactive)
67982e2b
SM
1415 (completion-in-region--single-word
1416 (minibuffer-prompt-end) (point-max)
1417 minibuffer-completion-table minibuffer-completion-predicate))
1418
1419(defun completion-in-region--single-word (beg end collection
1420 &optional predicate)
1421 (let ((minibuffer-completion-table collection)
1422 (minibuffer-completion-predicate predicate))
1423 (pcase (completion--do-completion beg end
1424 #'completion--try-word-completion)
a38313e1 1425 (#b000 nil)
67982e2b 1426 (_ t))))
ba5ff07b 1427
890429cc
SM
1428(defface completions-annotations '((t :inherit italic))
1429 "Face to use for annotations in the *Completions* buffer.")
1430
8f3b8a5f 1431(defcustom completions-format 'horizontal
3a9f97fa
JL
1432 "Define the appearance and sorting of completions.
1433If the value is `vertical', display completions sorted vertically
1434in columns in the *Completions* buffer.
8f3b8a5f 1435If the value is `horizontal', display completions sorted
3a9f97fa 1436horizontally in alphabetical order, rather than down the screen."
8f3b8a5f 1437 :type '(choice (const horizontal) (const vertical))
3a9f97fa
JL
1438 :version "23.2")
1439
3911966b 1440(defun completion--insert-strings (strings)
32bae13c
SM
1441 "Insert a list of STRINGS into the current buffer.
1442Uses columns to keep the listing readable but compact.
1443It also eliminates runs of equal strings."
1444 (when (consp strings)
1445 (let* ((length (apply 'max
1446 (mapcar (lambda (s)
1447 (if (consp s)
e5b5b82d
SM
1448 (+ (string-width (car s))
1449 (string-width (cadr s)))
1450 (string-width s)))
32bae13c
SM
1451 strings)))
1452 (window (get-buffer-window (current-buffer) 0))
1453 (wwidth (if window (1- (window-width window)) 79))
1454 (columns (min
1455 ;; At least 2 columns; at least 2 spaces between columns.
1456 (max 2 (/ wwidth (+ 2 length)))
1457 ;; Don't allocate more columns than we can fill.
1458 ;; Windows can't show less than 3 lines anyway.
1459 (max 1 (/ (length strings) 2))))
1460 (colwidth (/ wwidth columns))
1461 (column 0)
3a9f97fa
JL
1462 (rows (/ (length strings) columns))
1463 (row 0)
ae0bc9fb 1464 (first t)
32bae13c
SM
1465 (laststring nil))
1466 ;; The insertion should be "sensible" no matter what choices were made
1467 ;; for the parameters above.
1468 (dolist (str strings)
f87ff539 1469 (unless (equal laststring str) ; Remove (consecutive) duplicates.
32bae13c 1470 (setq laststring str)
ae0bc9fb
SM
1471 ;; FIXME: `string-width' doesn't pay attention to
1472 ;; `display' properties.
f87ff539
SM
1473 (let ((length (if (consp str)
1474 (+ (string-width (car str))
1475 (string-width (cadr str)))
1476 (string-width str))))
3a9f97fa
JL
1477 (cond
1478 ((eq completions-format 'vertical)
1479 ;; Vertical format
1480 (when (> row rows)
1481 (forward-line (- -1 rows))
1482 (setq row 0 column (+ column colwidth)))
1483 (when (> column 0)
1484 (end-of-line)
1485 (while (> (current-column) column)
1486 (if (eobp)
1487 (insert "\n")
1488 (forward-line 1)
1489 (end-of-line)))
1490 (insert " \t")
ae0bc9fb 1491 (set-text-properties (1- (point)) (point)
3a9f97fa
JL
1492 `(display (space :align-to ,column)))))
1493 (t
1494 ;; Horizontal format
ae0bc9fb 1495 (unless first
3a9f97fa
JL
1496 (if (< wwidth (+ (max colwidth length) column))
1497 ;; No space for `str' at point, move to next line.
1498 (progn (insert "\n") (setq column 0))
1499 (insert " \t")
1500 ;; Leave the space unpropertized so that in the case we're
1501 ;; already past the goal column, there is still
1502 ;; a space displayed.
ae0bc9fb 1503 (set-text-properties (1- (point)) (point)
3a9f97fa 1504 ;; We can't just set tab-width, because
3e2d70fd
SM
1505 ;; completion-setup-function will kill
1506 ;; all local variables :-(
3a9f97fa
JL
1507 `(display (space :align-to ,column)))
1508 nil))))
ae0bc9fb 1509 (setq first nil)
f87ff539 1510 (if (not (consp str))
e59e73d8 1511 (put-text-property (point) (progn (insert str) (point))
f87ff539 1512 'mouse-face 'highlight)
e59e73d8 1513 (put-text-property (point) (progn (insert (car str)) (point))
f87ff539 1514 'mouse-face 'highlight)
c7a409b6
DG
1515 (let ((beg (point))
1516 (end (progn (insert (cadr str)) (point))))
1517 (put-text-property beg end 'mouse-face nil)
1518 (font-lock-prepend-text-property beg end 'face
1519 'completions-annotations)))
3a9f97fa
JL
1520 (cond
1521 ((eq completions-format 'vertical)
1522 ;; Vertical format
1523 (if (> column 0)
1524 (forward-line)
1525 (insert "\n"))
1526 (setq row (1+ row)))
1527 (t
1528 ;; Horizontal format
1529 ;; Next column to align to.
1530 (setq column (+ column
1531 ;; Round up to a whole number of columns.
1532 (* colwidth (ceiling length colwidth))))))))))))
32bae13c 1533
6138158d
SM
1534(defvar completion-common-substring nil)
1535(make-obsolete-variable 'completion-common-substring nil "23.1")
32bae13c 1536
21622c6d
SM
1537(defvar completion-setup-hook nil
1538 "Normal hook run at the end of setting up a completion list buffer.
1539When this hook is run, the current buffer is the one in which the
1540command to display the completion list buffer was run.
1541The completion list buffer is available as the value of `standard-output'.
6138158d
SM
1542See also `display-completion-list'.")
1543
1544(defface completions-first-difference
1545 '((t (:inherit bold)))
67982e2b 1546 "Face added on the first uncommon character in completions in *Completions* buffer.")
6138158d 1547
c7a409b6
DG
1548(defface completions-common-part '((t nil))
1549 "Face added on the common prefix substring in completions in *Completions* buffer.
6138158d
SM
1550The idea of `completions-common-part' is that you can use it to
1551make the common parts less visible than normal, so that the rest
67982e2b 1552of the differing parts is, by contrast, slightly highlighted.")
6138158d 1553
125f7951 1554(defun completion-hilit-commonality (completions prefix-len base-size)
6138158d 1555 (when completions
125f7951 1556 (let ((com-str-len (- prefix-len (or base-size 0))))
6138158d
SM
1557 (nconc
1558 (mapcar
457d37ba
SM
1559 (lambda (elem)
1560 (let ((str
1561 ;; Don't modify the string itself, but a copy, since the
1562 ;; the string may be read-only or used for other purposes.
1563 ;; Furthermore, since `completions' may come from
1564 ;; display-completion-list, `elem' may be a list.
1565 (if (consp elem)
1566 (car (setq elem (cons (copy-sequence (car elem))
1567 (cdr elem))))
1568 (setq elem (copy-sequence elem)))))
c7a409b6
DG
1569 (font-lock-prepend-text-property
1570 0
1571 ;; If completion-boundaries returns incorrect
1572 ;; values, all-completions may return strings
1573 ;; that don't contain the prefix.
1574 (min com-str-len (length str))
1575 'face 'completions-common-part str)
457d37ba 1576 (if (> (length str) com-str-len)
c7a409b6
DG
1577 (font-lock-prepend-text-property com-str-len (1+ com-str-len)
1578 'face
1579 'completions-first-difference
1580 str)))
457d37ba 1581 elem)
6138158d
SM
1582 completions)
1583 base-size))))
21622c6d 1584
7bc7f64d 1585(defun display-completion-list (completions &optional common-substring)
32bae13c
SM
1586 "Display the list of completions, COMPLETIONS, using `standard-output'.
1587Each element may be just a symbol or string
1588or may be a list of two strings to be printed as if concatenated.
1589If it is a list of two strings, the first is the actual completion
1590alternative, the second serves as annotation.
1591`standard-output' must be a buffer.
1592The actual completion alternatives, as inserted, are given `mouse-face'
1593properties of `highlight'.
1594At the end, this runs the normal hook `completion-setup-hook'.
67982e2b
SM
1595It can find the completion buffer in `standard-output'."
1596 (declare (advertised-calling-convention (completions) "24.4"))
6138158d
SM
1597 (if common-substring
1598 (setq completions (completion-hilit-commonality
125f7951
SM
1599 completions (length common-substring)
1600 ;; We don't know the base-size.
1601 nil)))
32bae13c
SM
1602 (if (not (bufferp standard-output))
1603 ;; This *never* (ever) happens, so there's no point trying to be clever.
1604 (with-temp-buffer
1605 (let ((standard-output (current-buffer))
1606 (completion-setup-hook nil))
7bc7f64d 1607 (display-completion-list completions common-substring))
32bae13c
SM
1608 (princ (buffer-string)))
1609
d5e63715
SM
1610 (with-current-buffer standard-output
1611 (goto-char (point-max))
1612 (if (null completions)
1613 (insert "There are no possible completions of what you have typed.")
1614 (insert "Possible completions are:\n")
1615 (completion--insert-strings completions))))
e2947429 1616
6138158d
SM
1617 ;; The hilit used to be applied via completion-setup-hook, so there
1618 ;; may still be some code that uses completion-common-substring.
7ce8dff2
CY
1619 (with-no-warnings
1620 (let ((completion-common-substring common-substring))
1621 (run-hooks 'completion-setup-hook)))
32bae13c
SM
1622 nil)
1623
a2a25d24
SM
1624(defvar completion-extra-properties nil
1625 "Property list of extra properties of the current completion job.
1626These include:
321cc491
CY
1627
1628`:annotation-function': Function to annotate the completions buffer.
1629 The function must accept one argument, a completion string,
1630 and return either nil or a string which is to be displayed
1631 next to the completion (but which is not part of the
1632 completion). The function can access the completion data via
1633 `minibuffer-completion-table' and related variables.
1634
a2a25d24 1635`:exit-function': Function to run after completion is performed.
321cc491
CY
1636
1637 The function must accept two arguments, STRING and STATUS.
1638 STRING is the text to which the field was completed, and
1639 STATUS indicates what kind of operation happened:
1640 `finished' - text is now complete
1641 `sole' - text cannot be further completed but
1642 completion is not finished
1643 `exact' - text is a valid completion but may be further
1644 completed.")
a2a25d24 1645
ab22be48
SM
1646(defvar completion-annotate-function
1647 nil
1648 ;; Note: there's a lot of scope as for when to add annotations and
1649 ;; what annotations to add. E.g. completing-help.el allowed adding
1650 ;; the first line of docstrings to M-x completion. But there's
1651 ;; a tension, since such annotations, while useful at times, can
1652 ;; actually drown the useful information.
1653 ;; So completion-annotate-function should be used parsimoniously, or
1654 ;; else only used upon a user's request (e.g. we could add a command
1655 ;; to completion-list-mode to add annotations to the current
1656 ;; completions).
1657 "Function to add annotations in the *Completions* buffer.
1658The function takes a completion and should either return nil, or a string that
1659will be displayed next to the completion. The function can access the
1660completion table and predicates via `minibuffer-completion-table' and related
1661variables.")
a2a25d24
SM
1662(make-obsolete-variable 'completion-annotate-function
1663 'completion-extra-properties "24.1")
1664
1665(defun completion--done (string &optional finished message)
1666 (let* ((exit-fun (plist-get completion-extra-properties :exit-function))
1667 (pre-msg (and exit-fun (current-message))))
f58e0fd5 1668 (cl-assert (memq finished '(exact sole finished unknown)))
a2a25d24
SM
1669 (when exit-fun
1670 (when (eq finished 'unknown)
1671 (setq finished
1672 (if (eq (try-completion string
1673 minibuffer-completion-table
1674 minibuffer-completion-predicate)
1675 t)
1676 'finished 'exact)))
1677 (funcall exit-fun string finished))
1678 (when (and message
1679 ;; Don't output any message if the exit-fun already did so.
1680 (equal pre-msg (and exit-fun (current-message))))
1681 (completion--message message))))
ab22be48 1682
67982e2b 1683(defun minibuffer-completion-help (&optional start end)
32bae13c
SM
1684 "Display a list of possible completions of the current minibuffer contents."
1685 (interactive)
1686 (message "Making completion list...")
67982e2b
SM
1687 (let* ((start (or start (minibuffer-prompt-end)))
1688 (end (or end (point-max)))
1689 (string (buffer-substring start end))
30a23501 1690 (md (completion--field-metadata start))
a647cb26
SM
1691 (completions (completion-all-completions
1692 string
1693 minibuffer-completion-table
1694 minibuffer-completion-predicate
67982e2b 1695 (- (point) start)
30a23501 1696 md)))
32bae13c 1697 (message nil)
a2a25d24
SM
1698 (if (or (null completions)
1699 (and (not (consp (cdr completions)))
1700 (equal (car completions) string)))
1701 (progn
1702 ;; If there are no completions, or if the current input is already
1703 ;; the sole completion, then hide (previous&stale) completions.
1704 (minibuffer-hide-completions)
1705 (ding)
1706 (minibuffer-message
1707 (if completions "Sole completion" "No completions")))
1708
1709 (let* ((last (last completions))
1710 (base-size (cdr last))
1711 (prefix (unless (zerop base-size) (substring string 0 base-size)))
30a23501
SM
1712 (all-md (completion--metadata (buffer-substring-no-properties
1713 start (point))
1714 base-size md
1715 minibuffer-completion-table
1716 minibuffer-completion-predicate))
620c53a6
SM
1717 (afun (or (completion-metadata-get all-md 'annotation-function)
1718 (plist-get completion-extra-properties
1719 :annotation-function)
1720 completion-annotate-function))
a2a25d24
SM
1721 ;; If the *Completions* buffer is shown in a new
1722 ;; window, mark it as softly-dedicated, so bury-buffer in
1723 ;; minibuffer-hide-completions will know whether to
1724 ;; delete the window or not.
1725 (display-buffer-mark-dedicated 'soft))
1726 (with-output-to-temp-buffer "*Completions*"
1727 ;; Remove the base-size tail because `sort' requires a properly
1728 ;; nil-terminated list.
1729 (when last (setcdr last nil))
a2a25d24 1730 (setq completions
620c53a6
SM
1731 ;; FIXME: This function is for the output of all-completions,
1732 ;; not completion-all-completions. Often it's the same, but
1733 ;; not always.
1734 (let ((sort-fun (completion-metadata-get
1735 all-md 'display-sort-function)))
1736 (if sort-fun
1737 (funcall sort-fun completions)
1738 (sort completions 'string-lessp))))
1739 (when afun
1740 (setq completions
a2a25d24 1741 (mapcar (lambda (s)
620c53a6 1742 (let ((ann (funcall afun s)))
a2a25d24 1743 (if ann (list s ann) s)))
620c53a6 1744 completions)))
a2a25d24
SM
1745
1746 (with-current-buffer standard-output
1747 (set (make-local-variable 'completion-base-position)
1748 (list (+ start base-size)
1749 ;; FIXME: We should pay attention to completion
1750 ;; boundaries here, but currently
1751 ;; completion-all-completions does not give us the
1752 ;; necessary information.
1753 end))
1754 (set (make-local-variable 'completion-list-insert-choice-function)
1755 (let ((ctable minibuffer-completion-table)
1756 (cpred minibuffer-completion-predicate)
1757 (cprops completion-extra-properties))
1758 (lambda (start end choice)
620c53a6
SM
1759 (unless (or (zerop (length prefix))
1760 (equal prefix
1761 (buffer-substring-no-properties
1762 (max (point-min)
1763 (- start (length prefix)))
1764 start)))
a2a25d24
SM
1765 (message "*Completions* out of date"))
1766 ;; FIXME: Use `md' to do quoting&terminator here.
1767 (completion--replace start end choice)
1768 (let* ((minibuffer-completion-table ctable)
1769 (minibuffer-completion-predicate cpred)
1770 (completion-extra-properties cprops)
1771 (result (concat prefix choice))
1772 (bounds (completion-boundaries
1773 result ctable cpred "")))
1774 ;; If the completion introduces a new field, then
1775 ;; completion is not finished.
1776 (completion--done result
1777 (if (eq (car bounds) (length result))
1778 'exact 'finished)))))))
1779
1780 (display-completion-list completions))))
32bae13c
SM
1781 nil))
1782
890429cc
SM
1783(defun minibuffer-hide-completions ()
1784 "Get rid of an out-of-date *Completions* buffer."
1785 ;; FIXME: We could/should use minibuffer-scroll-window here, but it
1786 ;; can also point to the minibuffer-parent-window, so it's a bit tricky.
1787 (let ((win (get-buffer-window "*Completions*" 0)))
1788 (if win (with-selected-window win (bury-buffer)))))
1789
32bae13c
SM
1790(defun exit-minibuffer ()
1791 "Terminate this minibuffer argument."
1792 (interactive)
1793 ;; If the command that uses this has made modifications in the minibuffer,
1794 ;; we don't want them to cause deactivation of the mark in the original
1795 ;; buffer.
1796 ;; A better solution would be to make deactivate-mark buffer-local
1797 ;; (or to turn it into a list of buffers, ...), but in the mean time,
1798 ;; this should do the trick in most cases.
ba5ff07b 1799 (setq deactivate-mark nil)
32bae13c
SM
1800 (throw 'exit nil))
1801
1802(defun self-insert-and-exit ()
1803 "Terminate minibuffer input."
1804 (interactive)
8989a920 1805 (if (characterp last-command-event)
32bae13c
SM
1806 (call-interactively 'self-insert-command)
1807 (ding))
1808 (exit-minibuffer))
1809
a185548b 1810(defvar completion-in-region-functions nil
d36ed1c8
SM
1811 "Wrapper hook around `completion-in-region'.")
1812(make-obsolete-variable 'completion-in-region-functions
1813 'completion-in-region-function "24.4")
1814
1815(defvar completion-in-region-function #'completion--in-region
1816 "Function to perform the job of `completion-in-region'.
1817The function is called with 4 arguments: START END COLLECTION PREDICATE.
1818The arguments and expected return value are like the ones of
1819`completion-in-region'.")
a185548b 1820
3e2d70fd
SM
1821(defvar completion-in-region--data nil)
1822
e240cc21
SM
1823(defvar completion-in-region-mode-predicate nil
1824 "Predicate to tell `completion-in-region-mode' when to exit.
1825It is called with no argument and should return nil when
1826`completion-in-region-mode' should exit (and hence pop down
1827the *Completions* buffer).")
1828
1829(defvar completion-in-region-mode--predicate nil
1830 "Copy of the value of `completion-in-region-mode-predicate'.
1831This holds the value `completion-in-region-mode-predicate' had when
1832we entered `completion-in-region-mode'.")
1833
a185548b
SM
1834(defun completion-in-region (start end collection &optional predicate)
1835 "Complete the text between START and END using COLLECTION.
3e38b2bd 1836Return nil if there is no valid completion, else t.
08549772
LMI
1837Point needs to be somewhere between START and END.
1838PREDICATE (a function called with no arguments) says when to
1839exit."
f58e0fd5 1840 (cl-assert (<= start (point)) (<= (point) end))
d36ed1c8
SM
1841 (funcall completion-in-region-function start end collection predicate))
1842
02d844b5
GM
1843(defcustom read-file-name-completion-ignore-case
1844 (if (memq system-type '(ms-dos windows-nt darwin cygwin))
1845 t nil)
1846 "Non-nil means when reading a file name completion ignores case."
02d844b5
GM
1847 :type 'boolean
1848 :version "22.1")
1849
d36ed1c8 1850(defun completion--in-region (start end collection &optional predicate)
a185548b 1851 (with-wrapper-hook
d86d2721
SM
1852 ;; FIXME: Maybe we should use this hook to provide a "display
1853 ;; completions" operation as well.
a185548b
SM
1854 completion-in-region-functions (start end collection predicate)
1855 (let ((minibuffer-completion-table collection)
67982e2b 1856 (minibuffer-completion-predicate predicate))
7a2c7ca7
CY
1857 ;; HACK: if the text we are completing is already in a field, we
1858 ;; want the completion field to take priority (e.g. Bug#6830).
e240cc21 1859 (when completion-in-region-mode-predicate
e240cc21 1860 (setq completion-in-region--data
504a0381
SM
1861 `(,(if (markerp start) start (copy-marker start))
1862 ,(copy-marker end t) ,collection ,predicate))
1863 (completion-in-region-mode 1))
67982e2b 1864 (completion--in-region-1 start end))))
8ba31f36 1865
3e2d70fd
SM
1866(defvar completion-in-region-mode-map
1867 (let ((map (make-sparse-keymap)))
c0a193ea
SM
1868 ;; FIXME: Only works if completion-in-region-mode was activated via
1869 ;; completion-at-point called directly.
82b24fb2 1870 (define-key map "\M-?" 'completion-help-at-point)
3e2d70fd
SM
1871 (define-key map "\t" 'completion-at-point)
1872 map)
1873 "Keymap activated during `completion-in-region'.")
1874
1875;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
1876;; the *Completions*).
1877;; - lisp-mode: never.
1878;; - comint: only do it if you hit SPC at the right time.
1879;; - pcomplete: pop it down on SPC or after some time-delay.
1880;; - semantic: use a post-command-hook check similar to this one.
1881(defun completion-in-region--postch ()
3e2d70fd
SM
1882 (or unread-command-events ;Don't pop down the completions in the middle of
1883 ;mouse-drag-region/mouse-set-point.
1884 (and completion-in-region--data
d92df117 1885 (and (eq (marker-buffer (nth 0 completion-in-region--data))
3e2d70fd 1886 (current-buffer))
d92df117 1887 (>= (point) (nth 0 completion-in-region--data))
3e2d70fd
SM
1888 (<= (point)
1889 (save-excursion
d92df117 1890 (goto-char (nth 1 completion-in-region--data))
3e2d70fd 1891 (line-end-position)))
2dbaa080 1892 (funcall completion-in-region-mode--predicate)))
3e2d70fd
SM
1893 (completion-in-region-mode -1)))
1894
1895;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
1896
504a0381
SM
1897(defvar completion-in-region-mode nil) ;Explicit defvar, i.s.o defcustom.
1898
3e2d70fd 1899(define-minor-mode completion-in-region-mode
504a0381 1900 "Transient minor mode used during `completion-in-region'."
3e2d70fd 1901 :global t
ed8be7ff 1902 :group 'minibuffer
504a0381
SM
1903 ;; Prevent definition of a custom-variable since it makes no sense to
1904 ;; customize this variable.
1905 :variable completion-in-region-mode
3e2d70fd
SM
1906 ;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
1907 (remove-hook 'post-command-hook #'completion-in-region--postch)
1908 (setq minor-mode-overriding-map-alist
1909 (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
1910 minor-mode-overriding-map-alist))
1911 (if (null completion-in-region-mode)
504a0381
SM
1912 (progn
1913 (setq completion-in-region--data nil)
1914 (unless (equal "*Completions*" (buffer-name (window-buffer)))
1915 (minibuffer-hide-completions)))
3e2d70fd 1916 ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
f58e0fd5 1917 (cl-assert completion-in-region-mode-predicate)
2dbaa080
SM
1918 (setq completion-in-region-mode--predicate
1919 completion-in-region-mode-predicate)
3e2d70fd
SM
1920 (add-hook 'post-command-hook #'completion-in-region--postch)
1921 (push `(completion-in-region-mode . ,completion-in-region-mode-map)
1922 minor-mode-overriding-map-alist)))
1923
1924;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
1925;; on minor-mode-overriding-map-alist instead.
1926(setq minor-mode-map-alist
1927 (delq (assq 'completion-in-region-mode minor-mode-map-alist)
1928 minor-mode-map-alist))
1929
3a07ffce 1930(defvar completion-at-point-functions '(tags-completion-at-point-function)
51ef56c4 1931 "Special hook to find the completion table for the thing at point.
d86d2721
SM
1932Each function on this hook is called in turns without any argument and should
1933return either nil to mean that it is not applicable at point,
51ef56c4 1934or a function of no argument to perform completion (discouraged),
60236b0d 1935or a list of the form (START END COLLECTION . PROPS) where
51ef56c4
SM
1936 START and END delimit the entity to complete and should include point,
1937 COLLECTION is the completion table to use to complete it, and
1938 PROPS is a property list for additional information.
a2a25d24
SM
1939Currently supported properties are all the properties that can appear in
1940`completion-extra-properties' plus:
0ff8e1ba 1941 `:predicate' a predicate that completion candidates need to satisfy.
60236b0d
CY
1942 `:exclusive' If `no', means that if the completion table fails to
1943 match the text at point, then instead of reporting a completion
3d10e134
SM
1944 failure, the completion should try the next completion function.
1945As is the case with most hooks, the functions are responsible to preserve
1946things like point and current buffer.")
51ef56c4 1947
3e2d70fd 1948(defvar completion--capf-misbehave-funs nil
0ff8e1ba
SM
1949 "List of functions found on `completion-at-point-functions' that misbehave.
1950These are functions that neither return completion data nor a completion
1951function but instead perform completion right away.")
3e2d70fd 1952(defvar completion--capf-safe-funs nil
0ff8e1ba
SM
1953 "List of well-behaved functions found on `completion-at-point-functions'.
1954These are functions which return proper completion data rather than
1955a completion function or god knows what else.")
3e2d70fd
SM
1956
1957(defun completion--capf-wrapper (fun which)
d1bb6623
SM
1958 ;; FIXME: The safe/misbehave handling assumes that a given function will
1959 ;; always return the same kind of data, but this breaks down with functions
1960 ;; like comint-completion-at-point or mh-letter-completion-at-point, which
1961 ;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
f58e0fd5
SM
1962 (if (pcase which
1963 (`all t)
1964 (`safe (member fun completion--capf-safe-funs))
1965 (`optimist (not (member fun completion--capf-misbehave-funs))))
3e2d70fd
SM
1966 (let ((res (funcall fun)))
1967 (cond
0ff8e1ba 1968 ((and (consp res) (not (functionp res)))
3e2d70fd 1969 (unless (member fun completion--capf-safe-funs)
0ff8e1ba
SM
1970 (push fun completion--capf-safe-funs))
1971 (and (eq 'no (plist-get (nthcdr 3 res) :exclusive))
1972 ;; FIXME: Here we'd need to decide whether there are
1973 ;; valid completions against the current text. But this depends
1974 ;; on the actual completion UI (e.g. with the default completion
1975 ;; it depends on completion-style) ;-(
1976 ;; We approximate this result by checking whether prefix
1977 ;; completion might work, which means that non-prefix completion
1978 ;; will not work (or not right) for completion functions that
1979 ;; are non-exclusive.
1980 (null (try-completion (buffer-substring-no-properties
1981 (car res) (point))
1982 (nth 2 res)
1983 (plist-get (nthcdr 3 res) :predicate)))
1984 (setq res nil)))
3e2d70fd
SM
1985 ((not (or (listp res) (functionp res)))
1986 (unless (member fun completion--capf-misbehave-funs)
1987 (message
1988 "Completion function %S uses a deprecated calling convention" fun)
1989 (push fun completion--capf-misbehave-funs))))
e240cc21 1990 (if res (cons fun res)))))
3e2d70fd 1991
67027b49 1992(defun completion-at-point ()
48111a85 1993 "Perform completion on the text around point.
67027b49
SM
1994The completion method is determined by `completion-at-point-functions'."
1995 (interactive)
3e2d70fd
SM
1996 (let ((res (run-hook-wrapped 'completion-at-point-functions
1997 #'completion--capf-wrapper 'all)))
e240cc21 1998 (pcase res
d92df117
SM
1999 (`(,_ . ,(and (pred functionp) f)) (funcall f))
2000 (`(,hookfun . (,start ,end ,collection . ,plist))
2001 (unless (markerp start) (setq start (copy-marker start)))
2002 (let* ((completion-extra-properties plist)
2003 (completion-in-region-mode-predicate
2004 (lambda ()
2005 ;; We're still in the same completion field.
2006 (let ((newstart (car-safe (funcall hookfun))))
2007 (and newstart (= newstart start))))))
2008 (completion-in-region start end collection
2009 (plist-get plist :predicate))))
2010 ;; Maybe completion already happened and the function returned t.
2011 (_ (cdr res)))))
51ef56c4 2012
3e2d70fd
SM
2013(defun completion-help-at-point ()
2014 "Display the completions on the text around point.
2015The completion method is determined by `completion-at-point-functions'."
2016 (interactive)
2017 (let ((res (run-hook-wrapped 'completion-at-point-functions
2018 ;; Ignore misbehaving functions.
2019 #'completion--capf-wrapper 'optimist)))
e240cc21
SM
2020 (pcase res
2021 (`(,_ . ,(and (pred functionp) f))
2022 (message "Don't know how to show completions for %S" f))
d92df117
SM
2023 (`(,hookfun . (,start ,end ,collection . ,plist))
2024 (unless (markerp start) (setq start (copy-marker start)))
2025 (let* ((minibuffer-completion-table collection)
2026 (minibuffer-completion-predicate (plist-get plist :predicate))
2027 (completion-extra-properties plist)
2028 (completion-in-region-mode-predicate
2029 (lambda ()
2030 ;; We're still in the same completion field.
2031 (let ((newstart (car-safe (funcall hookfun))))
67982e2b 2032 (and newstart (= newstart start))))))
d92df117
SM
2033 ;; FIXME: We should somehow (ab)use completion-in-region-function or
2034 ;; introduce a corresponding hook (plus another for word-completion,
2035 ;; and another for force-completion, maybe?).
d92df117 2036 (setq completion-in-region--data
504a0381
SM
2037 `(,start ,(copy-marker end t) ,collection
2038 ,(plist-get plist :predicate)))
2039 (completion-in-region-mode 1)
67982e2b 2040 (minibuffer-completion-help start end)))
d92df117
SM
2041 (`(,hookfun . ,_)
2042 ;; The hook function already performed completion :-(
2043 ;; Not much we can do at this point.
2044 (message "%s already performed completion!" hookfun)
2045 nil)
2046 (_ (message "Nothing to complete at point")))))
3e2d70fd 2047
1d4adede
SM
2048;;; Key bindings.
2049
a38313e1
SM
2050(let ((map minibuffer-local-map))
2051 (define-key map "\C-g" 'abort-recursive-edit)
2052 (define-key map "\r" 'exit-minibuffer)
2053 (define-key map "\n" 'exit-minibuffer))
2054
3349e122
SM
2055(defvar minibuffer-local-completion-map
2056 (let ((map (make-sparse-keymap)))
2057 (set-keymap-parent map minibuffer-local-map)
2058 (define-key map "\t" 'minibuffer-complete)
2059 ;; M-TAB is already abused for many other purposes, so we should find
2060 ;; another binding for it.
2061 ;; (define-key map "\e\t" 'minibuffer-force-complete)
2062 (define-key map " " 'minibuffer-complete-word)
2063 (define-key map "?" 'minibuffer-completion-help)
2064 map)
2065 "Local keymap for minibuffer input with completion.")
2066
2067(defvar minibuffer-local-must-match-map
2068 (let ((map (make-sparse-keymap)))
2069 (set-keymap-parent map minibuffer-local-completion-map)
2070 (define-key map "\r" 'minibuffer-complete-and-exit)
2071 (define-key map "\n" 'minibuffer-complete-and-exit)
2072 map)
2073 "Local keymap for minibuffer input with completion, for exact match.")
a38313e1 2074
3349e122
SM
2075(defvar minibuffer-local-filename-completion-map
2076 (let ((map (make-sparse-keymap)))
2077 (define-key map " " nil)
2078 map)
2079 "Local keymap for minibuffer input with completion for filenames.
2080Gets combined either with `minibuffer-local-completion-map' or
2081with `minibuffer-local-must-match-map'.")
a38313e1 2082
3349e122
SM
2083(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
2084 'minibuffer-local-filename-must-match-map "23.1")
1a72a195
SM
2085(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
2086(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
a38313e1
SM
2087
2088(let ((map minibuffer-local-ns-map))
2089 (define-key map " " 'exit-minibuffer)
2090 (define-key map "\t" 'exit-minibuffer)
2091 (define-key map "?" 'self-insert-and-exit))
2092
fd6fa53f
SM
2093(defvar minibuffer-inactive-mode-map
2094 (let ((map (make-keymap)))
2095 (suppress-keymap map)
2096 (define-key map "e" 'find-file-other-frame)
2097 (define-key map "f" 'find-file-other-frame)
2098 (define-key map "b" 'switch-to-buffer-other-frame)
2099 (define-key map "i" 'info)
2100 (define-key map "m" 'mail)
2101 (define-key map "n" 'make-frame)
123ecb68 2102 (define-key map [mouse-1] 'view-echo-area-messages)
fd6fa53f
SM
2103 ;; So the global down-mouse-1 binding doesn't clutter the execution of the
2104 ;; above mouse-1 binding.
2105 (define-key map [down-mouse-1] #'ignore)
2106 map)
2107 "Keymap for use in the minibuffer when it is not active.
2108The non-mouse bindings in this keymap can only be used in minibuffer-only
2109frames, since the minibuffer can normally not be selected when it is
2110not active.")
2111
2112(define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer"
2113 :abbrev-table nil ;abbrev.el is not loaded yet during dump.
2114 ;; Note: this major mode is called from minibuf.c.
2115 "Major mode to use in the minibuffer when it is not active.
2116This is only used when the minibuffer area has no active minibuffer.")
2117
a38313e1
SM
2118;;; Completion tables.
2119
34b67b0f 2120(defun minibuffer--double-dollars (str)
79c4eeb4
SM
2121 ;; Reuse the actual "$" from the string to preserve any text-property it
2122 ;; might have, such as `face'.
2123 (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
2124 str))
34b67b0f 2125
21622c6d
SM
2126(defun completion--make-envvar-table ()
2127 (mapcar (lambda (enventry)
9f3618b5 2128 (substring enventry 0 (string-match-p "=" enventry)))
21622c6d
SM
2129 process-environment))
2130
a38313e1 2131(defconst completion--embedded-envvar-re
3b11e6ac
SM
2132 ;; We can't reuse env--substitute-vars-regexp because we need to match only
2133 ;; potentially-unfinished envvars at end of string.
a38313e1
SM
2134 (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
2135 "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
2136
d032d5e7 2137(defun completion--embedded-envvar-table (string _pred action)
c6432f1e
SM
2138 "Completion table for envvars embedded in a string.
2139The envvar syntax (and escaping) rules followed by this table are the
2140same as `substitute-in-file-name'."
2141 ;; We ignore `pred', because the predicates passed to us via
2142 ;; read-file-name-internal are not 100% correct and fail here:
2143 ;; e.g. we get predicates like file-directory-p there, whereas the filename
2144 ;; completed needs to be passed through substitute-in-file-name before it
2145 ;; can be passed to file-directory-p.
528c56e2
SM
2146 (when (string-match completion--embedded-envvar-re string)
2147 (let* ((beg (or (match-beginning 2) (match-beginning 1)))
2148 (table (completion--make-envvar-table))
2149 (prefix (substring string 0 beg)))
c6432f1e
SM
2150 (cond
2151 ((eq action 'lambda)
2152 ;; This table is expected to be used in conjunction with some
2153 ;; other table that provides the "main" completion. Let the
2154 ;; other table handle the test-completion case.
2155 nil)
30a23501
SM
2156 ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
2157 ;; Only return boundaries/metadata if there's something to complete,
03408648
SM
2158 ;; since otherwise when we're used in
2159 ;; completion-table-in-turn, we could return boundaries and
2160 ;; let some subsequent table return a list of completions.
2161 ;; FIXME: Maybe it should rather be fixed in
2162 ;; completion-table-in-turn instead, but it's difficult to
2163 ;; do it efficiently there.
c6432f1e 2164 (when (try-completion (substring string beg) table nil)
03408648
SM
2165 ;; Compute the boundaries of the subfield to which this
2166 ;; completion applies.
30a23501
SM
2167 (if (eq action 'metadata)
2168 '(metadata (category . environment-variable))
2169 (let ((suffix (cdr action)))
f58e0fd5
SM
2170 `(boundaries
2171 ,(or (match-beginning 2) (match-beginning 1))
2172 . ,(when (string-match "[^[:alnum:]_]" suffix)
2173 (match-beginning 0)))))))
c6432f1e 2174 (t
a38313e1
SM
2175 (if (eq (aref string (1- beg)) ?{)
2176 (setq table (apply-partially 'completion-table-with-terminator
2177 "}" table)))
ab22be48
SM
2178 ;; Even if file-name completion is case-insensitive, we want
2179 ;; envvar completion to be case-sensitive.
2180 (let ((completion-ignore-case nil))
2181 (completion-table-with-context
c6432f1e 2182 prefix table (substring string beg) nil action)))))))
017c22fe 2183
528c56e2
SM
2184(defun completion-file-name-table (string pred action)
2185 "Completion table for file names."
af7b6078
SM
2186 (condition-case nil
2187 (cond
2188 ((eq action 'metadata) '(metadata (category . file)))
ed571ccb
SM
2189 ((string-match-p "\\`~[^/\\]*\\'" string)
2190 (completion-table-with-context "~"
2191 (mapcar (lambda (u) (concat u "/"))
2192 (system-users))
2193 (substring string 1)
2194 pred action))
af7b6078
SM
2195 ((eq (car-safe action) 'boundaries)
2196 (let ((start (length (file-name-directory string)))
2197 (end (string-match-p "/" (cdr action))))
f58e0fd5
SM
2198 `(boundaries
2199 ;; if `string' is "C:" in w32, (file-name-directory string)
2200 ;; returns "C:/", so `start' is 3 rather than 2.
2201 ;; Not quite sure what is The Right Fix, but clipping it
2202 ;; back to 2 will work for this particular case. We'll
2203 ;; see if we can come up with a better fix when we bump
2204 ;; into more such problematic cases.
2205 ,(min start (length string)) . ,end)))
528c56e2 2206
af7b6078
SM
2207 ((eq action 'lambda)
2208 (if (zerop (length string))
2209 nil ;Not sure why it's here, but it probably doesn't harm.
2210 (funcall (or pred 'file-exists-p) string)))
017c22fe 2211
af7b6078
SM
2212 (t
2213 (let* ((name (file-name-nondirectory string))
2214 (specdir (file-name-directory string))
2215 (realdir (or specdir default-directory)))
2216
2217 (cond
2218 ((null action)
2219 (let ((comp (file-name-completion name realdir pred)))
2220 (if (stringp comp)
2221 (concat specdir comp)
2222 comp)))
2223
2224 ((eq action t)
2225 (let ((all (file-name-all-completions name realdir)))
2226
2227 ;; Check the predicate, if necessary.
2228 (unless (memq pred '(nil file-exists-p))
2229 (let ((comp ())
2230 (pred
2231 (if (eq pred 'file-directory-p)
2232 ;; Brute-force speed up for directory checking:
2233 ;; Discard strings which don't end in a slash.
2234 (lambda (s)
2235 (let ((len (length s)))
2236 (and (> len 0) (eq (aref s (1- len)) ?/))))
2237 ;; Must do it the hard (and slow) way.
2238 pred)))
2239 (let ((default-directory (expand-file-name realdir)))
2240 (dolist (tem all)
2241 (if (funcall pred tem) (push tem comp))))
2242 (setq all (nreverse comp))))
2243
2244 all))))))
2245 (file-error nil))) ;PCM often calls with invalid directories.
528c56e2
SM
2246
2247(defvar read-file-name-predicate nil
2248 "Current predicate used by `read-file-name-internal'.")
2249(make-obsolete-variable 'read-file-name-predicate
2250 "use the regular PRED argument" "23.2")
2251
79c4eeb4 2252(defun completion--sifn-requote (upos qstr)
86957a0c 2253 ;; We're looking for `qpos' such that:
036dfb8b 2254 ;; (equal (substring (substitute-in-file-name qstr) 0 upos)
86957a0c 2255 ;; (substitute-in-file-name (substring qstr 0 qpos)))
036dfb8b
SM
2256 ;; Big problem here: we have to reverse engineer substitute-in-file-name to
2257 ;; find the position corresponding to UPOS in QSTR, but
2258 ;; substitute-in-file-name can do anything, depending on file-name-handlers.
86957a0c
SM
2259 ;; substitute-in-file-name does the following kind of things:
2260 ;; - expand env-var references.
2261 ;; - turn backslashes into slashes.
2262 ;; - truncate some prefix of the input.
2263 ;; - rewrite some prefix.
2264 ;; Some of these operations are written in external libraries and we'd rather
2265 ;; not hard code any assumptions here about what they actually do. IOW, we
2266 ;; want to treat substitute-in-file-name as a black box, as much as possible.
036dfb8b 2267 ;; Kind of like in rfn-eshadow-update-overlay, only worse.
86957a0c
SM
2268 ;; Example of things we need to handle:
2269 ;; - Tramp (substitute-in-file-name "/foo:~/bar//baz") => "/scpc:foo:/baz".
2270 ;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin"
2271 ;; (substitute-in-file-name "C:\") => "/"
2272 ;; (substitute-in-file-name "C:\bi") => "/bi"
2273 (let* ((ustr (substitute-in-file-name qstr))
2274 (uprefix (substring ustr 0 upos))
2275 qprefix)
2276 ;; Main assumption: nothing after qpos should affect the text before upos,
2277 ;; so we can work our way backward from the end of qstr, one character
2278 ;; at a time.
2279 ;; Second assumptions: If qpos is far from the end this can be a bit slow,
2280 ;; so we speed it up by doing a first loop that skips a word at a time.
2281 ;; This word-sized loop is careful not to cut in the middle of env-vars.
2282 (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr)))
2283 (and boundary
1a72a195 2284 (progn
86957a0c
SM
2285 (setq qprefix (substring qstr 0 boundary))
2286 (string-prefix-p uprefix
2287 (substitute-in-file-name qprefix)))))
2288 (setq qstr qprefix))
2289 (let ((qpos (length qstr)))
2290 (while (and (> qpos 0)
2291 (string-prefix-p uprefix
2292 (substitute-in-file-name
2293 (substring qstr 0 (1- qpos)))))
2294 (setq qpos (1- qpos)))
2295 (cons qpos #'minibuffer--double-dollars))))
79c4eeb4
SM
2296
2297(defalias 'completion--file-name-table
2298 (completion-table-with-quoting #'completion-file-name-table
2299 #'substitute-in-file-name
2300 #'completion--sifn-requote)
528c56e2
SM
2301 "Internal subroutine for `read-file-name'. Do not call this.
2302This is a completion table for file names, like `completion-file-name-table'
79c4eeb4 2303except that it passes the file name through `substitute-in-file-name'.")
34b67b0f 2304
21622c6d 2305(defalias 'read-file-name-internal
79c4eeb4
SM
2306 (completion-table-in-turn #'completion--embedded-envvar-table
2307 #'completion--file-name-table)
21622c6d 2308 "Internal subroutine for `read-file-name'. Do not call this.")
34b67b0f 2309
b16ac1ec
LL
2310(defvar read-file-name-function 'read-file-name-default
2311 "The function called by `read-file-name' to do its work.
2312It should accept the same arguments as `read-file-name'.")
dbd50d4b 2313
dbd50d4b
SM
2314(defcustom insert-default-directory t
2315 "Non-nil means when reading a filename start with default dir in minibuffer.
2316
2317When the initial minibuffer contents show a name of a file or a directory,
2318typing RETURN without editing the initial contents is equivalent to typing
2319the default file name.
2320
2321If this variable is non-nil, the minibuffer contents are always
2322initially non-empty, and typing RETURN without editing will fetch the
2323default name, if one is provided. Note however that this default name
2324is not necessarily the same as initial contents inserted in the minibuffer,
2325if the initial contents is just the default directory.
2326
2327If this variable is nil, the minibuffer often starts out empty. In
2328that case you may have to explicitly fetch the next history element to
2329request the default name; typing RETURN without editing will leave
2330the minibuffer empty.
2331
2332For some commands, exiting with an empty minibuffer has a special meaning,
2333such as making the current buffer visit no file in the case of
2334`set-visited-file-name'."
dbd50d4b
SM
2335 :type 'boolean)
2336
4e3870f5
GM
2337;; Not always defined, but only called if next-read-file-uses-dialog-p says so.
2338(declare-function x-file-dialog "xfns.c"
2339 (prompt dir &optional default-filename mustmatch only-dir-p))
2340
b16ac1ec 2341(defun read-file-name--defaults (&optional dir initial)
7d371eac
JL
2342 (let ((default
2343 (cond
2344 ;; With non-nil `initial', use `dir' as the first default.
2345 ;; Essentially, this mean reversing the normal order of the
2346 ;; current directory name and the current file name, i.e.
2347 ;; 1. with normal file reading:
2348 ;; 1.1. initial input is the current directory
2349 ;; 1.2. the first default is the current file name
2350 ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'):
2351 ;; 2.2. initial input is the current file name
2352 ;; 2.1. the first default is the current directory
2353 (initial (abbreviate-file-name dir))
2354 ;; In file buffers, try to get the current file name
2355 (buffer-file-name
2356 (abbreviate-file-name buffer-file-name))))
2357 (file-name-at-point
2358 (run-hook-with-args-until-success 'file-name-at-point-functions)))
2359 (when file-name-at-point
2360 (setq default (delete-dups
2361 (delete "" (delq nil (list file-name-at-point default))))))
2362 ;; Append new defaults to the end of existing `minibuffer-default'.
2363 (append
2364 (if (listp minibuffer-default) minibuffer-default (list minibuffer-default))
2365 (if (listp default) default (list default)))))
2366
dbd50d4b
SM
2367(defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
2368 "Read file name, prompting with PROMPT and completing in directory DIR.
2369Value is not expanded---you must call `expand-file-name' yourself.
4abcdac8
CY
2370
2371DIR is the directory to use for completing relative file names.
2372It should be an absolute directory name, or nil (which means the
2373current buffer's value of `default-directory').
2374
2375DEFAULT-FILENAME specifies the default file name to return if the
2376user exits the minibuffer with the same non-empty string inserted
2377by this function. If DEFAULT-FILENAME is a string, that serves
2378as the default. If DEFAULT-FILENAME is a list of strings, the
2379first string is the default. If DEFAULT-FILENAME is omitted or
2380nil, then if INITIAL is non-nil, the default is DIR combined with
2381INITIAL; otherwise, if the current buffer is visiting a file,
2382that file serves as the default; otherwise, the default is simply
2383the string inserted into the minibuffer.
2384
2385If the user exits with an empty minibuffer, return an empty
2386string. (This happens only if the user erases the pre-inserted
2387contents, or if `insert-default-directory' is nil.)
846b6eba
CY
2388
2389Fourth arg MUSTMATCH can take the following values:
2390- nil means that the user can exit with any input.
2391- t means that the user is not allowed to exit unless
2392 the input is (or completes to) an existing file.
2393- `confirm' means that the user can exit with any input, but she needs
2394 to confirm her choice if the input is not an existing file.
2395- `confirm-after-completion' means that the user can exit with any
2396 input, but she needs to confirm her choice if she called
2397 `minibuffer-complete' right before `minibuffer-complete-and-exit'
2398 and the input is not an existing file.
2399- anything else behaves like t except that typing RET does not exit if it
2400 does non-null completion.
2401
dbd50d4b 2402Fifth arg INITIAL specifies text to start with.
846b6eba 2403
4abcdac8
CY
2404Sixth arg PREDICATE, if non-nil, should be a function of one
2405argument; then a file name is considered an acceptable completion
2406alternative only if PREDICATE returns non-nil with the file name
2407as its argument.
dbd50d4b 2408
846b6eba
CY
2409If this command was invoked with the mouse, use a graphical file
2410dialog if `use-dialog-box' is non-nil, and the window system or X
8368c14e 2411toolkit in use provides a file dialog box, and DIR is not a
2605051a
GM
2412remote file. For graphical file dialogs, any of the special values
2413of MUSTMATCH `confirm' and `confirm-after-completion' are
2414treated as equivalent to nil. Some graphical file dialogs respect
2415a MUSTMATCH value of t, and some do not (or it only has a cosmetic
fba9b8b6 2416effect, and does not actually prevent the user from entering a
2605051a 2417non-existent file).
dbd50d4b
SM
2418
2419See also `read-file-name-completion-ignore-case'
2420and `read-file-name-function'."
2605051a
GM
2421 ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection),
2422 ;; then MUSTMATCH is enforced. But with newer Gtk
2423 ;; (xg_get_file_with_chooser), it only has a cosmetic effect.
2424 ;; The user can still type a non-existent file name.
b16ac1ec
LL
2425 (funcall (or read-file-name-function #'read-file-name-default)
2426 prompt dir default-filename mustmatch initial predicate))
2427
09b95ce3
MY
2428(defvar minibuffer-local-filename-syntax
2429 (let ((table (make-syntax-table))
2430 (punctuation (car (string-to-syntax "."))))
2431 ;; Convert all punctuation entries to symbol.
2432 (map-char-table (lambda (c syntax)
2433 (when (eq (car syntax) punctuation)
2434 (modify-syntax-entry c "_" table)))
2435 table)
2436 (mapc
2437 (lambda (c)
2438 (modify-syntax-entry c "." table))
2439 '(?/ ?: ?\\))
2440 table)
48de8b12 2441 "Syntax table used when reading a file name in the minibuffer.")
09b95ce3 2442
620c53a6
SM
2443;; minibuffer-completing-file-name is a variable used internally in minibuf.c
2444;; to determine whether to use minibuffer-local-filename-completion-map or
2445;; minibuffer-local-completion-map. It shouldn't be exported to Elisp.
2403c841
SM
2446;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to
2447;; use (eq minibuffer-completion-table #'read-file-name-internal), which is
2448;; probably even worse. Maybe We should add some read-file-name-setup-hook
2449;; instead, but for now, let's keep this non-obsolete.
cc356a5d 2450;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get)
620c53a6 2451
b16ac1ec
LL
2452(defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate)
2453 "Default method for reading file names.
2454See `read-file-name' for the meaning of the arguments."
dbd50d4b
SM
2455 (unless dir (setq dir default-directory))
2456 (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
2457 (unless default-filename
2458 (setq default-filename (if initial (expand-file-name initial dir)
2459 buffer-file-name)))
2460 ;; If dir starts with user's homedir, change that to ~.
2461 (setq dir (abbreviate-file-name dir))
2462 ;; Likewise for default-filename.
e8a5fe3e 2463 (if default-filename
032c3399
JL
2464 (setq default-filename
2465 (if (consp default-filename)
2466 (mapcar 'abbreviate-file-name default-filename)
2467 (abbreviate-file-name default-filename))))
6b11952a 2468 (let ((insdef (cond
dbd50d4b
SM
2469 ((and insert-default-directory (stringp dir))
2470 (if initial
2471 (cons (minibuffer--double-dollars (concat dir initial))
2472 (length (minibuffer--double-dollars dir)))
2473 (minibuffer--double-dollars dir)))
2474 (initial (cons (minibuffer--double-dollars initial) 0)))))
2475
03408648
SM
2476 (let ((completion-ignore-case read-file-name-completion-ignore-case)
2477 (minibuffer-completing-file-name t)
2478 (pred (or predicate 'file-exists-p))
2479 (add-to-history nil))
2480
2481 (let* ((val
2482 (if (or (not (next-read-file-uses-dialog-p))
2483 ;; Graphical file dialogs can't handle remote
2484 ;; files (Bug#99).
2485 (file-remote-p dir))
2486 ;; We used to pass `dir' to `read-file-name-internal' by
2487 ;; abusing the `predicate' argument. It's better to
2488 ;; just use `default-directory', but in order to avoid
2489 ;; changing `default-directory' in the current buffer,
2490 ;; we don't let-bind it.
2491 (let ((dir (file-name-as-directory
2492 (expand-file-name dir))))
2493 (minibuffer-with-setup-hook
2494 (lambda ()
2495 (setq default-directory dir)
2496 ;; When the first default in `minibuffer-default'
2497 ;; duplicates initial input `insdef',
2498 ;; reset `minibuffer-default' to nil.
2499 (when (equal (or (car-safe insdef) insdef)
2500 (or (car-safe minibuffer-default)
2501 minibuffer-default))
2502 (setq minibuffer-default
2503 (cdr-safe minibuffer-default)))
2504 ;; On the first request on `M-n' fill
2505 ;; `minibuffer-default' with a list of defaults
2506 ;; relevant for file-name reading.
2507 (set (make-local-variable 'minibuffer-default-add-function)
2508 (lambda ()
2509 (with-current-buffer
2510 (window-buffer (minibuffer-selected-window))
09b95ce3
MY
2511 (read-file-name--defaults dir initial))))
2512 (set-syntax-table minibuffer-local-filename-syntax))
03408648
SM
2513 (completing-read prompt 'read-file-name-internal
2514 pred mustmatch insdef
2515 'file-name-history default-filename)))
2516 ;; If DEFAULT-FILENAME not supplied and DIR contains
2517 ;; a file name, split it.
2518 (let ((file (file-name-nondirectory dir))
2519 ;; When using a dialog, revert to nil and non-nil
2520 ;; interpretation of mustmatch. confirm options
2521 ;; need to be interpreted as nil, otherwise
2522 ;; it is impossible to create new files using
2523 ;; dialogs with the default settings.
2524 (dialog-mustmatch
2525 (not (memq mustmatch
2526 '(nil confirm confirm-after-completion)))))
2527 (when (and (not default-filename)
2528 (not (zerop (length file))))
2529 (setq default-filename file)
2530 (setq dir (file-name-directory dir)))
2531 (when default-filename
2532 (setq default-filename
2533 (expand-file-name (if (consp default-filename)
2534 (car default-filename)
2535 default-filename)
2536 dir)))
2537 (setq add-to-history t)
2538 (x-file-dialog prompt dir default-filename
2539 dialog-mustmatch
2540 (eq predicate 'file-directory-p)))))
2541
2542 (replace-in-history (eq (car-safe file-name-history) val)))
2543 ;; If completing-read returned the inserted default string itself
2544 ;; (rather than a new string with the same contents),
2545 ;; it has to mean that the user typed RET with the minibuffer empty.
2546 ;; In that case, we really want to return ""
2547 ;; so that commands such as set-visited-file-name can distinguish.
2548 (when (consp default-filename)
2549 (setq default-filename (car default-filename)))
2550 (when (eq val default-filename)
2551 ;; In this case, completing-read has not added an element
2552 ;; to the history. Maybe we should.
2553 (if (not replace-in-history)
2554 (setq add-to-history t))
2555 (setq val ""))
2556 (unless val (error "No file name specified"))
2557
2558 (if (and default-filename
2559 (string-equal val (if (consp insdef) (car insdef) insdef)))
2560 (setq val default-filename))
2561 (setq val (substitute-in-file-name val))
2562
2563 (if replace-in-history
2564 ;; Replace what Fcompleting_read added to the history
2565 ;; with what we will actually return. As an exception,
2566 ;; if that's the same as the second item in
2567 ;; file-name-history, it's really a repeat (Bug#4657).
2568 (let ((val1 (minibuffer--double-dollars val)))
2569 (if history-delete-duplicates
2570 (setcdr file-name-history
2571 (delete val1 (cdr file-name-history))))
2572 (if (string= val1 (cadr file-name-history))
2573 (pop file-name-history)
2574 (setcar file-name-history val1)))
2575 (if add-to-history
2576 ;; Add the value to the history--but not if it matches
2577 ;; the last value already there.
dbd50d4b 2578 (let ((val1 (minibuffer--double-dollars val)))
03408648
SM
2579 (unless (and (consp file-name-history)
2580 (equal (car file-name-history) val1))
2581 (setq file-name-history
2582 (cons val1
2583 (if history-delete-duplicates
2584 (delete val1 file-name-history)
2585 file-name-history)))))))
b16ac1ec 2586 val))))
dbd50d4b 2587
8b04c0ae
JL
2588(defun internal-complete-buffer-except (&optional buffer)
2589 "Perform completion on all buffers excluding BUFFER.
e35b3063 2590BUFFER nil or omitted means use the current buffer.
8b04c0ae 2591Like `internal-complete-buffer', but removes BUFFER from the completion list."
a647cb26 2592 (let ((except (if (stringp buffer) buffer (buffer-name buffer))))
8b04c0ae
JL
2593 (apply-partially 'completion-table-with-predicate
2594 'internal-complete-buffer
2595 (lambda (name)
2596 (not (equal (if (consp name) (car name) name) except)))
2597 nil)))
2598
eee6de73 2599;;; Old-style completion, used in Emacs-21 and Emacs-22.
19c04f39 2600
d032d5e7 2601(defun completion-emacs21-try-completion (string table pred _point)
19c04f39
SM
2602 (let ((completion (try-completion string table pred)))
2603 (if (stringp completion)
2604 (cons completion (length completion))
2605 completion)))
2606
d032d5e7 2607(defun completion-emacs21-all-completions (string table pred _point)
6138158d 2608 (completion-hilit-commonality
eee6de73 2609 (all-completions string table pred)
125f7951
SM
2610 (length string)
2611 (car (completion-boundaries string table pred ""))))
19c04f39 2612
19c04f39
SM
2613(defun completion-emacs22-try-completion (string table pred point)
2614 (let ((suffix (substring string point))
2615 (completion (try-completion (substring string 0 point) table pred)))
2616 (if (not (stringp completion))
2617 completion
2618 ;; Merge a trailing / in completion with a / after point.
2619 ;; We used to only do it for word completion, but it seems to make
2620 ;; sense for all completions.
34200787
SM
2621 ;; Actually, claiming this feature was part of Emacs-22 completion
2622 ;; is pushing it a bit: it was only done in minibuffer-completion-word,
2623 ;; which was (by default) not bound during file completion, where such
2624 ;; slashes are most likely to occur.
2625 (if (and (not (zerop (length completion)))
2626 (eq ?/ (aref completion (1- (length completion))))
19c04f39
SM
2627 (not (zerop (length suffix)))
2628 (eq ?/ (aref suffix 0)))
34200787
SM
2629 ;; This leaves point after the / .
2630 (setq suffix (substring suffix 1)))
19c04f39
SM
2631 (cons (concat completion suffix) (length completion)))))
2632
2633(defun completion-emacs22-all-completions (string table pred point)
125f7951
SM
2634 (let ((beforepoint (substring string 0 point)))
2635 (completion-hilit-commonality
2636 (all-completions beforepoint table pred)
2637 point
2638 (car (completion-boundaries beforepoint table pred "")))))
19c04f39 2639
eee6de73
SM
2640;;; Basic completion.
2641
2642(defun completion--merge-suffix (completion point suffix)
2643 "Merge end of COMPLETION with beginning of SUFFIX.
2644Simple generalization of the \"merge trailing /\" done in Emacs-22.
2645Return the new suffix."
2646 (if (and (not (zerop (length suffix)))
2647 (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix)
2648 ;; Make sure we don't compress things to less
2649 ;; than we started with.
2650 point)
2651 ;; Just make sure we didn't match some other \n.
2652 (eq (match-end 1) (length completion)))
2653 (substring suffix (- (match-end 1) (match-beginning 1)))
2654 ;; Nothing to merge.
2655 suffix))
2656
00278747
SM
2657(defun completion-basic--pattern (beforepoint afterpoint bounds)
2658 (delete
2659 "" (list (substring beforepoint (car bounds))
2660 'point
2661 (substring afterpoint 0 (cdr bounds)))))
2662
34200787 2663(defun completion-basic-try-completion (string table pred point)
a647cb26
SM
2664 (let* ((beforepoint (substring string 0 point))
2665 (afterpoint (substring string point))
2666 (bounds (completion-boundaries beforepoint table pred afterpoint)))
86011bf2
SM
2667 (if (zerop (cdr bounds))
2668 ;; `try-completion' may return a subtly different result
2669 ;; than `all+merge', so try to use it whenever possible.
2670 (let ((completion (try-completion beforepoint table pred)))
2671 (if (not (stringp completion))
2672 completion
2673 (cons
2674 (concat completion
2675 (completion--merge-suffix completion point afterpoint))
2676 (length completion))))
a647cb26
SM
2677 (let* ((suffix (substring afterpoint (cdr bounds)))
2678 (prefix (substring beforepoint 0 (car bounds)))
2679 (pattern (delete
2680 "" (list (substring beforepoint (car bounds))
2681 'point
2682 (substring afterpoint 0 (cdr bounds)))))
2683 (all (completion-pcm--all-completions prefix pattern table pred)))
86011bf2
SM
2684 (if minibuffer-completing-file-name
2685 (setq all (completion-pcm--filename-try-filter all)))
2686 (completion-pcm--merge-try pattern all prefix suffix)))))
2687
2688(defun completion-basic-all-completions (string table pred point)
a647cb26
SM
2689 (let* ((beforepoint (substring string 0 point))
2690 (afterpoint (substring string point))
2691 (bounds (completion-boundaries beforepoint table pred afterpoint))
d032d5e7 2692 ;; (suffix (substring afterpoint (cdr bounds)))
a647cb26
SM
2693 (prefix (substring beforepoint 0 (car bounds)))
2694 (pattern (delete
2695 "" (list (substring beforepoint (car bounds))
2696 'point
2697 (substring afterpoint 0 (cdr bounds)))))
2698 (all (completion-pcm--all-completions prefix pattern table pred)))
125f7951 2699 (completion-hilit-commonality all point (car bounds))))
19c04f39 2700
34200787
SM
2701;;; Partial-completion-mode style completion.
2702
890429cc
SM
2703(defvar completion-pcm--delim-wild-regex nil
2704 "Regular expression matching delimiters controlling the partial-completion.
2705Typically, this regular expression simply matches a delimiter, meaning
2706that completion can add something at (match-beginning 0), but if it has
2707a submatch 1, then completion can add something at (match-end 1).
2708This is used when the delimiter needs to be of size zero (e.g. the transition
2709from lowercase to uppercase characters).")
34200787
SM
2710
2711(defun completion-pcm--prepare-delim-re (delims)
2712 (setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
2713
a2a25d24 2714(defcustom completion-pcm-word-delimiters "-_./:| "
34200787
SM
2715 "A string of characters treated as word delimiters for completion.
2716Some arcane rules:
2717If `]' is in this string, it must come first.
2718If `^' is in this string, it must not come first.
2719If `-' is in this string, it must come first or right after `]'.
2720In other words, if S is this string, then `[S]' must be a valid Emacs regular
2721expression (not containing character ranges like `a-z')."
2722 :set (lambda (symbol value)
2723 (set-default symbol value)
2724 ;; Refresh other vars.
2725 (completion-pcm--prepare-delim-re value))
2726 :initialize 'custom-initialize-reset
2727 :type 'string)
2728
79ccd68f
SM
2729(defcustom completion-pcm-complete-word-inserts-delimiters nil
2730 "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters.
2731Those chars are treated as delimiters iff this variable is non-nil.
2732I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas
2733if nil, it will list all possible commands in *Completions* because none of
2734the commands start with a \"-\" or a SPC."
2bed3f04 2735 :version "24.1"
79ccd68f
SM
2736 :type 'boolean)
2737
34200787 2738(defun completion-pcm--pattern-trivial-p (pattern)
1bba1cfc
SM
2739 (and (stringp (car pattern))
2740 ;; It can be followed by `point' and "" and still be trivial.
2741 (let ((trivial t))
2742 (dolist (elem (cdr pattern))
2743 (unless (member elem '(point ""))
2744 (setq trivial nil)))
2745 trivial)))
34200787 2746
a38313e1
SM
2747(defun completion-pcm--string->pattern (string &optional point)
2748 "Split STRING into a pattern.
34200787 2749A pattern is a list where each element is either a string
934eacb9 2750or a symbol, see `completion-pcm--merge-completions'."
a38313e1
SM
2751 (if (and point (< point (length string)))
2752 (let ((prefix (substring string 0 point))
2753 (suffix (substring string point)))
34200787
SM
2754 (append (completion-pcm--string->pattern prefix)
2755 '(point)
2756 (completion-pcm--string->pattern suffix)))
3e2d70fd
SM
2757 (let* ((pattern nil)
2758 (p 0)
67982e2b
SM
2759 (p0 p)
2760 (pending nil))
26c548b0 2761
890429cc
SM
2762 (while (and (setq p (string-match completion-pcm--delim-wild-regex
2763 string p))
79ccd68f
SM
2764 (or completion-pcm-complete-word-inserts-delimiters
2765 ;; If the char was added by minibuffer-complete-word,
2766 ;; then don't treat it as a delimiter, otherwise
2767 ;; "M-x SPC" ends up inserting a "-" rather than listing
2768 ;; all completions.
2769 (not (get-text-property p 'completion-try-word string))))
890429cc
SM
2770 ;; Usually, completion-pcm--delim-wild-regex matches a delimiter,
2771 ;; meaning that something can be added *before* it, but it can also
2772 ;; match a prefix and postfix, in which case something can be added
2773 ;; in-between (e.g. match [[:lower:]][[:upper:]]).
2774 ;; This is determined by the presence of a submatch-1 which delimits
2775 ;; the prefix.
2776 (if (match-end 1) (setq p (match-end 1)))
67982e2b
SM
2777 (unless (= p0 p)
2778 (if pending (push pending pattern))
2779 (push (substring string p0 p) pattern))
2780 (setq pending nil)
a38313e1 2781 (if (eq (aref string p) ?*)
34200787
SM
2782 (progn
2783 (push 'star pattern)
2784 (setq p0 (1+ p)))
2785 (push 'any pattern)
67982e2b
SM
2786 (if (match-end 1)
2787 (setq p0 p)
2788 (push (substring string p (match-end 0)) pattern)
2789 ;; `any-delim' is used so that "a-b" also finds "array->beginning".
2790 (setq pending 'any-delim)
2791 (setq p0 (match-end 0))))
2792 (setq p p0))
2793
2794 (when (> (length string) p0)
2795 (if pending (push pending pattern))
2796 (push (substring string p0) pattern))
34200787
SM
2797 ;; An empty string might be erroneously added at the beginning.
2798 ;; It should be avoided properly, but it's so easy to remove it here.
67982e2b
SM
2799 (delete "" (nreverse pattern)))))
2800
2801(defun completion-pcm--optimize-pattern (p)
2802 ;; Remove empty strings in a separate phase since otherwise a ""
2803 ;; might prevent some other optimization, as in '(any "" any).
2804 (setq p (delete "" p))
2805 (let ((n '()))
2806 (while p
2807 (pcase p
2808 (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest)
2809 (setq p (cons (concat s1 s2) rest)))
2810 (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_)
2811 (setq p (cdr p)))
2812 (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest)))
2813 (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest)))
2814 (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest)))
2815 (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest)))
2816 (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest)))
2817 (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
2818 (_ (push (pop p) n))))
2819 (nreverse n)))
34200787
SM
2820
2821(defun completion-pcm--pattern->regex (pattern &optional group)
a38313e1 2822 (let ((re
ab22be48
SM
2823 (concat "\\`"
2824 (mapconcat
2825 (lambda (x)
79ccd68f
SM
2826 (cond
2827 ((stringp x) (regexp-quote x))
67982e2b
SM
2828 (t
2829 (let ((re (if (eq x 'any-delim)
2830 (concat completion-pcm--delim-wild-regex "*?")
2831 ".*?")))
2832 (if (if (consp group) (memq x group) group)
2833 (concat "\\(" re "\\)")
2834 re)))))
ab22be48 2835 pattern
15c72e1d 2836 ""))))
a38313e1
SM
2837 ;; Avoid pathological backtracking.
2838 (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re)
2839 (setq re (replace-match "" t t re 1)))
2840 re))
34200787 2841
a38313e1 2842(defun completion-pcm--all-completions (prefix pattern table pred)
34200787 2843 "Find all completions for PATTERN in TABLE obeying PRED.
26c548b0 2844PATTERN is as returned by `completion-pcm--string->pattern'."
f58e0fd5 2845 ;; (cl-assert (= (car (completion-boundaries prefix table pred ""))
125f7951 2846 ;; (length prefix)))
34200787
SM
2847 ;; Find an initial list of possible completions.
2848 (if (completion-pcm--pattern-trivial-p pattern)
2849
2850 ;; Minibuffer contains no delimiters -- simple case!
125f7951 2851 (all-completions (concat prefix (car pattern)) table pred)
26c548b0 2852
34200787
SM
2853 ;; Use all-completions to do an initial cull. This is a big win,
2854 ;; since all-completions is written in C!
2855 (let* (;; Convert search pattern to a standard regular expression.
2856 (regex (completion-pcm--pattern->regex pattern))
15c72e1d
SM
2857 (case-fold-search completion-ignore-case)
2858 (completion-regexp-list (cons regex completion-regexp-list))
34200787 2859 (compl (all-completions
30a23501
SM
2860 (concat prefix
2861 (if (stringp (car pattern)) (car pattern) ""))
125f7951 2862 table pred)))
34200787
SM
2863 (if (not (functionp table))
2864 ;; The internal functions already obeyed completion-regexp-list.
2865 compl
15c72e1d 2866 (let ((poss ()))
34200787 2867 (dolist (c compl)
9f3618b5 2868 (when (string-match-p regex c) (push c poss)))
34200787
SM
2869 poss)))))
2870
7372b09c
SM
2871(defun completion-pcm--hilit-commonality (pattern completions)
2872 (when completions
2873 (let* ((re (completion-pcm--pattern->regex pattern '(point)))
1bba1cfc 2874 (case-fold-search completion-ignore-case))
1bba1cfc
SM
2875 (mapcar
2876 (lambda (str)
2877 ;; Don't modify the string itself.
2878 (setq str (copy-sequence str))
2879 (unless (string-match re str)
2880 (error "Internal error: %s does not match %s" re str))
2881 (let ((pos (or (match-beginning 1) (match-end 0))))
2882 (put-text-property 0 pos
2883 'font-lock-face 'completions-common-part
2884 str)
2885 (if (> (length str) pos)
2886 (put-text-property pos (1+ pos)
2887 'font-lock-face 'completions-first-difference
2888 str)))
2889 str)
2890 completions))))
7372b09c 2891
eee6de73
SM
2892(defun completion-pcm--find-all-completions (string table pred point
2893 &optional filter)
2894 "Find all completions for STRING at POINT in TABLE, satisfying PRED.
2895POINT is a position inside STRING.
2896FILTER is a function applied to the return value, that can be used, e.g. to
53964682 2897filter out additional entries (because TABLE might not obey PRED)."
eee6de73 2898 (unless filter (setq filter 'identity))
a647cb26
SM
2899 (let* ((beforepoint (substring string 0 point))
2900 (afterpoint (substring string point))
2901 (bounds (completion-boundaries beforepoint table pred afterpoint))
2902 (prefix (substring beforepoint 0 (car bounds)))
2903 (suffix (substring afterpoint (cdr bounds)))
2904 firsterror)
f8381803
SM
2905 (setq string (substring string (car bounds) (+ point (cdr bounds))))
2906 (let* ((relpoint (- point (car bounds)))
2907 (pattern (completion-pcm--string->pattern string relpoint))
67982e2b 2908 (all (condition-case-unless-debug err
eee6de73
SM
2909 (funcall filter
2910 (completion-pcm--all-completions
2911 prefix pattern table pred))
67982e2b 2912 (error (setq firsterror err) nil))))
a38313e1
SM
2913 (when (and (null all)
2914 (> (car bounds) 0)
2915 (null (ignore-errors (try-completion prefix table pred))))
2916 ;; The prefix has no completions at all, so we should try and fix
2917 ;; that first.
2918 (let ((substring (substring prefix 0 -1)))
f58e0fd5
SM
2919 (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix)
2920 (completion-pcm--find-all-completions
2921 substring table pred (length substring) filter)))
a38313e1
SM
2922 (let ((sep (aref prefix (1- (length prefix))))
2923 ;; Text that goes between the new submatches and the
2924 ;; completion substring.
2925 (between nil))
2926 ;; Eliminate submatches that don't end with the separator.
2927 (dolist (submatch (prog1 suball (setq suball ())))
2928 (when (eq sep (aref submatch (1- (length submatch))))
2929 (push submatch suball)))
2930 (when suball
2931 ;; Update the boundaries and corresponding pattern.
2932 ;; We assume that all submatches result in the same boundaries
2933 ;; since we wouldn't know how to merge them otherwise anyway.
f8381803
SM
2934 ;; FIXME: COMPLETE REWRITE!!!
2935 (let* ((newbeforepoint
2936 (concat subprefix (car suball)
2937 (substring string 0 relpoint)))
2938 (leftbound (+ (length subprefix) (length (car suball))))
a38313e1 2939 (newbounds (completion-boundaries
f8381803
SM
2940 newbeforepoint table pred afterpoint)))
2941 (unless (or (and (eq (cdr bounds) (cdr newbounds))
2942 (eq (car newbounds) leftbound))
a38313e1
SM
2943 ;; Refuse new boundaries if they step over
2944 ;; the submatch.
f8381803 2945 (< (car newbounds) leftbound))
a38313e1
SM
2946 ;; The new completed prefix does change the boundaries
2947 ;; of the completed substring.
f8381803
SM
2948 (setq suffix (substring afterpoint (cdr newbounds)))
2949 (setq string
2950 (concat (substring newbeforepoint (car newbounds))
2951 (substring afterpoint 0 (cdr newbounds))))
2952 (setq between (substring newbeforepoint leftbound
a38313e1
SM
2953 (car newbounds)))
2954 (setq pattern (completion-pcm--string->pattern
f8381803
SM
2955 string
2956 (- (length newbeforepoint)
2957 (car newbounds)))))
a38313e1 2958 (dolist (submatch suball)
30a23501
SM
2959 (setq all (nconc
2960 (mapcar
2961 (lambda (s) (concat submatch between s))
2962 (funcall filter
2963 (completion-pcm--all-completions
2964 (concat subprefix submatch between)
2965 pattern table pred)))
2966 all)))
c63028e1
SM
2967 ;; FIXME: This can come in handy for try-completion,
2968 ;; but isn't right for all-completions, since it lists
2969 ;; invalid completions.
2970 ;; (unless all
2971 ;; ;; Even though we found expansions in the prefix, none
2972 ;; ;; leads to a valid completion.
2973 ;; ;; Let's keep the expansions, tho.
2974 ;; (dolist (submatch suball)
2975 ;; (push (concat submatch between newsubstring) all)))
2976 ))
a38313e1
SM
2977 (setq pattern (append subpat (list 'any (string sep))
2978 (if between (list between)) pattern))
2979 (setq prefix subprefix)))))
2980 (if (and (null all) firsterror)
2981 (signal (car firsterror) (cdr firsterror))
2982 (list pattern all prefix suffix)))))
2983
34200787 2984(defun completion-pcm-all-completions (string table pred point)
f58e0fd5
SM
2985 (pcase-let ((`(,pattern ,all ,prefix ,_suffix)
2986 (completion-pcm--find-all-completions string table pred point)))
d4e88786
SM
2987 (when all
2988 (nconc (completion-pcm--hilit-commonality pattern all)
2989 (length prefix)))))
34200787 2990
1493963b
SM
2991(defun completion--sreverse (str)
2992 "Like `reverse' but for a string STR rather than a list."
e33c6771 2993 (apply #'string (nreverse (mapcar 'identity str))))
1493963b
SM
2994
2995(defun completion--common-suffix (strs)
2996 "Return the common suffix of the strings STRS."
2997 (completion--sreverse
2998 (try-completion
2999 ""
e33c6771 3000 (mapcar #'completion--sreverse strs))))
1493963b 3001
34200787 3002(defun completion-pcm--merge-completions (strs pattern)
934eacb9
SM
3003 "Extract the commonality in STRS, with the help of PATTERN.
3004PATTERN can contain strings and symbols chosen among `star', `any', `point',
3005and `prefix'. They all match anything (aka \".*\") but are merged differently:
3006`any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets
3007 completed to just \"a\").
3008`prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets
3009 completed to just \"b\").
3010`star' grows from both ends and is reified into a \"*\" (when matching \"a1b\"
3011 and \"a2b\" it gets completed to \"a*b\").
3012`point' is like `star' except that it gets reified as the position of point
3013 instead of being reified as a \"*\" character.
3014The underlying idea is that we should return a string which still matches
3015the same set of elements."
681e0e7c
SM
3016 ;; When completing while ignoring case, we want to try and avoid
3017 ;; completing "fo" to "foO" when completing against "FOO" (bug#4219).
3018 ;; So we try and make sure that the string we return is all made up
3019 ;; of text from the completions rather than part from the
3020 ;; completions and part from the input.
3021 ;; FIXME: This reduces the problems of inconsistent capitalization
3022 ;; but it doesn't fully fix it: we may still end up completing
3023 ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against
3024 ;; '("foo-barr" "FOO-BARD").
34200787
SM
3025 (cond
3026 ((null (cdr strs)) (list (car strs)))
3027 (t
3028 (let ((re (completion-pcm--pattern->regex pattern 'group))
3029 (ccs ())) ;Chopped completions.
3030
3031 ;; First chop each string into the parts corresponding to each
3032 ;; non-constant element of `pattern', using regexp-matching.
3033 (let ((case-fold-search completion-ignore-case))
3034 (dolist (str strs)
3035 (unless (string-match re str)
3036 (error "Internal error: %s doesn't match %s" str re))
3037 (let ((chopped ())
681e0e7c
SM
3038 (last 0)
3039 (i 1)
3040 next)
3041 (while (setq next (match-end i))
3042 (push (substring str last next) chopped)
3043 (setq last next)
34200787
SM
3044 (setq i (1+ i)))
3045 ;; Add the text corresponding to the implicit trailing `any'.
681e0e7c 3046 (push (substring str last) chopped)
34200787
SM
3047 (push (nreverse chopped) ccs))))
3048
3049 ;; Then for each of those non-constant elements, extract the
3050 ;; commonality between them.
681e0e7c
SM
3051 (let ((res ())
3052 (fixed ""))
3053 ;; Make the implicit trailing `any' explicit.
34200787
SM
3054 (dolist (elem (append pattern '(any)))
3055 (if (stringp elem)
681e0e7c 3056 (setq fixed (concat fixed elem))
34200787
SM
3057 (let ((comps ()))
3058 (dolist (cc (prog1 ccs (setq ccs nil)))
3059 (push (car cc) comps)
3060 (push (cdr cc) ccs))
681e0e7c
SM
3061 ;; Might improve the likelihood to avoid choosing
3062 ;; different capitalizations in different parts.
3063 ;; In practice, it doesn't seem to make any difference.
3064 (setq ccs (nreverse ccs))
3065 (let* ((prefix (try-completion fixed comps))
3066 (unique (or (and (eq prefix t) (setq prefix fixed))
34200787 3067 (eq t (try-completion prefix comps)))))
934eacb9
SM
3068 (unless (or (eq elem 'prefix)
3069 (equal prefix ""))
3070 (push prefix res))
34200787
SM
3071 ;; If there's only one completion, `elem' is not useful
3072 ;; any more: it can only match the empty string.
3073 ;; FIXME: in some cases, it may be necessary to turn an
3074 ;; `any' into a `star' because the surrounding context has
3075 ;; changed such that string->pattern wouldn't add an `any'
3076 ;; here any more.
1493963b
SM
3077 (unless unique
3078 (push elem res)
b1da2957
SM
3079 ;; Extract common suffix additionally to common prefix.
3080 ;; Don't do it for `any' since it could lead to a merged
3081 ;; completion that doesn't itself match the candidates.
3082 (when (and (memq elem '(star point prefix))
3083 ;; If prefix is one of the completions, there's no
3084 ;; suffix left to find.
3085 (not (assoc-string prefix comps t)))
3086 (let ((suffix
3087 (completion--common-suffix
3088 (if (zerop (length prefix)) comps
3089 ;; Ignore the chars in the common prefix, so we
3090 ;; don't merge '("abc" "abbc") as "ab*bc".
3091 (let ((skip (length prefix)))
3092 (mapcar (lambda (str) (substring str skip))
3093 comps))))))
f58e0fd5 3094 (cl-assert (stringp suffix))
1493963b
SM
3095 (unless (equal suffix "")
3096 (push suffix res)))))
681e0e7c 3097 (setq fixed "")))))
34200787
SM
3098 ;; We return it in reverse order.
3099 res)))))
3100
3101(defun completion-pcm--pattern->string (pattern)
3102 (mapconcat (lambda (x) (cond
03408648
SM
3103 ((stringp x) x)
3104 ((eq x 'star) "*")
3105 (t ""))) ;any, point, prefix.
34200787
SM
3106 pattern
3107 ""))
3108
eee6de73
SM
3109;; We want to provide the functionality of `try', but we use `all'
3110;; and then merge it. In most cases, this works perfectly, but
3111;; if the completion table doesn't consider the same completions in
3112;; `try' as in `all', then we have a problem. The most common such
3113;; case is for filename completion where completion-ignored-extensions
3114;; is only obeyed by the `try' code. We paper over the difference
3115;; here. Note that it is not quite right either: if the completion
3116;; table uses completion-table-in-turn, this filtering may take place
3117;; too late to correctly fallback from the first to the
3118;; second alternative.
3119(defun completion-pcm--filename-try-filter (all)
3120 "Filter to adjust `all' file completion to the behavior of `try'."
03408648 3121 (when all
eee6de73
SM
3122 (let ((try ())
3123 (re (concat "\\(?:\\`\\.\\.?/\\|"
3124 (regexp-opt completion-ignored-extensions)
3125 "\\)\\'")))
3126 (dolist (f all)
9f3618b5 3127 (unless (string-match-p re f) (push f try)))
eee6de73 3128 (or try all))))
9f3618b5 3129
eee6de73
SM
3130
3131(defun completion-pcm--merge-try (pattern all prefix suffix)
3132 (cond
3133 ((not (consp all)) all)
3134 ((and (not (consp (cdr all))) ;Only one completion.
3135 ;; Ignore completion-ignore-case here.
3136 (equal (completion-pcm--pattern->string pattern) (car all)))
3137 t)
3138 (t
03408648
SM
3139 (let* ((mergedpat (completion-pcm--merge-completions all pattern))
3140 ;; `mergedpat' is in reverse order. Place new point (by
3141 ;; order of preference) either at the old point, or at
3142 ;; the last place where there's something to choose, or
3143 ;; at the very end.
3144 (pointpat (or (memq 'point mergedpat)
3145 (memq 'any mergedpat)
3146 (memq 'star mergedpat)
3147 ;; Not `prefix'.
3148 mergedpat))
3149 ;; New pos from the start.
3150 (newpos (length (completion-pcm--pattern->string pointpat)))
9858f6c3 3151 ;; Do it afterwards because it changes `pointpat' by side effect.
03408648 3152 (merged (completion-pcm--pattern->string (nreverse mergedpat))))
eee6de73
SM
3153
3154 (setq suffix (completion--merge-suffix merged newpos suffix))
03408648 3155 (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
34200787 3156
eee6de73 3157(defun completion-pcm-try-completion (string table pred point)
f58e0fd5
SM
3158 (pcase-let ((`(,pattern ,all ,prefix ,suffix)
3159 (completion-pcm--find-all-completions
3160 string table pred point
3161 (if minibuffer-completing-file-name
3162 'completion-pcm--filename-try-filter))))
eee6de73
SM
3163 (completion-pcm--merge-try pattern all prefix suffix)))
3164
00278747
SM
3165;;; Substring completion
3166;; Mostly derived from the code of `basic' completion.
3167
3168(defun completion-substring--all-completions (string table pred point)
3169 (let* ((beforepoint (substring string 0 point))
3170 (afterpoint (substring string point))
3171 (bounds (completion-boundaries beforepoint table pred afterpoint))
3172 (suffix (substring afterpoint (cdr bounds)))
3173 (prefix (substring beforepoint 0 (car bounds)))
3174 (basic-pattern (completion-basic--pattern
3175 beforepoint afterpoint bounds))
3176 (pattern (if (not (stringp (car basic-pattern)))
3177 basic-pattern
79ccd68f 3178 (cons 'prefix basic-pattern)))
00278747
SM
3179 (all (completion-pcm--all-completions prefix pattern table pred)))
3180 (list all pattern prefix suffix (car bounds))))
3181
3182(defun completion-substring-try-completion (string table pred point)
f58e0fd5
SM
3183 (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
3184 (completion-substring--all-completions
3185 string table pred point)))
00278747
SM
3186 (if minibuffer-completing-file-name
3187 (setq all (completion-pcm--filename-try-filter all)))
3188 (completion-pcm--merge-try pattern all prefix suffix)))
3189
3190(defun completion-substring-all-completions (string table pred point)
f58e0fd5
SM
3191 (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
3192 (completion-substring--all-completions
3193 string table pred point)))
00278747
SM
3194 (when all
3195 (nconc (completion-pcm--hilit-commonality pattern all)
3196 (length prefix)))))
3197
3198;; Initials completion
fcb68f70
SM
3199;; Complete /ums to /usr/monnier/src or lch to list-command-history.
3200
3201(defun completion-initials-expand (str table pred)
51b23c44
SM
3202 (let ((bounds (completion-boundaries str table pred "")))
3203 (unless (or (zerop (length str))
3204 ;; Only check within the boundaries, since the
3205 ;; boundary char (e.g. /) might be in delim-regexp.
3206 (string-match completion-pcm--delim-wild-regex str
3207 (car bounds)))
fcb68f70
SM
3208 (if (zerop (car bounds))
3209 (mapconcat 'string str "-")
3210 ;; If there's a boundary, it's trickier. The main use-case
3211 ;; we consider here is file-name completion. We'd like
3212 ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e.
3213 ;; But at the same time, we don't want /usr/share/ae to expand
3214 ;; to /usr/share/a/e just because we mistyped "ae" for "ar",
3215 ;; so we probably don't want initials to touch anything that
3216 ;; looks like /usr/share/foo. As a heuristic, we just check that
3217 ;; the text before the boundary char is at most 1 char.
3218 ;; This allows both ~/eee and /eee and not much more.
3219 ;; FIXME: It sadly also disallows the use of ~/eee when that's
3220 ;; embedded within something else (e.g. "(~/eee" in Info node
3221 ;; completion or "ancestor:/eee" in bzr-revision completion).
3222 (when (< (car bounds) 3)
3223 (let ((sep (substring str (1- (car bounds)) (car bounds))))
3224 ;; FIXME: the above string-match checks the whole string, whereas
3225 ;; we end up only caring about the after-boundary part.
3226 (concat (substring str 0 (car bounds))
3227 (mapconcat 'string (substring str (car bounds)) sep))))))))
3228
d032d5e7 3229(defun completion-initials-all-completions (string table pred _point)
fcb68f70
SM
3230 (let ((newstr (completion-initials-expand string table pred)))
3231 (when newstr
3232 (completion-pcm-all-completions newstr table pred (length newstr)))))
3233
d032d5e7 3234(defun completion-initials-try-completion (string table pred _point)
fcb68f70
SM
3235 (let ((newstr (completion-initials-expand string table pred)))
3236 (when newstr
3237 (completion-pcm-try-completion newstr table pred (length newstr)))))
4e323265
LL
3238\f
3239(defvar completing-read-function 'completing-read-default
3240 "The function called by `completing-read' to do its work.
3241It should accept the same arguments as `completing-read'.")
3242
3243(defun completing-read-default (prompt collection &optional predicate
3244 require-match initial-input
3245 hist def inherit-input-method)
3246 "Default method for reading from the minibuffer with completion.
3247See `completing-read' for the meaning of the arguments."
3248
3249 (when (consp initial-input)
3250 (setq initial-input
3251 (cons (car initial-input)
3252 ;; `completing-read' uses 0-based index while
3253 ;; `read-from-minibuffer' uses 1-based index.
3254 (1+ (cdr initial-input)))))
3255
3256 (let* ((minibuffer-completion-table collection)
3257 (minibuffer-completion-predicate predicate)
3258 (minibuffer-completion-confirm (unless (eq require-match t)
3259 require-match))
3349e122 3260 (base-keymap (if require-match
4e323265 3261 minibuffer-local-must-match-map
3349e122
SM
3262 minibuffer-local-completion-map))
3263 (keymap (if (memq minibuffer-completing-file-name '(nil lambda))
3264 base-keymap
3265 ;; Layer minibuffer-local-filename-completion-map
3266 ;; on top of the base map.
640c8776
SM
3267 (make-composed-keymap
3268 minibuffer-local-filename-completion-map
3269 ;; Set base-keymap as the parent, so that nil bindings
3270 ;; in minibuffer-local-filename-completion-map can
3271 ;; override bindings in base-keymap.
3272 base-keymap)))
4e323265
LL
3273 (result (read-from-minibuffer prompt initial-input keymap
3274 nil hist def inherit-input-method)))
3275 (when (and (equal result "") def)
3276 (setq result (if (consp def) (car def) def)))
3277 result))
7d371eac
JL
3278\f
3279;; Miscellaneous
3280
3281(defun minibuffer-insert-file-name-at-point ()
3282 "Get a file name at point in original buffer and insert it to minibuffer."
3283 (interactive)
3284 (let ((file-name-at-point
3285 (with-current-buffer (window-buffer (minibuffer-selected-window))
3286 (run-hook-with-args-until-success 'file-name-at-point-functions))))
3287 (when file-name-at-point
3288 (insert file-name-at-point))))
34200787 3289
32bae13c 3290(provide 'minibuffer)
dc6ee347 3291
32bae13c 3292;;; minibuffer.el ends here