;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2013 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Package: emacs
;;; Todo:
+;; - Make *Completions* readable even if some of the completion
+;; entries have LF chars or spaces in them (including at
+;; beginning/end) or are very long.
;; - 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.
;; - whether the user wants completion to pay attention to case.
;; e.g. we may want to make it possible for the user to say "first try
;; completion case-sensitively, and if that fails, try to ignore case".
+;; Maybe the trick is that we should distinguish completion-ignore-case in
+;; try/all-completions (obey user's preference) from its use in
+;; test-completion (obey the underlying object's semantics).
;; - add support for ** to pcm.
;; - Add vc-file-name-completion-table to read-file-name-internal.
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
;;; Completion table manipulation
(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.
+ "Return a completion table from TABLE with S1 replaced by S2.
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)."
(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)))))
+ `(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))
(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)))
+ `(boundaries ,(+ (car bound) len) . ,(cdr bound)))
(let ((comp (complete-with-action action table string pred)))
(cond
;; In case of try-completion, add the prefix.
(cdr terminator) (regexp-quote terminator)))
(max (and terminator-regexp
(string-match terminator-regexp suffix))))
- (list* 'boundaries (car bounds)
- (min (cdr bounds) (or max (length suffix))))))
+ `(boundaries ,(car bounds)
+ . ,(min (cdr bounds) (or max (length suffix))))))
((eq action nil)
(let ((comp (try-completion string table pred)))
(if (consp terminator) (setq terminator (car terminator)))
;; 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.
+ ;; FIXME: For some forms of "quoting" such as the truncation behavior of
+ ;; substitute-in-file-name, it would be desirable not to requote completely.
"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.
(qsuffix (cdr action))
(ufull (if (zerop (length qsuffix)) ustring
(funcall unquote (concat string qsuffix))))
- (_ (assert (string-prefix-p ustring ufull)))
+ (_ (cl-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)))
(- (car (funcall requote urfullboundary
(concat string qsuffix)))
(length string))))))
- (list* 'boundaries qlboundary qrboundary)))
+ `(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
(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))
+ (cl-assert (string-prefix-p uprefix ustring))
(list ustring table (length uprefix)
(lambda (unquoted-result op)
(pcase op
- (`1 ;;try
+ (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
+ (2 ;;all
(let* ((last (last unquoted-result))
(base (or (cdr last) 0)))
(when last
(defun completion--twq-try (string ustring completion point
unquote requote)
- ;; Basically two case: either the new result is
+ ;; Basically two cases: either the new result is
;; - commonprefix1 <point> morecommonprefix <qpos> suffix
;; - commonprefix <qpos> newprefix <point> suffix
(pcase-let*
((> 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)))
+ (if (equal (funcall unquote qstring) completion)
+ (cons qstring qpoint)
+ ;; If requote failed (e.g. because sifn-requote did not handle
+ ;; Tramp's "/foo:/bar//baz -> /foo:/baz" truncation), then at least
+ ;; try requote properly.
+ (let ((qstr (funcall qfun completion)))
+ (cons qstr (length qstr))))))
(defun completion--string-equal-p (s1 s2)
(eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
(`(,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))
+ ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where
+ ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/".
+ ;;(cl-assert (completion--string-equal-p
+ ;; (funcall unquote qfullprefix)
+ ;; (concat (substring ustring 0 boundary) prefix))
+ ;; t))
(qboundary (car (funcall requote boundary string)))
- (_ (assert (<= qboundary qfullpos)))
+ (_ (cl-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
;; which only get quoted when needed by choose-completion.
(nconc
(mapcar (lambda (completion)
- (assert (string-prefix-p prefix completion 'ignore-case) t)
+ (cl-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)
+ ;; FIXME: Similarly here, Cygwin's mapping trips this
+ ;; assertion.
+ ;;(cl-assert
+ ;; (completion--string-equal-p
+ ;; (funcall unquote
+ ;; (concat (substring string 0 qboundary)
+ ;; qcompletion))
+ ;; (concat (substring ustring 0 boundary)
+ ;; completion))
+ ;; t)
qcompletion))
completions)
qboundary))))
(defun delete-minibuffer-contents ()
"Delete all user input in a minibuffer.
If the current buffer is not a minibuffer, erase its entire contents."
+ (interactive)
;; We used to do `delete-field' here, but when file name shadowing
;; is on, the field doesn't cover the entire minibuffer contents.
(delete-region (minibuffer-prompt-end) (point-max)))
(const buffer)
(const file)
(const unicode-name)
+ (const bookmark)
symbol)
:value-type
(set :tag "Properties to override"
like `minibuffer-force-complete'.
If nil, cycling is never used.
If t, cycling is always used.
-If an integer, cycling is used as soon as there are fewer completion
-candidates than this number."
+If an integer, cycling is used so long as there are not more
+completion candidates than this number."
:version "24.1"
:type completion--cycling-threshold-type)
(defvar completion-all-sorted-completions nil)
(make-variable-buffer-local 'completion-all-sorted-completions)
+(defvar-local completion--all-sorted-completions-location nil)
(defvar completion-cycling nil)
(defvar completion-fail-discreetly nil
;; This signal an (intended) error if comps is too
;; short or if completion-cycle-threshold is t.
(consp (nthcdr threshold comps)))))
- ;; Fewer than completion-cycle-threshold remaining
+ ;; Not more than completion-cycle-threshold remaining
;; completions: let's cycle.
(setq completed t exact t)
(completion--cache-all-sorted-completions comps)
'exact 'unknown))))
;; Show the completion table, if requested.
((not exact)
- (if (case completion-auto-help
- (lazy (eq this-command last-command))
- (t completion-auto-help))
+ (if (pcase completion-auto-help
+ (`lazy (eq this-command last-command))
+ (_ completion-auto-help))
(minibuffer-completion-help)
(completion--message "Next char not unique")))
;; If the last exact completion and this one were the same, it
((and completion-cycling completion-all-sorted-completions)
(minibuffer-force-complete)
t)
- (t (case (completion--do-completion)
+ (t (pcase (completion--do-completion)
(#b000 nil)
- (t t)))))
+ (_ t)))))
(defun completion--cache-all-sorted-completions (comps)
(add-hook 'after-change-functions
- 'completion--flush-all-sorted-completions nil t)
+ 'completion--flush-all-sorted-completions nil t)
+ (setq completion--all-sorted-completions-location
+ (cons (copy-marker (field-beginning)) (copy-marker (field-end))))
(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--flush-all-sorted-completions (&optional start end _len)
+ (unless (and start end
+ (or (> start (cdr completion--all-sorted-completions-location))
+ (< end (car completion--all-sorted-completions-location))))
+ (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
(sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
(when last
(setcdr last nil)
+
+ ;; Delete duplicates: do it after setting last's cdr to nil (so
+ ;; it's a proper list), and be careful to reset `last' since it
+ ;; may be a different cons-cell.
+ (setq all (delete-dups all))
+ (setq last (last all))
+
(setq all (if sort-fun (funcall sort-fun all)
;; Prefer shorter completions, by default.
(sort all (lambda (c1 c2) (< (length c1) (length c2))))))
;; all possibilities.
(completion--cache-all-sorted-completions (nconc all base-size))))))
+(defun minibuffer-force-complete-and-exit ()
+ "Complete the minibuffer with first of the matches and exit."
+ (interactive)
+ (minibuffer-force-complete)
+ (minibuffer--complete-and-exit
+ ;; If the previous completion completed to an element which fails
+ ;; test-completion, then we shouldn't exit, but that should be rare.
+ (lambda () (minibuffer-message "Incomplete"))))
+
(defun minibuffer-force-complete ()
"Complete the minibuffer to an exact match.
Repeated uses step through the possible completions."
;; FIXME: Need to deal with the extra-size issue here as well.
;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
- (let* ((start (field-beginning))
+ (let* ((start (copy-marker (field-beginning)))
(end (field-end))
;; (md (completion--field-metadata start))
(all (completion-all-sorted-completions))
(completion--message
(if all "No more completions" "No completions")))
((not (consp (cdr all)))
- (let ((mod (equal (car all) (buffer-substring-no-properties base end))))
- (if mod (completion--replace base end (car all)))
+ (let ((done (equal (car all) (buffer-substring-no-properties base end))))
+ (unless done (completion--replace base end (car all)))
(completion--done (buffer-substring-no-properties start (point))
- 'finished (unless mod "Sole completion"))))
+ 'finished (when done "Sole completion"))))
(t
(completion--replace base end (car all))
(completion--done (buffer-substring-no-properties start (point)) 'sole)
;; through the previous possible completions.
(let ((last (last all)))
(setcdr last (cons (car all) (cdr last)))
- (completion--cache-all-sorted-completions (cdr all)))))))
+ (completion--cache-all-sorted-completions (cdr all)))
+ ;; Make sure repeated uses cycle, even though completion--done might
+ ;; have added a space or something that moved us outside of the field.
+ ;; (bug#12221).
+ (let* ((table minibuffer-completion-table)
+ (pred minibuffer-completion-predicate)
+ (extra-prop completion-extra-properties)
+ (cmd
+ (lambda () "Cycle through the possible completions."
+ (interactive)
+ (let ((completion-extra-properties extra-prop))
+ (completion-in-region start (point) table pred)))))
+ (set-temporary-overlay-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [remap completion-at-point] cmd)
+ (define-key map (vector last-command-event) cmd)
+ map)))))))
(defvar minibuffer-confirm-exit-commands
- '(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word)
+ '(completion-at-point minibuffer-complete
+ minibuffer-complete-word PC-complete PC-complete-word)
"A list of commands which cause an immediately following
`minibuffer-complete-and-exit' to ask for extra confirmation.")
`minibuffer-confirm-exit-commands', and accept the input
otherwise."
(interactive)
+ (minibuffer--complete-and-exit
+ (lambda ()
+ (pcase (condition-case nil
+ (completion--do-completion nil 'expect-exact)
+ (error 1))
+ ((or #b001 #b011) (exit-minibuffer))
+ (#b111 (if (not minibuffer-completion-confirm)
+ (exit-minibuffer)
+ (minibuffer-message "Confirm")
+ nil))
+ (_ nil)))))
+
+(defun minibuffer--complete-and-exit (completion-function)
+ "Exit from `require-match' minibuffer.
+COMPLETION-FUNCTION is called if the current buffer's content does not
+appear to be a match."
(let ((beg (field-beginning))
(end (field-end)))
(cond
(t
;; Call do-completion, but ignore errors.
- (case (condition-case nil
- (completion--do-completion nil 'expect-exact)
- (error 1))
- ((#b001 #b011) (exit-minibuffer))
- (#b111 (if (not minibuffer-completion-confirm)
- (exit-minibuffer)
- (minibuffer-message "Confirm")
- nil))
- (t nil))))))
+ (funcall completion-function)))))
(defun completion--try-word-completion (string table predicate point md)
(let ((comp (completion-try-completion string table predicate point md)))
is added, provided that matches some possible completion.
Return nil if there is no valid completion, else t."
(interactive)
- (case (completion--do-completion 'completion--try-word-completion)
+ (pcase (completion--do-completion 'completion--try-word-completion)
(#b000 nil)
- (t t)))
+ (_ t)))
(defface completions-annotations '((t :inherit italic))
"Face to use for annotations in the *Completions* buffer.")
(defun completion--done (string &optional finished message)
(let* ((exit-fun (plist-get completion-extra-properties :exit-function))
(pre-msg (and exit-fun (current-message))))
- (assert (memq finished '(exact sole finished unknown)))
- ;; FIXME: exit-fun should receive `finished' as a parameter.
+ (cl-assert (memq finished '(exact sole finished unknown)))
(when exit-fun
(when (eq finished 'unknown)
(setq finished
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))
+ (cl-assert (<= start (point)) (<= (point) end))
(with-wrapper-hook
;; FIXME: Maybe we should use this hook to provide a "display
;; completions" operation as well.
(when completion-in-region-mode-predicate
(completion-in-region-mode 1)
(setq completion-in-region--data
- (list (current-buffer) start end collection)))
+ (list (if (markerp start) start (copy-marker start))
+ (copy-marker end) collection)))
+ ;; FIXME: `minibuffer-complete' should call `completion-in-region' rather
+ ;; than the other way around!
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
(or unread-command-events ;Don't pop down the completions in the middle of
;mouse-drag-region/mouse-set-point.
(and completion-in-region--data
- (and (eq (car completion-in-region--data)
+ (and (eq (marker-buffer (nth 0 completion-in-region--data))
(current-buffer))
- (>= (point) (nth 1 completion-in-region--data))
+ (>= (point) (nth 0 completion-in-region--data))
(<= (point)
(save-excursion
- (goto-char (nth 2 completion-in-region--data))
+ (goto-char (nth 1 completion-in-region--data))
(line-end-position)))
(funcall completion-in-region-mode--predicate)))
(completion-in-region-mode -1)))
(unless (equal "*Completions*" (buffer-name (window-buffer)))
(minibuffer-hide-completions))
;; (add-hook 'pre-command-hook #'completion-in-region--prech)
- (assert completion-in-region-mode-predicate)
+ (cl-assert completion-in-region-mode-predicate)
(setq completion-in-region-mode--predicate
completion-in-region-mode-predicate)
(add-hook 'post-command-hook #'completion-in-region--postch)
`:predicate' a predicate that completion candidates need to satisfy.
`: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.")
+ failure, the completion should try the next completion function.
+As is the case with most hooks, the functions are responsible to preserve
+things like point and current buffer.")
(defvar completion--capf-misbehave-funs nil
"List of functions found on `completion-at-point-functions' that misbehave.
;; always return the same kind of data, but this breaks down with functions
;; like comint-completion-at-point or mh-letter-completion-at-point, which
;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
- (if (case which
- (all t)
- (safe (member fun completion--capf-safe-funs))
- (optimist (not (member fun completion--capf-misbehave-funs))))
+ (if (pcase which
+ (`all t)
+ (`safe (member fun completion--capf-safe-funs))
+ (`optimist (not (member fun completion--capf-misbehave-funs))))
(let ((res (funcall fun)))
(cond
((and (consp res) (not (functionp res)))
(let ((res (run-hook-wrapped 'completion-at-point-functions
#'completion--capf-wrapper 'all)))
(pcase res
- (`(,_ . ,(and (pred functionp) f)) (funcall f))
- (`(,hookfun . (,start ,end ,collection . ,plist))
- (let* ((completion-extra-properties plist)
- (completion-in-region-mode-predicate
- (lambda ()
- ;; We're still in the same completion field.
- (eq (car-safe (funcall hookfun)) start))))
- (completion-in-region start end collection
- (plist-get plist :predicate))))
- ;; Maybe completion already happened and the function returned t.
- (_ (cdr res)))))
+ (`(,_ . ,(and (pred functionp) f)) (funcall f))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (unless (markerp start) (setq start (copy-marker start)))
+ (let* ((completion-extra-properties plist)
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (let ((newstart (car-safe (funcall hookfun))))
+ (and newstart (= newstart start))))))
+ (completion-in-region start end collection
+ (plist-get plist :predicate))))
+ ;; Maybe completion already happened and the function returned t.
+ (_ (cdr res)))))
(defun completion-help-at-point ()
"Display the completions on the text around point.
(pcase res
(`(,_ . ,(and (pred functionp) f))
(message "Don't know how to show completions for %S" f))
- (`(,hookfun . (,start ,end ,collection . ,plist))
- (let* ((minibuffer-completion-table collection)
- (minibuffer-completion-predicate (plist-get plist :predicate))
- (completion-extra-properties plist)
- (completion-in-region-mode-predicate
- (lambda ()
- ;; We're still in the same completion field.
- (eq (car-safe (funcall hookfun)) start)))
- (ol (make-overlay start end nil nil t)))
- ;; FIXME: We should somehow (ab)use completion-in-region-function or
- ;; 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))
- (unwind-protect
- (call-interactively 'minibuffer-completion-help)
- (delete-overlay ol))))
- (`(,hookfun . ,_)
- ;; The hook function already performed completion :-(
- ;; Not much we can do at this point.
- (message "%s already performed completion!" hookfun)
- nil)
- (_ (message "Nothing to complete at point")))))
+ (`(,hookfun . (,start ,end ,collection . ,plist))
+ (unless (markerp start) (setq start (copy-marker start)))
+ (let* ((minibuffer-completion-table collection)
+ (minibuffer-completion-predicate (plist-get plist :predicate))
+ (completion-extra-properties plist)
+ (completion-in-region-mode-predicate
+ (lambda ()
+ ;; We're still in the same completion field.
+ (let ((newstart (car-safe (funcall hookfun))))
+ (and newstart (= newstart start)))))
+ (ol (make-overlay start end nil nil t)))
+ ;; FIXME: We should somehow (ab)use completion-in-region-function or
+ ;; 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 start (copy-marker end) collection))
+ (unwind-protect
+ (call-interactively 'minibuffer-completion-help)
+ (delete-overlay ol))))
+ (`(,hookfun . ,_)
+ ;; The hook function already performed completion :-(
+ ;; Not much we can do at this point.
+ (message "%s already performed completion!" hookfun)
+ nil)
+ (_ (message "Nothing to complete at point")))))
;;; Key bindings.
(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)))))
+ (define-key map [mouse-1] 'view-echo-area-messages)
;; 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)
process-environment))
(defconst completion--embedded-envvar-re
+ ;; We can't reuse env--substitute-vars-regexp because we need to match only
+ ;; potentially-unfinished envvars at end of string.
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
"$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
(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)))))))
+ `(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
((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)))
+ `(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))
"use the regular PRED argument" "23.2")
(defun completion--sifn-requote (upos qstr)
- ;; We're looking for `qupos' such that:
+ ;; We're looking for `qpos' such that:
;; (equal (substring (substitute-in-file-name qstr) 0 upos)
- ;; (substitute-in-file-name (substring qstr 0 qupos)))
+ ;; (substitute-in-file-name (substring qstr 0 qpos)))
;; 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.
+ ;; substitute-in-file-name does the following kind of things:
+ ;; - expand env-var references.
+ ;; - turn backslashes into slashes.
+ ;; - truncate some prefix of the input.
+ ;; - rewrite some prefix.
+ ;; Some of these operations are written in external libraries and we'd rather
+ ;; not hard code any assumptions here about what they actually do. IOW, we
+ ;; want to treat substitute-in-file-name as a black box, as much as possible.
;; 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.
+ ;; Example of things we need to handle:
+ ;; - Tramp (substitute-in-file-name "/foo:~/bar//baz") => "/scpc:foo:/baz".
+ ;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin"
+ ;; (substitute-in-file-name "C:\") => "/"
+ ;; (substitute-in-file-name "C:\bi") => "/bi"
+ (let* ((ustr (substitute-in-file-name qstr))
+ (uprefix (substring ustr 0 upos))
+ qprefix)
+ ;; Main assumption: nothing after qpos should affect the text before upos,
+ ;; so we can work our way backward from the end of qstr, one character
+ ;; at a time.
+ ;; Second assumptions: If qpos is far from the end this can be a bit slow,
+ ;; so we speed it up by doing a first loop that skips a word at a time.
+ ;; This word-sized loop is careful not to cut in the middle of env-vars.
+ (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr)))
+ (and boundary
(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)))
+ (setq qprefix (substring qstr 0 boundary))
+ (string-prefix-p uprefix
+ (substitute-in-file-name qprefix)))))
+ (setq qstr qprefix))
+ (let ((qpos (length qstr)))
+ (while (and (> qpos 0)
+ (string-prefix-p uprefix
+ (substitute-in-file-name
+ (substring qstr 0 (1- qpos)))))
+ (setq qpos (1- qpos)))
+ (cons qpos #'minibuffer--double-dollars))))
(defalias 'completion--file-name-table
(completion-table-with-quoting #'completion-file-name-table
(defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
"Read file name, prompting with PROMPT and completing in directory DIR.
Value is not expanded---you must call `expand-file-name' yourself.
-Default name to DEFAULT-FILENAME if user exits the minibuffer with
-the same non-empty string that was inserted by this function.
- (If DEFAULT-FILENAME is omitted, the visited file name is used,
- except that if INITIAL is specified, that combined with DIR is used.
- If DEFAULT-FILENAME is a list of file names, the first file name is used.)
-If the user exits with an empty minibuffer, this function returns
-an empty string. (This can only happen if the user erased the
-pre-inserted contents or if `insert-default-directory' is nil.)
+
+DIR is the directory to use for completing relative file names.
+It should be an absolute directory name, or nil (which means the
+current buffer's value of `default-directory').
+
+DEFAULT-FILENAME specifies the default file name to return if the
+user exits the minibuffer with the same non-empty string inserted
+by this function. If DEFAULT-FILENAME is a string, that serves
+as the default. If DEFAULT-FILENAME is a list of strings, the
+first string is the default. If DEFAULT-FILENAME is omitted or
+nil, then if INITIAL is non-nil, the default is DIR combined with
+INITIAL; otherwise, if the current buffer is visiting a file,
+that file serves as the default; otherwise, the default is simply
+the string inserted into the minibuffer.
+
+If the user exits with an empty minibuffer, return an empty
+string. (This happens only if the user erases the pre-inserted
+contents, or if `insert-default-directory' is nil.)
Fourth arg MUSTMATCH can take the following values:
- nil means that the user can exit with any input.
Fifth arg INITIAL specifies text to start with.
-If optional sixth arg PREDICATE is non-nil, possible completions and
-the resulting file name must satisfy (funcall PREDICATE NAME).
-DIR should be an absolute directory name. It defaults to the value of
-`default-directory'.
+Sixth arg PREDICATE, if non-nil, should be a function of one
+argument; then a file name is considered an acceptable completion
+alternative only if PREDICATE returns non-nil with the file name
+as its argument.
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
(modify-syntax-entry c "." table))
'(?/ ?: ?\\))
table)
- "Syntax table to be used in minibuffer for reading file name.")
+ "Syntax table used when reading a file name in the minibuffer.")
;; minibuffer-completing-file-name is a variable used internally in minibuf.c
;; to determine whether to use minibuffer-local-filename-completion-map or
(setq p0 (1+ p)))
(push 'any pattern)
(setq p0 p))
- (incf p))
+ (cl-incf p))
;; An empty string might be erroneously added at the beginning.
;; It should be avoided properly, but it's so easy to remove it here.
(defun completion-pcm--all-completions (prefix pattern table pred)
"Find all completions for PATTERN in TABLE obeying PRED.
PATTERN is as returned by `completion-pcm--string->pattern'."
- ;; (assert (= (car (completion-boundaries prefix table pred ""))
+ ;; (cl-assert (= (car (completion-boundaries prefix table pred ""))
;; (length prefix)))
;; Find an initial list of possible completions.
(if (completion-pcm--pattern-trivial-p pattern)
;; The prefix has no completions at all, so we should try and fix
;; that first.
(let ((substring (substring prefix 0 -1)))
- (destructuring-bind (subpat suball subprefix _subsuffix)
- (completion-pcm--find-all-completions
- substring table pred (length substring) filter)
+ (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix)
+ (completion-pcm--find-all-completions
+ substring table pred (length substring) filter)))
(let ((sep (aref prefix (1- (length prefix))))
;; Text that goes between the new submatches and the
;; completion substring.
(list pattern all prefix suffix)))))
(defun completion-pcm-all-completions (string table pred point)
- (destructuring-bind (pattern all &optional prefix _suffix)
- (completion-pcm--find-all-completions string table pred point)
+ (pcase-let ((`(,pattern ,all ,prefix ,_suffix)
+ (completion-pcm--find-all-completions string table pred point)))
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))
(defun completion--sreverse (str)
"Like `reverse' but for a string STR rather than a list."
- (apply 'string (nreverse (mapcar 'identity str))))
+ (apply #'string (nreverse (mapcar 'identity str))))
(defun completion--common-suffix (strs)
"Return the common suffix of the strings STRS."
(completion--sreverse
(try-completion
""
- (mapcar 'completion--sreverse strs))))
+ (mapcar #'completion--sreverse strs))))
(defun completion-pcm--merge-completions (strs pattern)
"Extract the commonality in STRS, with the help of PATTERN.
;; `any' it could lead to a merged completion that
;; doesn't itself match the candidates.
(let ((suffix (completion--common-suffix comps)))
- (assert (stringp suffix))
+ (cl-assert (stringp suffix))
(unless (equal suffix "")
(push suffix res)))))
(setq fixed "")))))
(cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
- (destructuring-bind (pattern all prefix suffix)
- (completion-pcm--find-all-completions
- string table pred point
- (if minibuffer-completing-file-name
- 'completion-pcm--filename-try-filter))
+ (pcase-let ((`(,pattern ,all ,prefix ,suffix)
+ (completion-pcm--find-all-completions
+ string table pred point
+ (if minibuffer-completing-file-name
+ 'completion-pcm--filename-try-filter))))
(completion-pcm--merge-try pattern all prefix suffix)))
;;; Substring completion
(list all pattern prefix suffix (car bounds))))
(defun completion-substring-try-completion (string table pred point)
- (destructuring-bind (all pattern prefix suffix _carbounds)
- (completion-substring--all-completions string table pred point)
+ (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point)))
(if minibuffer-completing-file-name
(setq all (completion-pcm--filename-try-filter all)))
(completion-pcm--merge-try pattern all prefix suffix)))
(defun completion-substring-all-completions (string table pred point)
- (destructuring-bind (all pattern prefix _suffix _carbounds)
- (completion-substring--all-completions string table pred point)
+ (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
+ (completion-substring--all-completions
+ string table pred point)))
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
(length prefix)))))