X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/90207a152538c00b6c75b9774b528470dfb42717..d0efe6ec5bc90a206c194a429e6cdfd86a8fb3d5:/lisp/minibuffer.el diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 1d459b0db6..7fe50e930c 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -51,6 +51,9 @@ ;;; 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. @@ -74,6 +77,9 @@ ;; - 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. @@ -81,7 +87,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) ;;; Completion table manipulation @@ -211,7 +217,7 @@ case sensitive instead." (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)." @@ -224,10 +230,10 @@ 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)) @@ -267,7 +273,7 @@ the form (concat S2 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))) + `(boundaries ,(+ (car bound) len) . ,(cdr bound))) (let ((comp (complete-with-action action table string pred))) (cond ;; In case of try-completion, add the prefix. @@ -300,8 +306,8 @@ instead of a string, a function that takes the completion and returns the (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))) @@ -378,6 +384,8 @@ Note: TABLE needs to be a proper completion table which obeys predicates." ;; 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. @@ -408,7 +416,7 @@ for use at QPOS." (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))) @@ -418,7 +426,7 @@ for use at QPOS." (- (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 @@ -461,23 +469,23 @@ for use at QPOS." (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)) + (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 @@ -488,7 +496,7 @@ for use at QPOS." (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 morecommonprefix suffix ;; - commonprefix newprefix suffix (pcase-let* @@ -505,8 +513,16 @@ for use at QPOS." ((> 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))) (defun completion--twq-all (string ustring completions boundary unquote requote) @@ -519,11 +535,14 @@ for use at QPOS." (`(,qfullpos . ,qfun) (funcall requote (+ boundary (length prefix)) string)) (qfullprefix (substring string 0 qfullpos)) - (_ (assert (let ((uboundarystr (substring ustring 0 boundary))) - (equal (funcall unquote qfullprefix) - (concat uboundarystr prefix))))) + ;; 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 @@ -546,16 +565,20 @@ for use at QPOS." ;; which only get quoted when needed by choose-completion. (nconc (mapcar (lambda (completion) - (assert (string-prefix-p prefix completion)) + (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 - (equal (funcall unquote - (concat (substring string 0 qboundary) - qcompletion)) - (concat (substring ustring 0 boundary) - completion))) + ;; 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)))) @@ -621,6 +644,7 @@ That is what completion commands operate on." (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))) @@ -731,6 +755,7 @@ completing buffer and file names, respectively." (const buffer) (const file) (const unicode-name) + (const bookmark) symbol) :value-type (set :tag "Properties to override" @@ -847,8 +872,8 @@ Depending on this setting `minibuffer-complete' may use cycling, 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) @@ -859,6 +884,7 @@ candidates than this number." (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 @@ -965,7 +991,7 @@ when the buffer's text is already an exact match." ;; 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) @@ -983,9 +1009,9 @@ when the buffer's text is already an exact match." '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 @@ -1030,20 +1056,25 @@ scroll the window of possible completions." ((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 @@ -1075,6 +1106,13 @@ scroll the window of possible completions." (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)))))) @@ -1089,6 +1127,15 @@ scroll the window of possible completions." ;; 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." @@ -1096,7 +1143,7 @@ Repeated uses step through the possible completions." ;; FIXME: Need to deal with the extra-size issue here as well. ;; FIXME: ~/src/emacs/t/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)) @@ -1106,10 +1153,10 @@ Repeated uses step through the possible 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) @@ -1122,10 +1169,27 @@ Repeated uses step through the possible completions." ;; 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.") @@ -1144,6 +1208,22 @@ If `minibuffer-completion-confirm' is `confirm-after-completion', `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 @@ -1191,15 +1271,7 @@ If `minibuffer-completion-confirm' is `confirm-after-completion', (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))) @@ -1294,9 +1366,9 @@ After one word is completed as much as possible, a space or hyphen 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.") @@ -1543,8 +1615,7 @@ variables.") (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 @@ -1715,7 +1786,7 @@ Return nil if there is no valid completion, else t. 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. @@ -1730,7 +1801,10 @@ exit." (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))))) @@ -1754,12 +1828,12 @@ exit." (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))) @@ -1782,7 +1856,7 @@ the mode if ARG is omitted or nil." (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) @@ -1809,7 +1883,9 @@ Currently supported properties are all the properties that can appear in `: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. @@ -1825,10 +1901,10 @@ a completion function or god knows what else.") ;; 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))) @@ -1862,17 +1938,19 @@ The completion method is determined by `completion-at-point-functions'." (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. @@ -1884,32 +1962,34 @@ The completion method is determined by `completion-at-point-functions'." (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. @@ -1946,10 +2026,10 @@ The completion method is determined by `completion-at-point-functions'." Gets combined either with `minibuffer-local-completion-map' or with `minibuffer-local-must-match-map'.") -(defvar minibuffer-local-filename-must-match-map (make-sparse-keymap)) -(make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1") (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) @@ -1998,6 +2078,8 @@ This is only used when the minibuffer area has no active minibuffer.") 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:]_]*\\|{\\([^}]*\\)\\)\\'")) @@ -2034,10 +2116,10 @@ same as `substitute-in-file-name'." (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 @@ -2062,14 +2144,14 @@ same as `substitute-in-file-name'." ((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)) @@ -2117,27 +2199,49 @@ same as `substitute-in-file-name'." "use the regular PRED argument" "23.2") (defun completion--sifn-requote (upos qstr) - (let ((qpos 0)) - (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))) + ;; We're looking for `qpos' such that: + ;; (equal (substring (substitute-in-file-name qstr) 0 upos) + ;; (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. + ;; 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 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 @@ -2221,14 +2325,24 @@ such as making the current buffer visit no file in the case of (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. @@ -2245,10 +2359,10 @@ Fourth arg MUSTMATCH can take the following values: 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 @@ -2282,7 +2396,7 @@ and `read-file-name-function'." (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 @@ -2625,7 +2739,7 @@ or a symbol, see `completion-pcm--merge-completions'." (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. @@ -2650,7 +2764,7 @@ or a symbol, see `completion-pcm--merge-completions'." (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) @@ -2724,9 +2838,9 @@ filter out additional entries (because TABLE might not obey PRED)." ;; 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. @@ -2790,22 +2904,22 @@ filter out additional entries (because TABLE might not obey PRED)." (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. @@ -2890,7 +3004,7 @@ the same set of elements." ;; `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 ""))))) @@ -2954,11 +3068,11 @@ the same set of elements." (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 @@ -2979,15 +3093,17 @@ the same set of elements." (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)))))