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