;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Package: emacs
;; internal use only.
;; Functional completion tables have an extended calling conventions:
-;; - The `action' can be (additionally to nil, t, and lambda) of the form
-;; (boundaries . SUFFIX) in which case it should return
+;; The `action' can be (additionally to nil, t, and lambda) of the form
+;; - (boundaries . SUFFIX) in which case it should return
;; (boundaries START . END). See `completion-boundaries'.
;; Any other return value should be ignored (so we ignore values returned
;; from completion tables that don't know about this new `action' form).
+;; - `metadata' in which case it should return (metadata . ALIST) where
+;; ALIST is the metadata of this table. See `completion-metadata'.
+;; Any other return value should be ignored (so we ignore values returned
+;; from completion tables that don't know about this new `action' form).
;;; Bugs:
;; corresponding to the displayed completions because we only
;; provide the start info but not the end info in
;; completion-base-position.
-;; - quoting is problematic. E.g. the double-dollar quoting used in
-;; substitute-in-file-name (and hence read-file-name-internal) bumps
-;; into various bugs:
-;; - choose-completion doesn't know how to quote the text it inserts.
-;; E.g. it fails to double the dollars in file-name completion, or
-;; to backslash-escape spaces and other chars in comint completion.
-;; - when completing ~/tmp/fo$$o, the highligting in *Completions*
-;; is off by one position.
-;; - all code like PCM which relies on all-completions to match
-;; its argument gets confused because all-completions returns unquoted
-;; texts (as desired for *Completions* output).
;; - C-x C-f ~/*/sr ? should not list "~/./src".
;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el
;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
;; - for M-x, cycle-sort commands that have no key binding first.
;; - Make things like icomplete-mode or lightning-completion work with
;; completion-in-region-mode.
-;; - extend `boundaries' to provide various other meta-data about the
-;; output of `all-completions':
-;; - preferred sorting order when displayed in *Completions*.
-;; - annotations/text-properties to add when displayed in *Completions*.
-;; - quoting/unquoting (so we can complete files names with envvars
-;; and backslashes, and all-completion can list names without
-;; quoting backslashes and dollars).
+;; - extend `metadata':
;; - indicate how to turn all-completion's output into
;; try-completion's output: e.g. completion-ignored-extensions.
-;; maybe that could be merged with the "quote" operation above.
+;; maybe that could be merged with the "quote" operation.
;; - indicate that `all-completions' doesn't do prefix-completion
;; but just returns some list that relates in some other way to
;; the provided string (as is the case in filecache.el), in which
and for file names the result is the positions delimited by
the closest directory separators."
(let ((boundaries (if (functionp table)
- (funcall table string pred (cons 'boundaries suffix)))))
+ (funcall table string pred
+ (cons 'boundaries suffix)))))
(if (not (eq (car-safe boundaries) 'boundaries))
(setq boundaries nil))
(cons (or (cadr boundaries) 0)
(or (cddr boundaries) (length suffix)))))
+(defun completion-metadata (string table pred)
+ "Return the metadata of elements to complete at the end of STRING.
+This metadata is an alist. Currently understood keys are:
+- `category': the kind of objects returned by `all-completions'.
+ Used by `completion-category-overrides'.
+- `annotation-function': function to add annotations in *Completions*.
+ Takes one argument (STRING), which is a possible completion and
+ returns a string to append to STRING.
+- `display-sort-function': function to sort entries in *Completions*.
+ Takes one argument (COMPLETIONS) and should return a new list
+ of completions. Can operate destructively.
+- `cycle-sort-function': function to sort entries when cycling.
+ Works like `display-sort-function'.
+The metadata of a completion table should be constant between two boundaries."
+ (let ((metadata (if (functionp table)
+ (funcall table string pred 'metadata))))
+ (if (eq (car-safe metadata) 'metadata)
+ metadata
+ '(metadata))))
+
+(defun completion--field-metadata (field-start)
+ (completion-metadata (buffer-substring-no-properties field-start (point))
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+
+(defun completion-metadata-get (metadata prop)
+ (cdr (assq prop metadata)))
+
(defun completion--some (fun xs)
"Apply FUN to each element of XS in turn.
Return the first non-nil returned value.
(defun complete-with-action (action table string pred)
"Perform completion ACTION.
STRING is the string to complete.
-TABLE is the completion table, which should not be a function.
+TABLE is the completion table.
PRED is a completion predicate.
ACTION can be one of nil, t or `lambda'."
(cond
((functionp table) (funcall table string pred action))
- ((eq (car-safe action) 'boundaries)
- (cons 'boundaries (completion-boundaries string table pred (cdr action))))
+ ((eq (car-safe action) 'boundaries) nil)
+ ((eq action 'metadata) nil)
(t
(funcall
(cond
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
(lambda (string pred action)
- (if (eq (car-safe action) 'boundaries)
+ (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
;; `fun' is not supposed to return another function but a plain old
;; completion table, whose boundaries are always trivial.
nil
`(completion-table-dynamic
(lambda (,str)
(when (functionp ,var)
- (setq ,var (,fun)))
+ (setq ,var (funcall #',fun)))
,var))))
-(defun completion-table-case-fold (table string pred action)
- (let ((completion-ignore-case t))
- (complete-with-action action table string pred)))
+(defun completion-table-case-fold (table &optional dont-fold)
+ "Return new completion TABLE that is case insensitive.
+If DONT-FOLD is non-nil, return a completion table that is
+case sensitive instead."
+ (lambda (string pred action)
+ (let ((completion-ignore-case (not dont-fold)))
+ (complete-with-action action table string pred))))
+
+(defun completion-table-subvert (table s1 s2)
+ "Completion table that replaces the prefix S1 with S2 in STRING.
+The result is a completion table which completes strings of the
+form (concat S1 S) in the same way as TABLE completes strings of
+the form (concat S2 S)."
+ (lambda (string pred action)
+ (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
+ completion-ignore-case))
+ (concat s2 (substring string (length s1)))))
+ (res (if str (complete-with-action action table str pred))))
+ (when res
+ (cond
+ ((eq (car-safe action) 'boundaries)
+ (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
+ (list* 'boundaries
+ (max (length s1)
+ (+ beg (- (length s1) (length s2))))
+ (and (eq (car-safe res) 'boundaries) (cddr res)))))
+ ((stringp res)
+ (if (eq t (compare-strings res 0 (length s2) s2 nil nil
+ completion-ignore-case))
+ (concat s1 (substring res (length s2)))))
+ ((eq action t)
+ (let ((bounds (completion-boundaries str table pred "")))
+ (if (>= (car bounds) (length s2))
+ res
+ (let ((re (concat "\\`"
+ (regexp-quote (substring s2 (car bounds))))))
+ (delq nil
+ (mapcar (lambda (c)
+ (if (string-match re c)
+ (substring c (match-end 0))))
+ res))))))
+ ;; E.g. action=nil and it's the only completion.
+ (res))))))
(defun completion-table-with-context (prefix table string pred action)
;; TODO: add `suffix' maybe?
- ;; Notice that `pred' may not be a function in some abusive cases.
- (when (functionp pred)
- (setq pred
- ;; Predicates are called differently depending on the nature of
- ;; the completion table :-(
- (cond
- ((vectorp table) ;Obarray.
- (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
- ((hash-table-p table)
- (lambda (s _v) (funcall pred (concat prefix s))))
- ((functionp table)
- (lambda (s) (funcall pred (concat prefix s))))
- (t ;Lists and alists.
- (lambda (s)
- (funcall pred (concat prefix (if (consp s) (car s) s))))))))
- (if (eq (car-safe action) 'boundaries)
- (let* ((len (length prefix))
- (bound (completion-boundaries string table pred (cdr action))))
- (list* 'boundaries (+ (car bound) len) (cdr bound)))
- (let ((comp (complete-with-action action table string pred)))
- (cond
- ;; In case of try-completion, add the prefix.
- ((stringp comp) (concat prefix comp))
- (t comp)))))
+ (let ((pred
+ (if (not (functionp pred))
+ ;; Notice that `pred' may not be a function in some abusive cases.
+ pred
+ ;; Predicates are called differently depending on the nature of
+ ;; the completion table :-(
+ (cond
+ ((vectorp table) ;Obarray.
+ (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
+ ((hash-table-p table)
+ (lambda (s _v) (funcall pred (concat prefix s))))
+ ((functionp table)
+ (lambda (s) (funcall pred (concat prefix s))))
+ (t ;Lists and alists.
+ (lambda (s)
+ (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
+ (if (eq (car-safe action) 'boundaries)
+ (let* ((len (length prefix))
+ (bound (completion-boundaries string table pred (cdr action))))
+ (list* 'boundaries (+ (car bound) len) (cdr bound)))
+ (let ((comp (complete-with-action action table string pred)))
+ (cond
+ ;; In case of try-completion, add the prefix.
+ ((stringp comp) (concat prefix comp))
+ (t comp))))))
(defun completion-table-with-terminator (terminator table string pred action)
"Construct a completion table like TABLE but with an extra TERMINATOR.
(funcall terminator comp)
(concat comp terminator))
comp))))
- ((eq action t)
+ ;; completion-table-with-terminator is always used for
+ ;; "sub-completions" so it's only called if the terminator is missing,
+ ;; in which case `test-completion' should return nil.
+ ((eq action 'lambda) nil)
+ (t
;; FIXME: We generally want the `try' and `all' behaviors to be
;; consistent so pcm can merge the `all' output to get the `try' output,
;; but that sometimes clashes with the need for `all' output to look
;; good in *Completions*.
;; (mapcar (lambda (s) (concat s terminator))
;; (all-completions string table pred))))
- (all-completions string table pred))
- ;; completion-table-with-terminator is always used for
- ;; "sub-completions" so it's only called if the terminator is missing,
- ;; in which case `test-completion' should return nil.
- ((eq action 'lambda) nil)))
+ (complete-with-action action table string pred))))
(defun completion-table-with-predicate (table pred1 strict string pred2 action)
"Make a completion table equivalent to TABLE but filtered through PRED1.
(test-completion string table pred2))
(t
(or (complete-with-action action table string
- (if (null pred2) pred1
+ (if (not (and pred1 pred2))
+ (or pred1 pred2)
(lambda (x)
;; Call `pred1' first, so that `pred2'
;; really can't tell that `x' is in table.
- (if (funcall pred1 x) (funcall pred2 x)))))
+ (and (funcall pred1 x) (funcall pred2 x)))))
;; If completion failed and we're not applying pred1 strictly, try
;; again without pred1.
- (and (not strict)
+ (and (not strict) pred1 pred2
(complete-with-action action table string pred2))))))
(defun completion-table-in-turn (&rest tables)
(complete-with-action action table string pred))
tables)))
+(defun completion-table-with-quoting (table unquote requote)
+ ;; A difficult part of completion-with-quoting is to map positions in the
+ ;; quoted string to equivalent positions in the unquoted string and
+ ;; vice-versa. There is no efficient and reliable algorithm that works for
+ ;; arbitrary quote and unquote functions.
+ ;; So to map from quoted positions to unquoted positions, we simply assume
+ ;; that `concat' and `unquote' commute (which tends to be the case).
+ ;; And we ask `requote' to do the work of mapping from unquoted positions
+ ;; back to quoted positions.
+ "Return a new completion table operating on quoted text.
+TABLE operates on the unquoted text.
+UNQUOTE is a function that takes a string and returns a new unquoted string.
+REQUOTE is a function of 2 args (UPOS QSTR) where
+ QSTR is a string entered by the user (and hence indicating
+ the user's preferred form of quoting); and
+ UPOS is a position within the unquoted form of QSTR.
+REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the
+position corresponding to UPOS but in QSTR, and QFUN is a function
+of one argument (a string) which returns that argument appropriately quoted
+for use at QPOS."
+ ;; FIXME: One problem with the current setup is that `qfun' doesn't know if
+ ;; its argument is "the end of the completion", so if the quoting used double
+ ;; quotes (for example), we end up completing "fo" to "foobar and throwing
+ ;; away the closing double quote.
+ (lambda (string pred action)
+ (cond
+ ((eq action 'metadata)
+ (append (completion-metadata string table pred)
+ '((completion--unquote-requote . t))))
+
+ ((eq action 'lambda) ;;test-completion
+ (let ((ustring (funcall unquote string)))
+ (test-completion ustring table pred)))
+
+ ((eq (car-safe action) 'boundaries)
+ (let* ((ustring (funcall unquote string))
+ (qsuffix (cdr action))
+ (ufull (if (zerop (length qsuffix)) ustring
+ (funcall unquote (concat string qsuffix))))
+ (_ (assert (string-prefix-p ustring ufull)))
+ (usuffix (substring ufull (length ustring)))
+ (boundaries (completion-boundaries ustring table pred usuffix))
+ (qlboundary (car (funcall requote (car boundaries) string)))
+ (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
+ (let* ((urfullboundary
+ (+ (cdr boundaries) (length ustring))))
+ (- (car (funcall requote urfullboundary
+ (concat string qsuffix)))
+ (length string))))))
+ (list* 'boundaries qlboundary qrboundary)))
+
+ ;; In "normal" use a c-t-with-quoting completion table should never be
+ ;; called with action in (t nil) because `completion--unquote' should have
+ ;; been called before and would have returned a different completion table
+ ;; to apply to the unquoted text. But there's still a lot of code around
+ ;; that likes to use all/try-completions directly, so we do our best to
+ ;; handle those calls as well as we can.
+
+ ((eq action nil) ;;try-completion
+ (let* ((ustring (funcall unquote string))
+ (completion (try-completion ustring table pred)))
+ ;; Most forms of quoting allow several ways to quote the same string.
+ ;; So here we could simply requote `completion' in a kind of
+ ;; "canonical" quoted form without paying attention to the way
+ ;; `string' was quoted. But since we have to solve the more complex
+ ;; problems of "pay attention to the original quoting" for
+ ;; all-completions, we may as well use it here, since it provides
+ ;; a nicer behavior.
+ (if (not (stringp completion)) completion
+ (car (completion--twq-try
+ string ustring completion 0 unquote requote)))))
+
+ ((eq action t) ;;all-completions
+ ;; When all-completions is used for completion-try/all-completions
+ ;; (e.g. for `pcm' style), we can't do the job properly here because
+ ;; the caller will match our output against some pattern derived from
+ ;; the user's (quoted) input, and we don't have access to that
+ ;; pattern, so we can't know how to requote our output so that it
+ ;; matches the quoting used in the pattern. It is to fix this
+ ;; fundamental problem that we have to introduce the new
+ ;; unquote-requote method so that completion-try/all-completions can
+ ;; pass the unquoted string to the style functions.
+ (pcase-let*
+ ((ustring (funcall unquote string))
+ (completions (all-completions ustring table pred))
+ (boundary (car (completion-boundaries ustring table pred "")))
+ (completions
+ (completion--twq-all
+ string ustring completions boundary unquote requote))
+ (last (last completions)))
+ (when (consp last) (setcdr last nil))
+ completions))
+
+ ((eq action 'completion--unquote)
+ (let ((ustring (funcall unquote string))
+ (uprefix (funcall unquote (substring string 0 pred))))
+ ;; We presume (more or less) that `concat' and `unquote' commute.
+ (assert (string-prefix-p uprefix ustring))
+ (list ustring table (length uprefix)
+ (lambda (unquoted-result op)
+ (pcase op
+ (`1 ;;try
+ (if (not (stringp (car-safe unquoted-result)))
+ unquoted-result
+ (completion--twq-try
+ string ustring
+ (car unquoted-result) (cdr unquoted-result)
+ unquote requote)))
+ (`2 ;;all
+ (let* ((last (last unquoted-result))
+ (base (or (cdr last) 0)))
+ (when last
+ (setcdr last nil)
+ (completion--twq-all string ustring
+ unquoted-result base
+ unquote requote))))))))))))
+
+(defun completion--twq-try (string ustring completion point
+ unquote requote)
+ ;; Basically two case: either the new result is
+ ;; - commonprefix1 <point> morecommonprefix <qpos> suffix
+ ;; - commonprefix <qpos> newprefix <point> suffix
+ (pcase-let*
+ ((prefix (fill-common-string-prefix ustring completion))
+ (suffix (substring completion (max point (length prefix))))
+ (`(,qpos . ,qfun) (funcall requote (length prefix) string))
+ (qstr1 (if (> point (length prefix))
+ (funcall qfun (substring completion (length prefix) point))))
+ (qsuffix (funcall qfun suffix))
+ (qstring (concat (substring string 0 qpos) qstr1 qsuffix))
+ (qpoint
+ (cond
+ ((zerop point) 0)
+ ((> point (length prefix)) (+ qpos (length qstr1)))
+ (t (car (funcall requote point string))))))
+ ;; Make sure `requote' worked.
+ (assert (equal (funcall unquote qstring) completion))
+ (cons qstring qpoint)))
+
+(defun completion--string-equal-p (s1 s2)
+ (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
+
+(defun completion--twq-all (string ustring completions boundary
+ unquote requote)
+ (when completions
+ (pcase-let*
+ ((prefix
+ (let ((completion-regexp-list nil))
+ (try-completion "" (cons (substring ustring boundary)
+ completions))))
+ (`(,qfullpos . ,qfun)
+ (funcall requote (+ boundary (length prefix)) string))
+ (qfullprefix (substring string 0 qfullpos))
+ (_ (assert (completion--string-equal-p
+ (funcall unquote qfullprefix)
+ (concat (substring ustring 0 boundary) prefix))
+ t))
+ (qboundary (car (funcall requote boundary string)))
+ (_ (assert (<= qboundary qfullpos)))
+ ;; FIXME: this split/quote/concat business messes up the carefully
+ ;; placed completions-common-part and completions-first-difference
+ ;; faces. We could try within the mapcar loop to search for the
+ ;; boundaries of those faces, pass them to `requote' to find their
+ ;; equivalent positions in the quoted output and re-add the faces:
+ ;; this might actually lead to correct results but would be
+ ;; pretty expensive.
+ ;; The better solution is to not quote the *Completions* display,
+ ;; which nicely circumvents the problem. The solution I used here
+ ;; instead is to hope that `qfun' preserves the text-properties and
+ ;; presume that the `first-difference' is not within the `prefix';
+ ;; this presumption is not always true, but at least in practice it is
+ ;; true in most cases.
+ (qprefix (propertize (substring qfullprefix qboundary)
+ 'face 'completions-common-part)))
+
+ ;; Here we choose to quote all elements returned, but a better option
+ ;; would be to return unquoted elements together with a function to
+ ;; requote them, so that *Completions* can show nicer unquoted values
+ ;; which only get quoted when needed by choose-completion.
+ (nconc
+ (mapcar (lambda (completion)
+ (assert (string-prefix-p prefix completion 'ignore-case) t)
+ (let* ((new (substring completion (length prefix)))
+ (qnew (funcall qfun new))
+ (qcompletion (concat qprefix qnew)))
+ (assert
+ (completion--string-equal-p
+ (funcall unquote
+ (concat (substring string 0 qboundary)
+ qcompletion))
+ (concat (substring ustring 0 boundary)
+ completion))
+ t)
+ qcompletion))
+ completions)
+ qboundary))))
+
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
(define-obsolete-function-alias
follow the calling convention of `completion-all-completions'),
and DOC describes the way this style of completion works.")
+(defconst completion--styles-type
+ `(repeat :tag "insert a new menu to add more styles"
+ (choice ,@(mapcar (lambda (x) (list 'const (car x)))
+ completion-styles-alist))))
+(defconst completion--cycling-threshold-type
+ '(choice (const :tag "No cycling" nil)
+ (const :tag "Always cycle" t)
+ (integer :tag "Threshold")))
+
(defcustom completion-styles
;; First, use `basic' because prefix completion has been the standard
;; for "ever" and works well in most cases, so using it first
;; and simply add "bar" to the end of the result.
emacs22)
"List of completion styles to use.
-The available styles are listed in `completion-styles-alist'."
- :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x)))
- completion-styles-alist)))
+The available styles are listed in `completion-styles-alist'.
+
+Note that `completion-category-overrides' may override these
+styles for specific categories, such as files, buffers, etc."
+ :type completion--styles-type
:group 'minibuffer
:version "23.1")
-(defun completion-try-completion (string table pred point)
+(defcustom completion-category-overrides
+ '((buffer (styles . (basic substring))))
+ "List of `completion-styles' overrides for specific categories.
+Each override has the shape (CATEGORY . ALIST) where ALIST is
+an association list that can specify properties such as:
+- `styles': the list of `completion-styles' to use for that category.
+- `cycle': the `completion-cycle-threshold' to use for that category.
+Categories are symbols such as `buffer' and `file', used when
+completing buffer and file names, respectively."
+ :version "24.1"
+ :type `(alist :key-type (choice :tag "Category"
+ (const buffer)
+ (const file)
+ (const unicode-name)
+ symbol)
+ :value-type
+ (set :tag "Properties to override"
+ (cons :tag "Completion Styles"
+ (const :tag "Select a style from the menu;" styles)
+ ,completion--styles-type)
+ (cons :tag "Completion Cycling"
+ (const :tag "Select one value from the menu." cycle)
+ ,completion--cycling-threshold-type))))
+
+(defun completion--styles (metadata)
+ (let* ((cat (completion-metadata-get metadata 'category))
+ (over (assq 'styles (cdr (assq cat completion-category-overrides)))))
+ (if over
+ (delete-dups (append (cdr over) (copy-sequence completion-styles)))
+ completion-styles)))
+
+(defun completion--nth-completion (n string table pred point metadata)
+ "Call the Nth method of completion styles."
+ (unless metadata
+ (setq metadata
+ (completion-metadata (substring string 0 point) table pred)))
+ ;; We provide special support for quoting/unquoting here because it cannot
+ ;; reliably be done within the normal completion-table routines: Completion
+ ;; styles such as `substring' or `partial-completion' need to match the
+ ;; output of all-completions with the user's input, and since most/all
+ ;; quoting mechanisms allow several equivalent quoted forms, the
+ ;; completion-style can't do this matching (e.g. `substring' doesn't know
+ ;; that "\a\b\e" is a valid (quoted) substring of "label").
+ ;; The quote/unquote function needs to come from the completion table (rather
+ ;; than from completion-extra-properties) because it may apply only to some
+ ;; part of the string (e.g. substitute-in-file-name).
+ (let ((requote
+ (when (completion-metadata-get metadata 'completion--unquote-requote)
+ (let ((new (funcall table string point 'completion--unquote)))
+ (setq string (pop new))
+ (setq table (pop new))
+ (setq point (pop new))
+ (pop new))))
+ (result
+ (completion--some (lambda (style)
+ (funcall (nth n (assq style
+ completion-styles-alist))
+ string table pred point))
+ (completion--styles metadata))))
+ (if requote
+ (funcall requote result n)
+ result)))
+
+(defun completion-try-completion (string table pred point &optional metadata)
"Try to complete STRING using completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
The return value can be either nil to indicate that there is no completion,
t to indicate that STRING is the only possible completion,
-or a pair (STRING . NEWPOINT) of the completed result string together with
+or a pair (NEWSTRING . NEWPOINT) of the completed result string together with
a new position for point."
- (completion--some (lambda (style)
- (funcall (nth 1 (assq style completion-styles-alist))
- string table pred point))
- completion-styles))
+ (completion--nth-completion 1 string table pred point metadata))
-(defun completion-all-completions (string table pred point)
+(defun completion-all-completions (string table pred point &optional metadata)
"List the possible completions of STRING in completion table TABLE.
Only the elements of table that satisfy predicate PRED are considered.
POINT is the position of point within STRING.
in the last `cdr'."
;; FIXME: We need to additionally return the info needed for the
;; second part of completion-base-position.
- (completion--some (lambda (style)
- (funcall (nth 2 (assq style completion-styles-alist))
- string table pred point))
- completion-styles))
+ (completion--nth-completion 2 string table pred point metadata))
(defun minibuffer--bitset (modified completions exact)
(logior (if modified 4 0)
(defun completion--replace (beg end newtext)
"Replace the buffer text between BEG and END with NEWTEXT.
Moves point to the end of the new text."
+ ;; The properties on `newtext' include things like
+ ;; completions-first-difference, which we don't want to include
+ ;; upon insertion.
+ (set-text-properties 0 (length newtext) nil newtext)
;; Maybe this should be in subr.el.
;; You'd think this is trivial to do, but details matter if you want
;; to keep markers "at the right place" and be robust in the face of
(setq end (- end suffix-len))
(setq newtext (substring newtext 0 (- suffix-len))))
(goto-char beg)
- (insert newtext)
+ (insert-and-inherit newtext)
(delete-region (point) (+ (point) (- end beg)))
(forward-char suffix-len)))
If t, cycling is always used.
If an integer, cycling is used as soon as there are fewer completion
candidates than this number."
- :type '(choice (const :tag "No cycling" nil)
- (const :tag "Always cycle" t)
- (integer :tag "Threshold")))
+ :version "24.1"
+ :type completion--cycling-threshold-type)
+
+(defun completion--cycle-threshold (metadata)
+ (let* ((cat (completion-metadata-get metadata 'category))
+ (over (assq 'cycle (cdr (assq cat completion-category-overrides)))))
+ (if over (cdr over) completion-cycle-threshold)))
(defvar completion-all-sorted-completions nil)
(make-variable-buffer-local 'completion-all-sorted-completions)
(let* ((beg (field-beginning))
(end (field-end))
(string (buffer-substring beg end))
+ (md (completion--field-metadata beg))
(comp (funcall (or try-completion-function
'completion-try-completion)
string
minibuffer-completion-table
minibuffer-completion-predicate
- (- (point) beg))))
+ (- (point) beg)
+ md)))
(cond
((null comp)
(minibuffer-hide-completions)
(completion--do-completion try-completion-function expect-exact)
;; It did find a match. Do we match some possibility exactly now?
- (let ((exact (test-completion completion
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (comps
- ;; Check to see if we want to do cycling. We do it
- ;; here, after having performed the normal completion,
- ;; so as to take advantage of the difference between
- ;; try-completion and all-completions, for things
- ;; like completion-ignored-extensions.
- (when (and completion-cycle-threshold
- ;; Check that the completion didn't make
- ;; us jump to a different boundary.
- (or (not completed)
- (< (car (completion-boundaries
- (substring completion 0 comp-pos)
+ (let* ((exact (test-completion completion
minibuffer-completion-table
- minibuffer-completion-predicate
+ minibuffer-completion-predicate))
+ (threshold (completion--cycle-threshold md))
+ (comps
+ ;; Check to see if we want to do cycling. We do it
+ ;; here, after having performed the normal completion,
+ ;; so as to take advantage of the difference between
+ ;; try-completion and all-completions, for things
+ ;; like completion-ignored-extensions.
+ (when (and threshold
+ ;; Check that the completion didn't make
+ ;; us jump to a different boundary.
+ (or (not completed)
+ (< (car (completion-boundaries
+ (substring completion 0 comp-pos)
+ minibuffer-completion-table
+ minibuffer-completion-predicate
""))
comp-pos)))
(completion-all-sorted-completions))))
(not (ignore-errors
;; This signal an (intended) error if comps is too
;; short or if completion-cycle-threshold is t.
- (consp (nthcdr completion-cycle-threshold comps)))))
+ (consp (nthcdr threshold comps)))))
;; Fewer than completion-cycle-threshold remaining
;; completions: let's cycle.
(setq completed t exact t)
- (setq completion-all-sorted-completions comps)
+ (completion--cache-all-sorted-completions comps)
(minibuffer-force-complete))
(completed
;; We could also decide to refresh the completions,
(interactive)
;; If the previous command was not this,
;; mark the completion buffer obsolete.
- (unless (eq this-command last-command)
+ (setq this-command 'completion-at-point)
+ (unless (eq 'completion-at-point last-command)
(completion--flush-all-sorted-completions)
(setq minibuffer-scroll-window nil))
(#b000 nil)
(t t)))))
+(defun completion--cache-all-sorted-completions (comps)
+ (add-hook 'after-change-functions
+ 'completion--flush-all-sorted-completions nil t)
+ (setq completion-all-sorted-completions comps))
+
(defun completion--flush-all-sorted-completions (&rest _ignore)
(remove-hook 'after-change-functions
'completion--flush-all-sorted-completions t)
(setq completion-cycling nil)
(setq completion-all-sorted-completions nil))
+(defun completion--metadata (string base md-at-point table pred)
+ ;; Like completion-metadata, but for the specific case of getting the
+ ;; metadata at `base', which tends to trigger pathological behavior for old
+ ;; completion tables which don't understand `metadata'.
+ (let ((bounds (completion-boundaries string table pred "")))
+ (if (eq (car bounds) base) md-at-point
+ (completion-metadata (substring string 0 base) table pred))))
+
(defun completion-all-sorted-completions ()
(or completion-all-sorted-completions
(let* ((start (field-beginning))
(end (field-end))
- (all (completion-all-completions (buffer-substring start end)
- minibuffer-completion-table
- minibuffer-completion-predicate
- (- (point) start)))
+ (string (buffer-substring start end))
+ (md (completion--field-metadata start))
+ (all (completion-all-completions
+ string
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) start)
+ md))
(last (last all))
- (base-size (or (cdr last) 0)))
+ (base-size (or (cdr last) 0))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
(when last
(setcdr last nil)
- ;; Prefer shorter completions.
- (setq all (sort all (lambda (c1 c2)
- (let ((s1 (get-text-property
- 0 :completion-cycle-penalty c1))
- (s2 (get-text-property
- 0 :completion-cycle-penalty c2)))
- (if (eq s1 s2)
- (< (length c1) (length c2))
- (< (or s1 (length c1))
- (or s2 (length c2))))))))
+ (setq all (if sort-fun (funcall sort-fun all)
+ ;; Prefer shorter completions, by default.
+ (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
;; Prefer recently used completions.
- ;; FIXME: Additional sorting ideas:
- ;; - for M-x, prefer commands that have no key binding.
(when (minibufferp)
(let ((hist (symbol-value minibuffer-history-variable)))
(setq all (sort all (lambda (c1 c2)
;; Cache the result. This is not just for speed, but also so that
;; repeated calls to minibuffer-force-complete can cycle through
;; all possibilities.
- (add-hook 'after-change-functions
- 'completion--flush-all-sorted-completions nil t)
- (setq completion-all-sorted-completions
- (nconc all base-size))))))
+ (completion--cache-all-sorted-completions (nconc all base-size))))))
(defun minibuffer-force-complete ()
"Complete the minibuffer to an exact match.
;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
(let* ((start (field-beginning))
(end (field-end))
+ ;; (md (completion--field-metadata start))
(all (completion-all-sorted-completions))
(base (+ start (or (cdr (last all)) 0))))
(cond
(completion--done (buffer-substring-no-properties start (point))
'finished (unless mod "Sole completion"))))
(t
- (setq completion-cycling t)
(completion--replace base end (car all))
(completion--done (buffer-substring-no-properties start (point)) 'sole)
+ ;; Set cycling after modifying the buffer since the flush hook resets it.
+ (setq completion-cycling t)
;; If completing file names, (car all) may be a directory, so we'd now
;; have a new set of possible completions and might want to reset
;; completion-all-sorted-completions to nil, but we prefer not to,
;; through the previous possible completions.
(let ((last (last all)))
(setcdr last (cons (car all) (cdr last)))
- (setq completion-all-sorted-completions (cdr all)))))))
+ (completion--cache-all-sorted-completions (cdr all)))))))
(defvar minibuffer-confirm-exit-commands
'(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word)
;; file, so `try-completion' actually completes to
;; that file.
(= (length string) (length compl)))
- (goto-char end)
- (insert compl)
- (delete-region beg end))))
+ (completion--replace beg end compl))))
(exit-minibuffer))
((memq minibuffer-completion-confirm '(confirm confirm-after-completion))
nil))
(t nil))))))
-(defun completion--try-word-completion (string table predicate point)
- (let ((comp (completion-try-completion string table predicate point)))
+(defun completion--try-word-completion (string table predicate point md)
+ (let ((comp (completion-try-completion string table predicate point md)))
(if (not (consp comp))
comp
(while (and exts (not (consp tem)))
(setq tem (completion-try-completion
(concat before (pop exts) after)
- table predicate (1+ point))))
+ table predicate (1+ point) md)))
(if (consp tem) (setq comp tem))))
;; Completing a single word is actually more difficult than completing
(column 0)
(rows (/ (length strings) columns))
(row 0)
+ (first t)
(laststring nil))
;; The insertion should be "sensible" no matter what choices were made
;; for the parameters above.
(dolist (str strings)
(unless (equal laststring str) ; Remove (consecutive) duplicates.
(setq laststring str)
+ ;; FIXME: `string-width' doesn't pay attention to
+ ;; `display' properties.
(let ((length (if (consp str)
(+ (string-width (car str))
(string-width (cadr str)))
(forward-line 1)
(end-of-line)))
(insert " \t")
- (set-text-properties (- (point) 1) (point)
+ (set-text-properties (1- (point)) (point)
`(display (space :align-to ,column)))))
(t
;; Horizontal format
- (unless (bolp)
+ (unless first
(if (< wwidth (+ (max colwidth length) column))
;; No space for `str' at point, move to next line.
(progn (insert "\n") (setq column 0))
;; Leave the space unpropertized so that in the case we're
;; already past the goal column, there is still
;; a space displayed.
- (set-text-properties (- (point) 1) (point)
+ (set-text-properties (1- (point)) (point)
;; We can't just set tab-width, because
;; completion-setup-function will kill
;; all local variables :-(
`(display (space :align-to ,column)))
nil))))
+ (setq first nil)
(if (not (consp str))
(put-text-property (point) (progn (insert str) (point))
'mouse-face 'highlight)
(defvar completion-extra-properties nil
"Property list of extra properties of the current completion job.
These include:
-`:annotation-function': Function to add annotations in the completions buffer.
- The function takes a completion and should either return nil, or a string
- that will be displayed next to the completion. The function can access the
- completion data via `minibuffer-completion-table' and related variables.
+
+`:annotation-function': Function to annotate the completions buffer.
+ The function must accept one argument, a completion string,
+ and return either nil or a string which is to be displayed
+ next to the completion (but which is not part of the
+ completion). The function can access the completion data via
+ `minibuffer-completion-table' and related variables.
+
`:exit-function': Function to run after completion is performed.
- The function takes at least 2 parameters (STRING and STATUS) where STRING
- is the text to which the field was completed and STATUS indicates what
- kind of operation happened: if text is now complete it's `finished', if text
- cannot be further completed but completion is not finished, it's `sole', if
- text is a valid completion but may be further completed, it's `exact', and
- other STATUSes may be added in the future.")
+
+ The function must accept two arguments, STRING and STATUS.
+ STRING is the text to which the field was completed, and
+ STATUS indicates what kind of operation happened:
+ `finished' - text is now complete
+ `sole' - text cannot be further completed but
+ completion is not finished
+ `exact' - text is a valid completion but may be further
+ completed.")
(defvar completion-annotate-function
nil
(let* ((start (field-beginning))
(end (field-end))
(string (field-string))
+ (md (completion--field-metadata start))
(completions (completion-all-completions
string
minibuffer-completion-table
minibuffer-completion-predicate
- (- (point) (field-beginning)))))
+ (- (point) (field-beginning))
+ md)))
(message nil)
(if (or (null completions)
(and (not (consp (cdr completions)))
(let* ((last (last completions))
(base-size (cdr last))
(prefix (unless (zerop base-size) (substring string 0 base-size)))
- (global-af (or (plist-get completion-extra-properties
- :annotation-function)
- completion-annotate-function))
+ (all-md (completion--metadata (buffer-substring-no-properties
+ start (point))
+ base-size md
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (afun (or (completion-metadata-get all-md 'annotation-function)
+ (plist-get completion-extra-properties
+ :annotation-function)
+ completion-annotate-function))
;; If the *Completions* buffer is shown in a new
;; window, mark it as softly-dedicated, so bury-buffer in
;; minibuffer-hide-completions will know whether to
;; Remove the base-size tail because `sort' requires a properly
;; nil-terminated list.
(when last (setcdr last nil))
- (setq completions (sort completions 'string-lessp))
(setq completions
- (cond
- (global-af
+ ;; FIXME: This function is for the output of all-completions,
+ ;; not completion-all-completions. Often it's the same, but
+ ;; not always.
+ (let ((sort-fun (completion-metadata-get
+ all-md 'display-sort-function)))
+ (if sort-fun
+ (funcall sort-fun completions)
+ (sort completions 'string-lessp))))
+ (when afun
+ (setq completions
(mapcar (lambda (s)
- (let ((ann (funcall global-af s)))
+ (let ((ann (funcall afun s)))
(if ann (list s ann) s)))
- completions))
- (t completions)))
+ completions)))
(with-current-buffer standard-output
(set (make-local-variable 'completion-base-position)
(cpred minibuffer-completion-predicate)
(cprops completion-extra-properties))
(lambda (start end choice)
- (unless
- (or (zerop (length prefix))
- (equal prefix
- (buffer-substring-no-properties
- (max (point-min) (- start (length prefix)))
- start)))
+ (unless (or (zerop (length prefix))
+ (equal prefix
+ (buffer-substring-no-properties
+ (max (point-min)
+ (- start (length prefix)))
+ start)))
(message "*Completions* out of date"))
;; FIXME: Use `md' to do quoting&terminator here.
(completion--replace start end choice)
(defun completion-in-region (start end collection &optional predicate)
"Complete the text between START and END using COLLECTION.
Return nil if there is no valid completion, else t.
-Point needs to be somewhere between START and END."
+Point needs to be somewhere between START and END.
+PREDICATE (a function called with no arguments) says when to
+exit."
(assert (<= start (point)) (<= (point) end))
(with-wrapper-hook
;; FIXME: Maybe we should use this hook to provide a "display
(minibuffer-completion-predicate predicate)
(ol (make-overlay start end nil nil t)))
(overlay-put ol 'field 'completion)
+ ;; HACK: if the text we are completing is already in a field, we
+ ;; want the completion field to take priority (e.g. Bug#6830).
+ (overlay-put ol 'priority 100)
(when completion-in-region-mode-predicate
(completion-in-region-mode 1)
(setq completion-in-region--data
- (list (current-buffer) start end collection)))
+ (list (current-buffer) start end collection)))
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
(let ((map (make-sparse-keymap)))
;; FIXME: Only works if completion-in-region-mode was activated via
;; completion-at-point called directly.
- (define-key map "?" 'completion-help-at-point)
+ (define-key map "\M-?" 'completion-help-at-point)
(define-key map "\t" 'completion-at-point)
map)
"Keymap activated during `completion-in-region'.")
;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
(define-minor-mode completion-in-region-mode
- "Transient minor mode used during `completion-in-region'."
+ "Transient minor mode used during `completion-in-region'.
+With a prefix argument ARG, enable the modemode if ARG is
+positive, and disable it otherwise. If called from Lisp, enable
+the mode if ARG is omitted or nil."
:global t
(setq completion-in-region--data nil)
;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
Each function on this hook is called in turns without any argument and should
return either nil to mean that it is not applicable at point,
or a function of no argument to perform completion (discouraged),
-or a list of the form (START END COLLECTION &rest PROPS) where
+or a list of the form (START END COLLECTION . PROPS) where
START and END delimit the entity to complete and should include point,
COLLECTION is the completion table to use to complete it, and
PROPS is a property list for additional information.
Currently supported properties are all the properties that can appear in
`completion-extra-properties' plus:
`:predicate' a predicate that completion candidates need to satisfy.
- `:exclusive' If `no', means that if the completion data does not match the
- text at point failure, then instead of reporting a completion failure,
- the completion should try the next completion function.")
+ `:exclusive' If `no', means that if the completion table fails to
+ match the text at point, then instead of reporting a completion
+ failure, the completion should try the next completion function.")
(defvar completion--capf-misbehave-funs nil
"List of functions found on `completion-at-point-functions' that misbehave.
;; introduce a corresponding hook (plus another for word-completion,
;; and another for force-completion, maybe?).
(overlay-put ol 'field 'completion)
+ (overlay-put ol 'priority 100)
(completion-in-region-mode 1)
(setq completion-in-region--data
- (list (current-buffer) start end collection))
+ (list (current-buffer) start end collection))
(unwind-protect
(call-interactively 'minibuffer-completion-help)
(delete-overlay ol))))
;;; Key bindings.
-(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
- 'minibuffer-local-filename-must-match-map "23.1")
-
(let ((map minibuffer-local-map))
(define-key map "\C-g" 'abort-recursive-edit)
(define-key map "\r" 'exit-minibuffer)
(define-key map "\n" 'exit-minibuffer))
-(let ((map minibuffer-local-completion-map))
- (define-key map "\t" 'minibuffer-complete)
- ;; M-TAB is already abused for many other purposes, so we should find
- ;; another binding for it.
- ;; (define-key map "\e\t" 'minibuffer-force-complete)
- (define-key map " " 'minibuffer-complete-word)
- (define-key map "?" 'minibuffer-completion-help))
+(defvar minibuffer-local-completion-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\t" 'minibuffer-complete)
+ ;; M-TAB is already abused for many other purposes, so we should find
+ ;; another binding for it.
+ ;; (define-key map "\e\t" 'minibuffer-force-complete)
+ (define-key map " " 'minibuffer-complete-word)
+ (define-key map "?" 'minibuffer-completion-help)
+ map)
+ "Local keymap for minibuffer input with completion.")
+
+(defvar minibuffer-local-must-match-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-completion-map)
+ (define-key map "\r" 'minibuffer-complete-and-exit)
+ (define-key map "\n" 'minibuffer-complete-and-exit)
+ map)
+ "Local keymap for minibuffer input with completion, for exact match.")
-(let ((map minibuffer-local-must-match-map))
- (define-key map "\r" 'minibuffer-complete-and-exit)
- (define-key map "\n" 'minibuffer-complete-and-exit))
+(defvar minibuffer-local-filename-completion-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map " " nil)
+ map)
+ "Local keymap for minibuffer input with completion for filenames.
+Gets combined either with `minibuffer-local-completion-map' or
+with `minibuffer-local-must-match-map'.")
-(let ((map minibuffer-local-filename-completion-map))
- (define-key map " " nil))
-(let ((map minibuffer-local-filename-must-match-map))
- (define-key map " " nil))
+(define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
+ 'minibuffer-local-filename-must-match-map "23.1")
+(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
+(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
(let ((map minibuffer-local-ns-map))
(define-key map " " 'exit-minibuffer)
(define-key map "\t" 'exit-minibuffer)
(define-key map "?" 'self-insert-and-exit))
+(defvar minibuffer-inactive-mode-map
+ (let ((map (make-keymap)))
+ (suppress-keymap map)
+ (define-key map "e" 'find-file-other-frame)
+ (define-key map "f" 'find-file-other-frame)
+ (define-key map "b" 'switch-to-buffer-other-frame)
+ (define-key map "i" 'info)
+ (define-key map "m" 'mail)
+ (define-key map "n" 'make-frame)
+ (define-key map [mouse-1] (lambda () (interactive)
+ (with-current-buffer "*Messages*"
+ (goto-char (point-max))
+ (display-buffer (current-buffer)))))
+ ;; So the global down-mouse-1 binding doesn't clutter the execution of the
+ ;; above mouse-1 binding.
+ (define-key map [down-mouse-1] #'ignore)
+ map)
+ "Keymap for use in the minibuffer when it is not active.
+The non-mouse bindings in this keymap can only be used in minibuffer-only
+frames, since the minibuffer can normally not be selected when it is
+not active.")
+
+(define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer"
+ :abbrev-table nil ;abbrev.el is not loaded yet during dump.
+ ;; Note: this major mode is called from minibuf.c.
+ "Major mode to use in the minibuffer when it is not active.
+This is only used when the minibuffer area has no active minibuffer.")
+
;;; Completion tables.
(defun minibuffer--double-dollars (str)
- (replace-regexp-in-string "\\$" "$$" str))
+ ;; Reuse the actual "$" from the string to preserve any text-property it
+ ;; might have, such as `face'.
+ (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
+ str))
(defun completion--make-envvar-table ()
(mapcar (lambda (enventry)
;; other table that provides the "main" completion. Let the
;; other table handle the test-completion case.
nil)
- ((eq (car-safe action) 'boundaries)
- ;; Only return boundaries if there's something to complete,
+ ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
+ ;; Only return boundaries/metadata if there's something to complete,
;; since otherwise when we're used in
;; completion-table-in-turn, we could return boundaries and
;; let some subsequent table return a list of completions.
(when (try-completion (substring string beg) table nil)
;; Compute the boundaries of the subfield to which this
;; completion applies.
- (let ((suffix (cdr action)))
- (list* 'boundaries
- (or (match-beginning 2) (match-beginning 1))
- (when (string-match "[^[:alnum:]_]" suffix)
- (match-beginning 0))))))
+ (if (eq action 'metadata)
+ '(metadata (category . environment-variable))
+ (let ((suffix (cdr action)))
+ (list* 'boundaries
+ (or (match-beginning 2) (match-beginning 1))
+ (when (string-match "[^[:alnum:]_]" suffix)
+ (match-beginning 0)))))))
(t
(if (eq (aref string (1- beg)) ?{)
(setq table (apply-partially 'completion-table-with-terminator
(defun completion-file-name-table (string pred action)
"Completion table for file names."
- (ignore-errors
- (cond
- ((eq (car-safe action) 'boundaries)
- (let ((start (length (file-name-directory string)))
- (end (string-match-p "/" (cdr action))))
- (list* 'boundaries
- ;; if `string' is "C:" in w32, (file-name-directory string)
- ;; returns "C:/", so `start' is 3 rather than 2.
- ;; Not quite sure what is The Right Fix, but clipping it
- ;; back to 2 will work for this particular case. We'll
- ;; see if we can come up with a better fix when we bump
- ;; into more such problematic cases.
- (min start (length string)) end)))
-
- ((eq action 'lambda)
- (if (zerop (length string))
- nil ;Not sure why it's here, but it probably doesn't harm.
- (funcall (or pred 'file-exists-p) string)))
+ (condition-case nil
+ (cond
+ ((eq action 'metadata) '(metadata (category . file)))
+ ((string-match-p "\\`~[^/\\]*\\'" string)
+ (completion-table-with-context "~"
+ (mapcar (lambda (u) (concat u "/"))
+ (system-users))
+ (substring string 1)
+ pred action))
+ ((eq (car-safe action) 'boundaries)
+ (let ((start (length (file-name-directory string)))
+ (end (string-match-p "/" (cdr action))))
+ (list* 'boundaries
+ ;; if `string' is "C:" in w32, (file-name-directory string)
+ ;; returns "C:/", so `start' is 3 rather than 2.
+ ;; Not quite sure what is The Right Fix, but clipping it
+ ;; back to 2 will work for this particular case. We'll
+ ;; see if we can come up with a better fix when we bump
+ ;; into more such problematic cases.
+ (min start (length string)) end)))
- (t
- (let* ((name (file-name-nondirectory string))
- (specdir (file-name-directory string))
- (realdir (or specdir default-directory)))
+ ((eq action 'lambda)
+ (if (zerop (length string))
+ nil ;Not sure why it's here, but it probably doesn't harm.
+ (funcall (or pred 'file-exists-p) string)))
- (cond
- ((null action)
- (let ((comp (file-name-completion name realdir pred)))
- (if (stringp comp)
- (concat specdir comp)
- comp)))
+ (t
+ (let* ((name (file-name-nondirectory string))
+ (specdir (file-name-directory string))
+ (realdir (or specdir default-directory)))
- ((eq action t)
- (let ((all (file-name-all-completions name realdir)))
-
- ;; Check the predicate, if necessary.
- (unless (memq pred '(nil file-exists-p))
- (let ((comp ())
- (pred
- (if (eq pred 'file-directory-p)
- ;; Brute-force speed up for directory checking:
- ;; Discard strings which don't end in a slash.
- (lambda (s)
- (let ((len (length s)))
- (and (> len 0) (eq (aref s (1- len)) ?/))))
- ;; Must do it the hard (and slow) way.
- pred)))
- (let ((default-directory (expand-file-name realdir)))
- (dolist (tem all)
- (if (funcall pred tem) (push tem comp))))
- (setq all (nreverse comp))))
-
- all))))))))
+ (cond
+ ((null action)
+ (let ((comp (file-name-completion name realdir pred)))
+ (if (stringp comp)
+ (concat specdir comp)
+ comp)))
+
+ ((eq action t)
+ (let ((all (file-name-all-completions name realdir)))
+
+ ;; Check the predicate, if necessary.
+ (unless (memq pred '(nil file-exists-p))
+ (let ((comp ())
+ (pred
+ (if (eq pred 'file-directory-p)
+ ;; Brute-force speed up for directory checking:
+ ;; Discard strings which don't end in a slash.
+ (lambda (s)
+ (let ((len (length s)))
+ (and (> len 0) (eq (aref s (1- len)) ?/))))
+ ;; Must do it the hard (and slow) way.
+ pred)))
+ (let ((default-directory (expand-file-name realdir)))
+ (dolist (tem all)
+ (if (funcall pred tem) (push tem comp))))
+ (setq all (nreverse comp))))
+
+ all))))))
+ (file-error nil))) ;PCM often calls with invalid directories.
(defvar read-file-name-predicate nil
"Current predicate used by `read-file-name-internal'.")
(make-obsolete-variable 'read-file-name-predicate
"use the regular PRED argument" "23.2")
-(defun completion--file-name-table (string pred action)
+(defun completion--sifn-requote (upos qstr)
+ ;; We're looking for `qupos' such that:
+ ;; (equal (substring (substitute-in-file-name qstr) 0 upos)
+ ;; (substitute-in-file-name (substring qstr 0 qupos)))
+ ;; Big problem here: we have to reverse engineer substitute-in-file-name to
+ ;; find the position corresponding to UPOS in QSTR, but
+ ;; substitute-in-file-name can do anything, depending on file-name-handlers.
+ ;; Kind of like in rfn-eshadow-update-overlay, only worse.
+ (let ((qpos 0))
+ ;; Handle substitute-in-file-name's truncation behavior.
+ (let (tpos)
+ (while (and (string-match "[\\/][~/\\]" qstr qpos)
+ ;; Hopefully our regexp covers all truncation cases.
+ ;; Also let's make sure sifn indeed truncates here.
+ (progn
+ (setq tpos (1+ (match-beginning 0)))
+ (equal (substitute-in-file-name qstr)
+ (substitute-in-file-name (substring qstr tpos)))))
+ (setq qpos tpos)))
+ ;; `upos' is relative to the position corresponding to `qpos' in
+ ;; (substitute-in-file-name qstr), so as qpos moves forward, upos
+ ;; gets smaller.
+ (while (and (> upos 0)
+ (string-match "\\$\\(\\$\\|\\([[:alnum:]_]+\\|{[^}]*}\\)\\)?"
+ qstr qpos))
+ (cond
+ ((>= (- (match-beginning 0) qpos) upos) ; UPOS is before current match.
+ (setq qpos (+ qpos upos))
+ (setq upos 0))
+ ((not (match-end 1)) ;A sole $: probably an error.
+ (setq upos (- upos (- (match-end 0) qpos)))
+ (setq qpos (match-end 0)))
+ (t
+ (setq upos (- upos (- (match-beginning 0) qpos)))
+ (setq qpos (match-end 0))
+ (setq upos (- upos (length (substitute-in-file-name
+ (match-string 0 qstr))))))))
+ ;; If `upos' is negative, it's because it's within the expansion of an
+ ;; envvar, i.e. there is no exactly matching qpos, so we just use the next
+ ;; available qpos right after the envvar.
+ (cons (if (>= upos 0) (+ qpos upos) qpos)
+ #'minibuffer--double-dollars)))
+
+(defalias 'completion--file-name-table
+ (completion-table-with-quoting #'completion-file-name-table
+ #'substitute-in-file-name
+ #'completion--sifn-requote)
"Internal subroutine for `read-file-name'. Do not call this.
This is a completion table for file names, like `completion-file-name-table'
-except that it passes the file name through `substitute-in-file-name'."
- (cond
- ((eq (car-safe action) 'boundaries)
- ;; For the boundaries, we can't really delegate to
- ;; substitute-in-file-name+completion-file-name-table and then fix
- ;; them up (as we do for the other actions), because it would
- ;; require us to track the relationship between `str' and
- ;; `string', which is difficult. And in any case, if
- ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba",
- ;; there's no way for us to return proper boundaries info, because
- ;; the boundary is not (yet) in `string'.
- ;;
- ;; FIXME: Actually there is a way to return correct boundaries
- ;; info, at the condition of modifying the all-completions
- ;; return accordingly. But for now, let's not bother.
- (completion-file-name-table string pred action))
-
- (t
- (let* ((default-directory
- (if (stringp pred)
- ;; It used to be that `pred' was abused to pass `dir'
- ;; as an argument.
- (prog1 (file-name-as-directory (expand-file-name pred))
- (setq pred nil))
- default-directory))
- (str (condition-case nil
- (substitute-in-file-name string)
- (error string)))
- (comp (completion-file-name-table
- str
- (with-no-warnings (or pred read-file-name-predicate))
- action)))
-
- (cond
- ((stringp comp)
- ;; Requote the $s before returning the completion.
- (minibuffer--double-dollars comp))
- ((and (null action) comp
- ;; Requote the $s before checking for changes.
- (setq str (minibuffer--double-dollars str))
- (not (string-equal string str)))
- ;; If there's no real completion, but substitute-in-file-name
- ;; changed the string, then return the new string.
- str)
- (t comp))))))
+except that it passes the file name through `substitute-in-file-name'.")
(defalias 'read-file-name-internal
- (completion-table-in-turn 'completion--embedded-envvar-table
- 'completion--file-name-table)
+ (completion-table-in-turn #'completion--embedded-envvar-table
+ #'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
(defvar read-file-name-function 'read-file-name-default
If this command was invoked with the mouse, use a graphical file
dialog if `use-dialog-box' is non-nil, and the window system or X
toolkit in use provides a file dialog box, and DIR is not a
-remote file. For graphical file dialogs, any the special values
-of MUSTMATCH; `confirm' and `confirm-after-completion' are
-treated as equivalent to nil.
+remote file. For graphical file dialogs, any of the special values
+of MUSTMATCH `confirm' and `confirm-after-completion' are
+treated as equivalent to nil. Some graphical file dialogs respect
+a MUSTMATCH value of t, and some do not (or it only has a cosmetic
+effect, and does not actually prevent the user from entering a
+non-existent file).
See also `read-file-name-completion-ignore-case'
and `read-file-name-function'."
+ ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection),
+ ;; then MUSTMATCH is enforced. But with newer Gtk
+ ;; (xg_get_file_with_chooser), it only has a cosmetic effect.
+ ;; The user can still type a non-existent file name.
(funcall (or read-file-name-function #'read-file-name-default)
prompt dir default-filename mustmatch initial predicate))
+(defvar minibuffer-local-filename-syntax
+ (let ((table (make-syntax-table))
+ (punctuation (car (string-to-syntax "."))))
+ ;; Convert all punctuation entries to symbol.
+ (map-char-table (lambda (c syntax)
+ (when (eq (car syntax) punctuation)
+ (modify-syntax-entry c "_" table)))
+ table)
+ (mapc
+ (lambda (c)
+ (modify-syntax-entry c "." table))
+ '(?/ ?: ?\\))
+ table)
+ "Syntax table to be used in minibuffer for reading file name.")
+
+;; minibuffer-completing-file-name is a variable used internally in minibuf.c
+;; to determine whether to use minibuffer-local-filename-completion-map or
+;; minibuffer-local-completion-map. It shouldn't be exported to Elisp.
+;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to
+;; use (eq minibuffer-completion-table #'read-file-name-internal), which is
+;; probably even worse. Maybe We should add some read-file-name-setup-hook
+;; instead, but for now, let's keep this non-obsolete.
+;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get)
+
(defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate)
"Default method for reading file names.
See `read-file-name' for the meaning of the arguments."
(lambda ()
(with-current-buffer
(window-buffer (minibuffer-selected-window))
- (read-file-name--defaults dir initial)))))
+ (read-file-name--defaults dir initial))))
+ (set-syntax-table minibuffer-local-filename-syntax))
(completing-read prompt 'read-file-name-internal
pred mustmatch insdef
'file-name-history default-filename)))
I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas
if nil, it will list all possible commands in *Completions* because none of
the commands start with a \"-\" or a SPC."
+ :version "24.1"
:type 'boolean)
(defun completion-pcm--pattern-trivial-p (pattern)
(defun completion-pcm--string->pattern (string &optional point)
"Split STRING into a pattern.
A pattern is a list where each element is either a string
-or a symbol chosen among `any', `star', `point', `prefix'."
+or a symbol, see `completion-pcm--merge-completions'."
(if (and point (< point (length string)))
(let ((prefix (substring string 0 point))
(suffix (substring string point)))
(case-fold-search completion-ignore-case)
(completion-regexp-list (cons regex completion-regexp-list))
(compl (all-completions
- (concat prefix (if (stringp (car pattern)) (car pattern) ""))
+ (concat prefix
+ (if (stringp (car pattern)) (car pattern) ""))
table pred)))
(if (not (functionp table))
;; The internal functions already obeyed completion-regexp-list.
"Find all completions for STRING at POINT in TABLE, satisfying PRED.
POINT is a position inside STRING.
FILTER is a function applied to the return value, that can be used, e.g. to
-filter out additional entries (because TABLE migth not obey PRED)."
+filter out additional entries (because TABLE might not obey PRED)."
(unless filter (setq filter 'identity))
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(- (length newbeforepoint)
(car newbounds)))))
(dolist (submatch suball)
- (setq all (nconc (mapcar
- (lambda (s) (concat submatch between s))
- (funcall filter
- (completion-pcm--all-completions
- (concat subprefix submatch between)
- pattern table pred)))
- all)))
+ (setq all (nconc
+ (mapcar
+ (lambda (s) (concat submatch between s))
+ (funcall filter
+ (completion-pcm--all-completions
+ (concat subprefix submatch between)
+ pattern table pred)))
+ all)))
;; FIXME: This can come in handy for try-completion,
;; but isn't right for all-completions, since it lists
;; invalid completions.
(mapcar 'completion--sreverse strs))))
(defun completion-pcm--merge-completions (strs pattern)
- "Extract the commonality in STRS, with the help of PATTERN."
+ "Extract the commonality in STRS, with the help of PATTERN.
+PATTERN can contain strings and symbols chosen among `star', `any', `point',
+and `prefix'. They all match anything (aka \".*\") but are merged differently:
+`any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets
+ completed to just \"a\").
+`prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets
+ completed to just \"b\").
+`star' grows from both ends and is reified into a \"*\" (when matching \"a1b\"
+ and \"a2b\" it gets completed to \"a*b\").
+`point' is like `star' except that it gets reified as the position of point
+ instead of being reified as a \"*\" character.
+The underlying idea is that we should return a string which still matches
+the same set of elements."
;; When completing while ignoring case, we want to try and avoid
;; completing "fo" to "foO" when completing against "FOO" (bug#4219).
;; So we try and make sure that the string we return is all made up
(let* ((prefix (try-completion fixed comps))
(unique (or (and (eq prefix t) (setq prefix fixed))
(eq t (try-completion prefix comps)))))
- (unless (equal prefix "") (push prefix res))
+ (unless (or (eq elem 'prefix)
+ (equal prefix ""))
+ (push prefix res))
;; If there's only one completion, `elem' is not useful
;; any more: it can only match the empty string.
;; FIXME: in some cases, it may be necessary to turn an
mergedpat))
;; New pos from the start.
(newpos (length (completion-pcm--pattern->string pointpat)))
- ;; Do it afterwards because it changes `pointpat' by sideeffect.
+ ;; Do it afterwards because it changes `pointpat' by side effect.
(merged (completion-pcm--pattern->string (nreverse mergedpat))))
(setq suffix (completion--merge-suffix merged newpos suffix))
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
-
+\f
+(defvar completing-read-function 'completing-read-default
+ "The function called by `completing-read' to do its work.
+It should accept the same arguments as `completing-read'.")
+
+(defun completing-read-default (prompt collection &optional predicate
+ require-match initial-input
+ hist def inherit-input-method)
+ "Default method for reading from the minibuffer with completion.
+See `completing-read' for the meaning of the arguments."
+
+ (when (consp initial-input)
+ (setq initial-input
+ (cons (car initial-input)
+ ;; `completing-read' uses 0-based index while
+ ;; `read-from-minibuffer' uses 1-based index.
+ (1+ (cdr initial-input)))))
+
+ (let* ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate predicate)
+ (minibuffer-completion-confirm (unless (eq require-match t)
+ require-match))
+ (base-keymap (if require-match
+ minibuffer-local-must-match-map
+ minibuffer-local-completion-map))
+ (keymap (if (memq minibuffer-completing-file-name '(nil lambda))
+ base-keymap
+ ;; Layer minibuffer-local-filename-completion-map
+ ;; on top of the base map.
+ (make-composed-keymap
+ minibuffer-local-filename-completion-map
+ ;; Set base-keymap as the parent, so that nil bindings
+ ;; in minibuffer-local-filename-completion-map can
+ ;; override bindings in base-keymap.
+ base-keymap)))
+ (result (read-from-minibuffer prompt initial-input keymap
+ nil hist def inherit-input-method)))
+ (when (and (equal result "") def)
+ (setq result (if (consp def) (car def) def)))
+ result))
\f
;; Miscellaneous