-;;; minibuffer.el --- Minibuffer completion functions
+;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
-;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2011 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
+;; Package: emacs
;; This file is part of GNU Emacs.
;; provide the start info but not the end info in
;; completion-base-position.
;; - quoting is problematic. E.g. the double-dollar quoting used in
-;; substitie-in-file-name (and hence read-file-name-internal) bumps
+;; 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
The result of the `completion-table-dynamic' form is a function
that can be used as the COLLECTION argument to `try-completion' and
`all-completions'. See Info node `(elisp)Programmed Completion'."
- (lexical-let ((fun fun))
- (lambda (string pred action)
+ (lambda (string pred action)
+ (if (eq (car-safe action) 'boundaries)
+ ;; `fun' is not supposed to return another function but a plain old
+ ;; completion table, whose boundaries are always trivial.
+ nil
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
(setq ,var (,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-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
- (lexical-let ((pred 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)))))))))
+ ;; 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))))
number 1 should match TERMINATOR. This is used when there is a need to
distinguish occurrences of the TERMINATOR strings which are really terminators
from others (e.g. escaped)."
+ ;; FIXME: This implementation is not right since it only adds the terminator
+ ;; in try-completion, so any completion-style that builds the completion via
+ ;; all-completions won't get the terminator, and selecting an entry in
+ ;; *Completions* won't get the terminator added either.
(cond
((eq (car-safe action) 'boundaries)
(let* ((suffix (cdr action))
(t
(or (complete-with-action action table string
(if (null pred2) pred1
- (lexical-let ((pred1 pred2) (pred2 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))))))
+ (lambda (x)
+ ;; Call `pred1' first, so that `pred2'
+ ;; really can't tell that `x' is in table.
+ (if (funcall pred1 x) (funcall pred2 x)))))
;; If completion failed and we're not applying pred1 strictly, try
;; again without pred1.
(and (not strict)
"Create a completion table that tries each table in TABLES in turn."
;; FIXME: the boundaries may come from TABLE1 even when the completion list
;; is returned by TABLE2 (because TABLE1 returned an empty list).
- (lexical-let ((tables tables))
- (lambda (string pred action)
- (completion--some (lambda (table)
- (complete-with-action action table string pred))
- tables))))
+ (lambda (string pred action)
+ (completion--some (lambda (table)
+ (complete-with-action action table string pred))
+ tables)))
;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
(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."
- ;; This should be in subr.el.
+ ;; 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
;; after-change-functions that may themselves modify the buffer.
- (goto-char beg)
- (insert newtext)
- (delete-region (point) (+ (point) (- end beg))))
+ (let ((prefix-len 0))
+ ;; Don't touch markers in the shared prefix (if any).
+ (while (and (< prefix-len (length newtext))
+ (< (+ beg prefix-len) end)
+ (eq (char-after (+ beg prefix-len))
+ (aref newtext prefix-len)))
+ (setq prefix-len (1+ prefix-len)))
+ (unless (zerop prefix-len)
+ (setq beg (+ beg prefix-len))
+ (setq newtext (substring newtext prefix-len))))
+ (let ((suffix-len 0))
+ ;; Don't touch markers in the shared suffix (if any).
+ (while (and (< suffix-len (length newtext))
+ (< beg (- end suffix-len))
+ (eq (char-before (- end suffix-len))
+ (aref newtext (- (length newtext) suffix-len 1))))
+ (setq suffix-len (1+ suffix-len)))
+ (unless (zerop suffix-len)
+ (setq end (- end suffix-len))
+ (setq newtext (substring newtext 0 (- suffix-len))))
+ (goto-char beg)
+ (insert newtext)
+ (delete-region (point) (+ (point) (- end beg)))
+ (forward-char suffix-len)))
(defcustom completion-cycle-threshold nil
"Number of completion candidates below which cycling is used.
(const :tag "Always cycle" t)
(integer :tag "Threshold")))
+(defvar completion-all-sorted-completions nil)
+(make-variable-buffer-local 'completion-all-sorted-completions)
+(defvar completion-cycling nil)
+
+(defvar completion-fail-discreetly nil
+ "If non-nil, stay quiet when there is no match.")
+
(defun completion--do-completion (&optional try-completion-function)
"Do the completion and return a summary of what happened.
M = completion was performed, the text was Modified.
(end (field-end))
(string (buffer-substring beg end))
(comp (funcall (or try-completion-function
- 'completion-try-completion)
- string
- minibuffer-completion-table
- minibuffer-completion-predicate
- (- (point) beg))))
+ 'completion-try-completion)
+ string
+ minibuffer-completion-table
+ minibuffer-completion-predicate
+ (- (point) beg))))
(cond
((null comp)
(minibuffer-hide-completions)
- (ding) (minibuffer-message "No match") (minibuffer--bitset nil nil nil))
+ (unless completion-fail-discreetly
+ (ding) (minibuffer-message "No match"))
+ (minibuffer--bitset nil nil nil))
((eq t comp)
(minibuffer-hide-completions)
(goto-char (field-end))
- (minibuffer--bitset nil nil t)) ;Exact and unique match.
+ (minibuffer--bitset nil nil t)) ;Exact and unique match.
(t
;; `completed' should be t if some completion was done, which doesn't
;; include simply changing the case of the entered string. However,
;; for appearance, the string is rewritten if the case changes.
(let* ((comp-pos (cdr comp))
- (completion (car comp))
- (completed (not (eq t (compare-strings completion nil nil
- string nil nil t))))
- (unchanged (eq t (compare-strings completion nil nil
- string nil nil nil))))
+ (completion (car comp))
+ (completed (not (eq t (compare-strings completion nil nil
+ string nil nil t))))
+ (unchanged (eq t (compare-strings completion nil nil
+ string nil nil nil))))
(if unchanged
- (goto-char end)
+ (goto-char end)
;; Insert in minibuffer the chars we got.
(completion--replace beg end completion))
;; Move point to its completion-mandated destination.
(forward-char (- comp-pos (length completion)))
(if (not (or unchanged completed))
- ;; The case of the string changed, but that's all. We're not sure
- ;; whether this is a unique completion or not, so try again using
- ;; the real case (this shouldn't recurse again, because the next
- ;; time try-completion will return either t or the exact string).
- (completion--do-completion try-completion-function)
+ ;; The case of the string changed, but that's all. We're not sure
+ ;; whether this is a unique completion or not, so try again using
+ ;; the real case (this shouldn't recurse again, because the next
+ ;; time try-completion will return either t or the exact string).
+ (completion--do-completion try-completion-function)
;; It did find a match. Do we match some possibility exactly now?
(let ((exact (test-completion completion
""))
comp-pos)))
(completion-all-sorted-completions))))
- (setq completion-all-sorted-completions nil)
+ (completion--flush-all-sorted-completions)
(cond
- ((and (not (ignore-errors
+ ((and (consp (cdr comps)) ;; There's something to cycle.
+ (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))))
- ;; More than 1, so there's something to cycle.
- (consp (cdr comps)))
+ (consp (nthcdr completion-cycle-threshold comps)))))
;; Fewer than completion-cycle-threshold remaining
;; completions: let's cycle.
(setq completed t exact t)
(setq completion-all-sorted-completions comps)
(minibuffer-force-complete))
(completed
- ;; We could also decide to refresh the completions,
- ;; if they're displayed (and assuming there are
- ;; completions left).
+ ;; We could also decide to refresh the completions,
+ ;; if they're displayed (and assuming there are
+ ;; completions left).
(minibuffer-hide-completions))
- ;; Show the completion table, if requested.
- ((not exact)
- (if (case completion-auto-help
- (lazy (eq this-command last-command))
- (t completion-auto-help))
- (minibuffer-completion-help)
- (minibuffer-message "Next char not unique")))
- ;; If the last exact completion and this one were the same, it
- ;; means we've already given a "Next char not unique" message
- ;; and the user's hit TAB again, so now we give him help.
- ((eq this-command last-command)
+ ;; Show the completion table, if requested.
+ ((not exact)
+ (if (case completion-auto-help
+ (lazy (eq this-command last-command))
+ (t completion-auto-help))
+ (minibuffer-completion-help)
+ (minibuffer-message "Next char not unique")))
+ ;; If the last exact completion and this one were the same, it
+ ;; means we've already given a "Next char not unique" message
+ ;; and the user's hit TAB again, so now we give him help.
+ ((eq this-command last-command)
(if completion-auto-help (minibuffer-completion-help))))
(minibuffer--bitset completed t exact))))))))
;; If the previous command was not this,
;; mark the completion buffer obsolete.
(unless (eq this-command last-command)
- (setq completion-all-sorted-completions nil)
+ (completion--flush-all-sorted-completions)
(setq minibuffer-scroll-window nil))
(cond
- ;; If there's a fresh completion window with a live buffer,
- ;; and this command is repeated, scroll that window.
+ ;; If there's a fresh completion window with a live buffer,
+ ;; and this command is repeated, scroll that window.
((window-live-p minibuffer-scroll-window)
(let ((window minibuffer-scroll-window))
- (with-current-buffer (window-buffer window)
- (if (pos-visible-in-window-p (point-max) window)
- ;; If end is in view, scroll up to the beginning.
- (set-window-start window (point-min) nil)
- ;; Else scroll down one screen.
- (scroll-other-window))
+ (with-current-buffer (window-buffer window)
+ (if (pos-visible-in-window-p (point-max) window)
+ ;; If end is in view, scroll up to the beginning.
+ (set-window-start window (point-min) nil)
+ ;; Else scroll down one screen.
+ (scroll-other-window))
nil)))
;; If we're cycling, keep on cycling.
- (completion-all-sorted-completions
+ ((and completion-cycling completion-all-sorted-completions)
(minibuffer-force-complete)
t)
(t (case (completion--do-completion)
t)
(t t)))))
-(defvar completion-all-sorted-completions nil)
-(make-variable-buffer-local 'completion-all-sorted-completions)
-
-(defun completion--flush-all-sorted-completions (&rest ignore)
+(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-all-sorted-completions ()
(when last
(setcdr last nil)
;; Prefer shorter completions.
- (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2)))))
+ (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))))))))
;; Prefer recently used completions.
+ ;; FIXME: Additional sorting ideas:
+ ;; - for M-x, prefer commands that have no key binding.
(let ((hist (symbol-value minibuffer-history-variable)))
(setq all (sort all (lambda (c1 c2)
(> (length (member c1 hist))
(all (completion-all-sorted-completions)))
(if (not (consp all))
(minibuffer-message (if all "No more completions" "No completions"))
+ (setq completion-cycling t)
(goto-char end)
(insert (car all))
(delete-region (+ start (cdr (last all))) end)
;; a space displayed.
(set-text-properties (- (point) 1) (point)
;; We can't just set tab-width, because
- ;; completion-setup-function will kill all
- ;; local variables :-(
+ ;; completion-setup-function will kill
+ ;; all local variables :-(
`(display (space :align-to ,column)))
nil))))
(if (not (consp str))
'mouse-face 'highlight)
(add-text-properties (point) (progn (insert (cadr str)) (point))
'(mouse-face nil
- face completions-annotations)))
+ face completions-annotations)))
(cond
((eq completions-format 'vertical)
;; Vertical format
"Display a list of possible completions of the current minibuffer contents."
(interactive)
(message "Making completion list...")
- (let* ((non-essential t)
- (start (field-beginning))
+ (let* ((start (field-beginning))
+ (end (field-end))
(string (field-string))
(completions (completion-all-completions
string
completions)))
(with-current-buffer standard-output
(set (make-local-variable 'completion-base-position)
- ;; FIXME: We should provide the END part as well, but
- ;; currently completion-all-completions does not give
- ;; us the necessary information.
- (list (+ start base-size) nil)))
+ (list (+ start base-size)
+ ;; FIXME: We should pay attention to completion
+ ;; boundaries here, but currently
+ ;; completion-all-completions does not give us the
+ ;; necessary information.
+ end)))
(display-completion-list completions)))
;; If there are no completions, or if the current input is already the
are expected to perform completion on START..END using COLLECTION
and PREDICATE, either by calling NEXT-FUN or by doing it themselves.")
+(defvar completion-in-region--data nil)
+
(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.
(assert (<= start (point)) (<= (point) end))
;; FIXME: undisplay the *Completions* buffer once the completion is done.
(with-wrapper-hook
+ ;; FIXME: Maybe we should use this hook to provide a "display
+ ;; completions" operation as well.
completion-in-region-functions (start end collection predicate)
(let ((minibuffer-completion-table collection)
(minibuffer-completion-predicate predicate)
(ol (make-overlay start end nil nil t)))
(overlay-put ol 'field 'completion)
+ (completion-in-region-mode 1)
+ (setq completion-in-region--data
+ (list (current-buffer) start end collection))
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol)))))
+(defvar completion-in-region-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "?" 'completion-help-at-point)
+ (define-key map "\t" 'completion-at-point)
+ map)
+ "Keymap activated during `completion-in-region'.")
+
+;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
+;; the *Completions*).
+;; - lisp-mode: never.
+;; - comint: only do it if you hit SPC at the right time.
+;; - pcomplete: pop it down on SPC or after some time-delay.
+;; - semantic: use a post-command-hook check similar to this one.
+(defun completion-in-region--postch ()
+ (message "completion-in-region--postch: cmd=%s" this-command)
+ (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)
+ (current-buffer))
+ (>= (point) (nth 1 completion-in-region--data))
+ (<= (point)
+ (save-excursion
+ (goto-char (nth 2 completion-in-region--data))
+ (line-end-position)))
+ (let ((comp-data (run-hook-wrapped
+ 'completion-at-point-functions
+ ;; Only use the known-safe functions.
+ #'completion--capf-wrapper 'safe)))
+ (eq (car comp-data)
+ ;; We're still in the same completion field.
+ (nth 1 completion-in-region--data)))))
+ (completion-in-region-mode -1)))
+
+;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
+
+(define-minor-mode completion-in-region-mode
+ "Transient minor mode used during `completion-in-region'."
+ :global t
+ (setq completion-in-region--data nil)
+ ;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
+ (remove-hook 'post-command-hook #'completion-in-region--postch)
+ (setq minor-mode-overriding-map-alist
+ (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
+ minor-mode-overriding-map-alist))
+ (if (null completion-in-region-mode)
+ (progn
+ (unless (equal "*Completions*" (buffer-name (window-buffer)))
+ (minibuffer-hide-completions))
+ (message "Leaving completion-in-region-mode"))
+ ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
+ (add-hook 'post-command-hook #'completion-in-region--postch)
+ (push `(completion-in-region-mode . ,completion-in-region-mode-map)
+ minor-mode-overriding-map-alist)))
+
+;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
+;; on minor-mode-overriding-map-alist instead.
+(setq minor-mode-map-alist
+ (delq (assq 'completion-in-region-mode minor-mode-map-alist)
+ minor-mode-map-alist))
+
(defvar completion-at-point-functions '(tags-completion-at-point-function)
"Special hook to find the completion table for the thing at point.
-It is called without any argument and should return either nil,
+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
START and END delimit the entity to complete and should include point,
`:predicate' a predicate that completion candidates need to satisfy.
`:annotation-function' the value to use for `completion-annotate-function'.")
-(defun completion-at-point (&optional arg)
+(defvar completion--capf-misbehave-funs nil
+ "List of functions found on `completion-at-point-functions' that misbehave.")
+(defvar completion--capf-safe-funs nil
+ "List of well-behaved functions found on `completion-at-point-functions'.")
+
+(defun completion--capf-wrapper (fun which)
+ (if (case which
+ (all t)
+ (safe (member fun completion--capf-safe-funs))
+ (optimist (not (member fun completion--capf-misbehave-funs))))
+ (let ((res (funcall fun)))
+ (cond
+ ((consp res)
+ (unless (member fun completion--capf-safe-funs)
+ (push fun completion--capf-safe-funs)))
+ ((not (or (listp res) (functionp res)))
+ (unless (member fun completion--capf-misbehave-funs)
+ (message
+ "Completion function %S uses a deprecated calling convention" fun)
+ (push fun completion--capf-misbehave-funs))))
+ res)))
+
+(defun completion-at-point ()
"Perform completion on the text around point.
-The completion method is determined by `completion-at-point-functions'.
-
-With a prefix argument, this command does completion within
-the collection of symbols listed in the index of the manual for the
-language you are using."
- (interactive "P")
- (if arg
- (info-complete-symbol)
- (let ((res (run-hook-with-args-until-success
- 'completion-at-point-functions)))
- (cond
- ((functionp res) (funcall res))
- (res
- (let* ((plist (nthcdr 3 res))
- (start (nth 0 res))
- (end (nth 1 res))
- (completion-annotate-function
- (or (plist-get plist :annotation-function)
- completion-annotate-function)))
- (completion-in-region start end (nth 2 res)
- (plist-get plist :predicate))))))))
-
-(define-obsolete-function-alias 'complete-symbol 'completion-at-point "24.1")
+The completion method is determined by `completion-at-point-functions'."
+ (interactive)
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ #'completion--capf-wrapper 'all)))
+ (cond
+ ((functionp res) (funcall res))
+ ((consp res)
+ (let* ((plist (nthcdr 3 res))
+ (start (nth 0 res))
+ (end (nth 1 res))
+ (completion-annotate-function
+ (or (plist-get plist :annotation-function)
+ completion-annotate-function)))
+ (completion-in-region start end (nth 2 res)
+ (plist-get plist :predicate))))
+ (res)))) ;Maybe completion already happened and the function returned t.
+
+(defun completion-help-at-point ()
+ "Display the completions on the text around point.
+The completion method is determined by `completion-at-point-functions'."
+ (interactive)
+ (let ((res (run-hook-wrapped 'completion-at-point-functions
+ ;; Ignore misbehaving functions.
+ #'completion--capf-wrapper 'optimist)))
+ (cond
+ ((functionp res)
+ (message "Don't know how to show completions for %S" res))
+ ((consp res)
+ (let* ((plist (nthcdr 3 res))
+ (minibuffer-completion-table (nth 2 res))
+ (minibuffer-completion-predicate (plist-get plist :predicate))
+ (completion-annotate-function
+ (or (plist-get plist :annotation-function)
+ completion-annotate-function))
+ (ol (make-overlay (nth 0 res) (nth 1 res) 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)
+ (unwind-protect
+ (call-interactively 'minibuffer-completion-help)
+ (delete-overlay ol))))
+ (res
+ ;; The hook function already performed completion :-(
+ ;; Not much we can do at this point.
+ nil)
+ (t (message "Nothing to complete at point")))))
;;; Key bindings.
(concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
"$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
-(defun completion--embedded-envvar-table (string pred action)
+(defun completion--embedded-envvar-table (string _pred action)
"Completion table for envvars embedded in a string.
The envvar syntax (and escaping) rules followed by this table are the
same as `substitute-in-file-name'."
;; other table handle the test-completion case.
nil)
((eq (car-safe action) 'boundaries)
- ;; Only return boundaries 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.
- ;; FIXME: Maybe it should rather be fixed in
- ;; completion-table-in-turn instead, but it's difficult to
- ;; do it efficiently there.
+ ;; Only return boundaries 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.
+ ;; FIXME: Maybe it should rather be fixed in
+ ;; completion-table-in-turn instead, but it's difficult to
+ ;; do it efficiently there.
(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)
+ ;; 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))))))
(t
(if (eq (aref string (1- beg)) ?{)
(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)))
+ (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)))
- (t
+ (t
(let* ((name (file-name-nondirectory string))
(specdir (file-name-directory string))
(realdir (or specdir default-directory)))
- (cond
- ((null action)
+ (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)))
+ ((eq action t)
+ (let ((all (file-name-all-completions name realdir)))
- ;; Check the predicate, if necessary.
+ ;; Check the predicate, if necessary.
(unless (memq pred '(nil file-exists-p))
- (let ((comp ())
- (pred
+ (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.
+ ;; 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))))
+ (dolist (tem all)
+ (if (funcall pred tem) (push tem comp))))
+ (setq all (nreverse comp))))
all))))))))
'completion--file-name-table)
"Internal subroutine for `read-file-name'. Do not call this.")
-(defvar read-file-name-function nil
- "If this is non-nil, `read-file-name' does its work by calling this function.")
+(defvar read-file-name-function 'read-file-name-default
+ "The function called by `read-file-name' to do its work.
+It should accept the same arguments as `read-file-name'.")
(defcustom read-file-name-completion-ignore-case
(if (memq system-type '(ms-dos windows-nt darwin cygwin))
(declare-function x-file-dialog "xfns.c"
(prompt dir &optional default-filename mustmatch only-dir-p))
-(defun read-file-name-defaults (&optional dir initial)
+(defun read-file-name--defaults (&optional dir initial)
(let ((default
(cond
;; With non-nil `initial', use `dir' as the first default.
See also `read-file-name-completion-ignore-case'
and `read-file-name-function'."
+ (funcall (or read-file-name-function #'read-file-name-default)
+ prompt dir default-filename mustmatch initial predicate))
+
+(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."
(unless dir (setq dir default-directory))
(unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
(unless default-filename
(minibuffer--double-dollars dir)))
(initial (cons (minibuffer--double-dollars initial) 0)))))
- (if read-file-name-function
- (funcall read-file-name-function
- prompt dir default-filename mustmatch initial predicate)
- (let ((completion-ignore-case read-file-name-completion-ignore-case)
- (minibuffer-completing-file-name t)
- (pred (or predicate 'file-exists-p))
- (add-to-history nil))
-
- (let* ((val
- (if (or (not (next-read-file-uses-dialog-p))
- ;; Graphical file dialogs can't handle remote
- ;; files (Bug#99).
- (file-remote-p dir))
- ;; We used to pass `dir' to `read-file-name-internal' by
- ;; abusing the `predicate' argument. It's better to
- ;; just use `default-directory', but in order to avoid
- ;; changing `default-directory' in the current buffer,
- ;; we don't let-bind it.
- (lexical-let ((dir (file-name-as-directory
- (expand-file-name dir))))
- (minibuffer-with-setup-hook
- (lambda ()
- (setq default-directory dir)
- ;; When the first default in `minibuffer-default'
- ;; duplicates initial input `insdef',
- ;; reset `minibuffer-default' to nil.
- (when (equal (or (car-safe insdef) insdef)
- (or (car-safe minibuffer-default)
- minibuffer-default))
- (setq minibuffer-default
- (cdr-safe minibuffer-default)))
- ;; On the first request on `M-n' fill
- ;; `minibuffer-default' with a list of defaults
- ;; relevant for file-name reading.
- (set (make-local-variable 'minibuffer-default-add-function)
- (lambda ()
- (with-current-buffer
- (window-buffer (minibuffer-selected-window))
- (read-file-name-defaults dir initial)))))
- (completing-read prompt 'read-file-name-internal
- pred mustmatch insdef
- 'file-name-history default-filename)))
- ;; If DEFAULT-FILENAME not supplied and DIR contains
- ;; a file name, split it.
- (let ((file (file-name-nondirectory dir))
- ;; When using a dialog, revert to nil and non-nil
- ;; interpretation of mustmatch. confirm options
- ;; need to be interpreted as nil, otherwise
- ;; it is impossible to create new files using
- ;; dialogs with the default settings.
- (dialog-mustmatch
- (not (memq mustmatch
- '(nil confirm confirm-after-completion)))))
- (when (and (not default-filename)
- (not (zerop (length file))))
- (setq default-filename file)
- (setq dir (file-name-directory dir)))
- (when default-filename
- (setq default-filename
- (expand-file-name (if (consp default-filename)
- (car default-filename)
- default-filename)
- dir)))
- (setq add-to-history t)
- (x-file-dialog prompt dir default-filename
- dialog-mustmatch
- (eq predicate 'file-directory-p)))))
-
- (replace-in-history (eq (car-safe file-name-history) val)))
- ;; If completing-read returned the inserted default string itself
- ;; (rather than a new string with the same contents),
- ;; it has to mean that the user typed RET with the minibuffer empty.
- ;; In that case, we really want to return ""
- ;; so that commands such as set-visited-file-name can distinguish.
- (when (consp default-filename)
- (setq default-filename (car default-filename)))
- (when (eq val default-filename)
- ;; In this case, completing-read has not added an element
- ;; to the history. Maybe we should.
- (if (not replace-in-history)
- (setq add-to-history t))
- (setq val ""))
- (unless val (error "No file name specified"))
-
- (if (and default-filename
- (string-equal val (if (consp insdef) (car insdef) insdef)))
- (setq val default-filename))
- (setq val (substitute-in-file-name val))
-
- (if replace-in-history
- ;; Replace what Fcompleting_read added to the history
- ;; with what we will actually return. As an exception,
- ;; if that's the same as the second item in
- ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((completion-ignore-case read-file-name-completion-ignore-case)
+ (minibuffer-completing-file-name t)
+ (pred (or predicate 'file-exists-p))
+ (add-to-history nil))
+
+ (let* ((val
+ (if (or (not (next-read-file-uses-dialog-p))
+ ;; Graphical file dialogs can't handle remote
+ ;; files (Bug#99).
+ (file-remote-p dir))
+ ;; We used to pass `dir' to `read-file-name-internal' by
+ ;; abusing the `predicate' argument. It's better to
+ ;; just use `default-directory', but in order to avoid
+ ;; changing `default-directory' in the current buffer,
+ ;; we don't let-bind it.
+ (let ((dir (file-name-as-directory
+ (expand-file-name dir))))
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (setq default-directory dir)
+ ;; When the first default in `minibuffer-default'
+ ;; duplicates initial input `insdef',
+ ;; reset `minibuffer-default' to nil.
+ (when (equal (or (car-safe insdef) insdef)
+ (or (car-safe minibuffer-default)
+ minibuffer-default))
+ (setq minibuffer-default
+ (cdr-safe minibuffer-default)))
+ ;; On the first request on `M-n' fill
+ ;; `minibuffer-default' with a list of defaults
+ ;; relevant for file-name reading.
+ (set (make-local-variable 'minibuffer-default-add-function)
+ (lambda ()
+ (with-current-buffer
+ (window-buffer (minibuffer-selected-window))
+ (read-file-name--defaults dir initial)))))
+ (completing-read prompt 'read-file-name-internal
+ pred mustmatch insdef
+ 'file-name-history default-filename)))
+ ;; If DEFAULT-FILENAME not supplied and DIR contains
+ ;; a file name, split it.
+ (let ((file (file-name-nondirectory dir))
+ ;; When using a dialog, revert to nil and non-nil
+ ;; interpretation of mustmatch. confirm options
+ ;; need to be interpreted as nil, otherwise
+ ;; it is impossible to create new files using
+ ;; dialogs with the default settings.
+ (dialog-mustmatch
+ (not (memq mustmatch
+ '(nil confirm confirm-after-completion)))))
+ (when (and (not default-filename)
+ (not (zerop (length file))))
+ (setq default-filename file)
+ (setq dir (file-name-directory dir)))
+ (when default-filename
+ (setq default-filename
+ (expand-file-name (if (consp default-filename)
+ (car default-filename)
+ default-filename)
+ dir)))
+ (setq add-to-history t)
+ (x-file-dialog prompt dir default-filename
+ dialog-mustmatch
+ (eq predicate 'file-directory-p)))))
+
+ (replace-in-history (eq (car-safe file-name-history) val)))
+ ;; If completing-read returned the inserted default string itself
+ ;; (rather than a new string with the same contents),
+ ;; it has to mean that the user typed RET with the minibuffer empty.
+ ;; In that case, we really want to return ""
+ ;; so that commands such as set-visited-file-name can distinguish.
+ (when (consp default-filename)
+ (setq default-filename (car default-filename)))
+ (when (eq val default-filename)
+ ;; In this case, completing-read has not added an element
+ ;; to the history. Maybe we should.
+ (if (not replace-in-history)
+ (setq add-to-history t))
+ (setq val ""))
+ (unless val (error "No file name specified"))
+
+ (if (and default-filename
+ (string-equal val (if (consp insdef) (car insdef) insdef)))
+ (setq val default-filename))
+ (setq val (substitute-in-file-name val))
+
+ (if replace-in-history
+ ;; Replace what Fcompleting_read added to the history
+ ;; with what we will actually return. As an exception,
+ ;; if that's the same as the second item in
+ ;; file-name-history, it's really a repeat (Bug#4657).
+ (let ((val1 (minibuffer--double-dollars val)))
+ (if history-delete-duplicates
+ (setcdr file-name-history
+ (delete val1 (cdr file-name-history))))
+ (if (string= val1 (cadr file-name-history))
+ (pop file-name-history)
+ (setcar file-name-history val1)))
+ (if add-to-history
+ ;; Add the value to the history--but not if it matches
+ ;; the last value already there.
(let ((val1 (minibuffer--double-dollars val)))
- (if history-delete-duplicates
- (setcdr file-name-history
- (delete val1 (cdr file-name-history))))
- (if (string= val1 (cadr file-name-history))
- (pop file-name-history)
- (setcar file-name-history val1)))
- (if add-to-history
- ;; Add the value to the history--but not if it matches
- ;; the last value already there.
- (let ((val1 (minibuffer--double-dollars val)))
- (unless (and (consp file-name-history)
- (equal (car file-name-history) val1))
- (setq file-name-history
- (cons val1
- (if history-delete-duplicates
- (delete val1 file-name-history)
- file-name-history)))))))
- val)))))
+ (unless (and (consp file-name-history)
+ (equal (car file-name-history) val1))
+ (setq file-name-history
+ (cons val1
+ (if history-delete-duplicates
+ (delete val1 file-name-history)
+ file-name-history)))))))
+ val))))
(defun internal-complete-buffer-except (&optional buffer)
"Perform completion on all buffers excluding BUFFER.
BUFFER nil or omitted means use the current buffer.
Like `internal-complete-buffer', but removes BUFFER from the completion list."
- (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer))))
+ (let ((except (if (stringp buffer) buffer (buffer-name buffer))))
(apply-partially 'completion-table-with-predicate
'internal-complete-buffer
(lambda (name)
;;; Old-style completion, used in Emacs-21 and Emacs-22.
-(defun completion-emacs21-try-completion (string table pred point)
+(defun completion-emacs21-try-completion (string table pred _point)
(let ((completion (try-completion string table pred)))
(if (stringp completion)
(cons completion (length completion))
completion)))
-(defun completion-emacs21-all-completions (string table pred point)
+(defun completion-emacs21-all-completions (string table pred _point)
(completion-hilit-commonality
(all-completions string table pred)
(length string)
(length completion))))
(let* ((suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
- (pattern (completion-basic--pattern
- beforepoint afterpoint bounds))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(if minibuffer-completing-file-name
(setq all (completion-pcm--filename-try-filter all)))
(let* ((beforepoint (substring string 0 point))
(afterpoint (substring string point))
(bounds (completion-boundaries beforepoint table pred afterpoint))
+ ;; (suffix (substring afterpoint (cdr bounds)))
(prefix (substring beforepoint 0 (car bounds)))
- (pattern (completion-basic--pattern beforepoint afterpoint bounds))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
(all (completion-pcm--all-completions prefix pattern table pred)))
(completion-hilit-commonality all point (car bounds))))
(append (completion-pcm--string->pattern prefix)
'(point)
(completion-pcm--string->pattern suffix)))
- (let ((pattern nil)
- (p 0)
- (p0 0))
+ (let* ((pattern nil)
+ (p 0)
+ (p0 p))
(while (and (setq p (string-match completion-pcm--delim-wild-regex
string p))
;; 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)
+ (destructuring-bind (subpat suball subprefix _subsuffix)
(completion-pcm--find-all-completions
substring table pred (length substring) filter)
(let ((sep (aref prefix (1- (length prefix))))
(list pattern all prefix suffix)))))
(defun completion-pcm-all-completions (string table pred point)
- (destructuring-bind (pattern all &optional prefix suffix)
+ (destructuring-bind (pattern all &optional prefix _suffix)
(completion-pcm--find-all-completions string table pred point)
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
(defun completion-pcm--pattern->string (pattern)
(mapconcat (lambda (x) (cond
- ((stringp x) x)
- ((eq x 'star) "*")
- (t ""))) ;any, point, prefix.
+ ((stringp x) x)
+ ((eq x 'star) "*")
+ (t ""))) ;any, point, prefix.
pattern
""))
;; second alternative.
(defun completion-pcm--filename-try-filter (all)
"Filter to adjust `all' file completion to the behavior of `try'."
- (when all
+ (when all
(let ((try ())
(re (concat "\\(?:\\`\\.\\.?/\\|"
(regexp-opt completion-ignored-extensions)
(equal (completion-pcm--pattern->string pattern) (car all)))
t)
(t
- (let* ((mergedpat (completion-pcm--merge-completions all pattern))
- ;; `mergedpat' is in reverse order. Place new point (by
- ;; order of preference) either at the old point, or at
- ;; the last place where there's something to choose, or
- ;; at the very end.
- (pointpat (or (memq 'point mergedpat)
- (memq 'any mergedpat)
- (memq 'star mergedpat)
- ;; Not `prefix'.
- mergedpat))
- ;; New pos from the start.
- (newpos (length (completion-pcm--pattern->string pointpat)))
- ;; Do it afterwards because it changes `pointpat' by sideeffect.
- (merged (completion-pcm--pattern->string (nreverse mergedpat))))
+ (let* ((mergedpat (completion-pcm--merge-completions all pattern))
+ ;; `mergedpat' is in reverse order. Place new point (by
+ ;; order of preference) either at the old point, or at
+ ;; the last place where there's something to choose, or
+ ;; at the very end.
+ (pointpat (or (memq 'point mergedpat)
+ (memq 'any mergedpat)
+ (memq 'star mergedpat)
+ ;; Not `prefix'.
+ mergedpat))
+ ;; New pos from the start.
+ (newpos (length (completion-pcm--pattern->string pointpat)))
+ ;; Do it afterwards because it changes `pointpat' by sideeffect.
+ (merged (completion-pcm--pattern->string (nreverse mergedpat))))
(setq suffix (completion--merge-suffix merged newpos suffix))
- (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
+ (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
(defun completion-pcm-try-completion (string table pred point)
(destructuring-bind (pattern all prefix suffix)
(list all pattern prefix suffix (car bounds))))
(defun completion-substring-try-completion (string table pred point)
- (destructuring-bind (all pattern prefix suffix carbounds)
+ (destructuring-bind (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)
+ (destructuring-bind (all pattern prefix _suffix _carbounds)
(completion-substring--all-completions string table pred point)
(when all
(nconc (completion-pcm--hilit-commonality pattern all)
(concat (substring str 0 (car bounds))
(mapconcat 'string (substring str (car bounds)) sep))))))))
-(defun completion-initials-all-completions (string table pred point)
+(defun completion-initials-all-completions (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-all-completions newstr table pred (length newstr)))))
-(defun completion-initials-try-completion (string table pred point)
+(defun completion-initials-try-completion (string table pred _point)
(let ((newstr (completion-initials-expand string table pred)))
(when newstr
(completion-pcm-try-completion newstr table pred (length newstr)))))
(provide 'minibuffer)
-;; arch-tag: ef8a0a15-1080-4790-a754-04017c02f08f
;;; minibuffer.el ends here
HCoop / bpt / emacs.git / blobdiff