-;;; pcomplete.el --- programmable completion
+;;; pcomplete.el --- programmable completion -*- lexical-binding: t -*-
-;; Copyright (C) 1999-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1999-2014 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@gnu.org>
;; Keywords: processes abbrev
;; argument position.
;;
;; To use pcomplete with shell-mode, for example, you will need the
-;; following in your .emacs file:
+;; following in your init file:
;;
;; (add-hook 'shell-mode-hook 'pcomplete-shell-setup)
;;
;;; Code:
-(eval-when-compile (require 'cl))
+(require 'comint)
(defgroup pcomplete nil
"Programmable completion."
"A list of characters which constitute a proper suffix."
:type '(repeat character)
:group 'pcomplete)
+(make-obsolete-variable 'pcomplete-suffix-list nil "24.1")
(defcustom pcomplete-recexact nil
"If non-nil, use shortest completion if characters cannot be added.
:type 'boolean
:group 'pcomplete)
-(defcustom pcomplete-arg-quote-list nil
- "List of characters to quote when completing an argument."
- :type '(choice (repeat character)
- (const :tag "Don't quote" nil))
- :group 'pcomplete)
-
-(defcustom pcomplete-quote-arg-hook nil
- "A hook which is run to quote a character within a filename.
-Each function is passed both the filename to be quoted, and the index
-to be considered. If the function wishes to provide an alternate
-quoted form, it need only return the replacement string. If no
-function provides a replacement, quoting shall proceed as normal,
-using a backslash to quote any character which is a member of
-`pcomplete-arg-quote-list'."
- :type 'hook
- :group 'pcomplete)
+(define-obsolete-variable-alias
+ 'pcomplete-arg-quote-list 'comint-file-name-quote-list "24.3")
(defcustom pcomplete-man-function 'man
"A function to that will be called to display a manual page.
;; it pretty much impossible to have completion other than
;; prefix-completion.
;;
-;; pcomplete--common-quoted-suffix and pcomplete--table-subvert try to
-;; work around this difficulty with heuristics, but it's
-;; really a hack.
+;; pcomplete--common-suffix and completion-table-subvert try to work around
+;; this difficulty with heuristics, but it's really a hack.
-(defvar pcomplete-unquote-argument-function nil)
+(defvar pcomplete-unquote-argument-function #'comint--unquote-argument)
-(defun pcomplete-unquote-argument (s)
- (cond
- (pcomplete-unquote-argument-function
- (funcall pcomplete-unquote-argument-function s))
- ((null pcomplete-arg-quote-list) s)
- (t
- (replace-regexp-in-string "\\\\\\(.\\)" "\\1" s t))))
+(defsubst pcomplete-unquote-argument (s)
+ (funcall pcomplete-unquote-argument-function s))
+
+(defvar pcomplete-requote-argument-function #'comint--requote-argument)
(defun pcomplete--common-suffix (s1 s2)
- (assert (not (or (string-match "\n" s1) (string-match "\n" s2))))
;; Since S2 is expected to be the "unquoted/expanded" version of S1,
;; there shouldn't be any case difference, even if the completion is
;; case-insensitive.
- (let ((case-fold-search nil)) ;; pcomplete-ignore-case
- (string-match ".*?\\(.*\\)\n.*\\1\\'" (concat s1 "\n" s2))
+ (let ((case-fold-search nil))
+ (string-match
+ ;; \x3FFF7F is just an arbitrary char among the ones Emacs accepts
+ ;; that hopefully will never appear in normal text.
+ "\\(?:.\\|\n\\)*?\\(\\(?:.\\|\n\\)*\\)\x3FFF7F\\(?:.\\|\n\\)*\\1\\'"
+ (concat s1 "\x3FFF7F" s2))
(- (match-end 1) (match-beginning 1))))
-(defun pcomplete--common-quoted-suffix (s1 s2)
- "Find the common suffix between S1 and S2 where S1 is the expanded S2.
-S1 is expected to be the unquoted and expanded version of S1.
-Returns (PS1 . PS2), i.e. the shortest prefixes of S1 and S2, such that
-S1 = (concat PS1 SS1) and S2 = (concat PS2 SS2) and
-SS1 = (unquote SS2)."
- (let* ((cs (pcomplete--common-suffix s1 s2))
- (ss1 (substring s1 (- (length s1) cs)))
- (qss1 (pcomplete-quote-argument ss1))
- qc)
- (if (and (not (equal ss1 qss1))
- (setq qc (pcomplete-quote-argument (substring ss1 0 1)))
- (eq t (compare-strings s2 (- (length s2) cs (length qc) -1)
- (- (length s2) cs -1)
- qc nil nil)))
- ;; The difference found is just that one char is quoted in S2
- ;; but not in S1, keep looking before this difference.
- (pcomplete--common-quoted-suffix
- (substring s1 0 (- (length s1) cs))
- (substring s2 0 (- (length s2) cs (length qc) -1)))
- (cons (substring s1 0 (- (length s1) cs))
- (substring s2 0 (- (length s2) cs))))))
-
-(defun pcomplete--table-subvert (table s1 s2 string pred action)
- "Completion table that replaces the prefix S1 with S2 in STRING.
-When TABLE, S1 and S2 are provided by `apply-partially', 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)."
- (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil
- completion-ignore-case))
- (concat s2 (pcomplete-unquote-argument
- (substring string (length s1))))))
- (res (if str (complete-with-action action table str pred))))
- (when res
- (cond
- ((and (eq (car-safe action) 'boundaries))
- (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
- (list* 'boundaries
- (max (length s1)
- ;; FIXME: Adjust because of quoting/unquoting.
- (+ beg (- (length s1) (length s2))))
- (and (eq (car-safe res) 'boundaries) (cddr res)))))
- ((stringp res)
- (if (eq t (compare-strings res 0 (length s2) s2 nil nil
- completion-ignore-case))
- (concat s1 (pcomplete-quote-argument
- (substring res (length s2))))))
- ((eq action t)
- (let ((bounds (completion-boundaries str table pred "")))
- (if (>= (car bounds) (length s2))
- res
- (let ((re (concat "\\`"
- (regexp-quote (substring s2 (car bounds))))))
- (delq nil
- (mapcar (lambda (c)
- (if (string-match re c)
- (substring c (match-end 0))))
- res))))))))))
-
-;; I don't think such commands are usable before first setting up buffer-local
-;; variables to parse args, so there's no point autoloading it.
-;; ;;;###autoload
(defun pcomplete-completions-at-point ()
"Provide standard completion using pcomplete's completion tables.
Same as `pcomplete' but using the standard completion UI."
;; pcomplete-stub and works from the buffer's text instead,
;; we need to trick minibuffer-complete, into using
;; pcomplete-stub without its knowledge. To that end, we
- ;; use pcomplete--table-subvert to construct a completion
+ ;; use completion-table-subvert to construct a completion
;; table which expects strings using a prefix from the
;; buffer's text but internally uses the corresponding
;; prefix from pcomplete-stub.
(beg (max (- (point) (length pcomplete-stub))
(pcomplete-begin)))
- (buftext (buffer-substring beg (point))))
+ (buftext (pcomplete-unquote-argument
+ (buffer-substring beg (point)))))
(when completions
(let ((table
- (cond
- ((not (equal pcomplete-stub buftext))
- ;; This isn't always strictly right (e.g. if
- ;; FOO="toto/$FOO", then completion of /$FOO/bar may
- ;; result in something incorrect), but given the lack of
- ;; any other info, it's about as good as it gets, and in
- ;; practice it should work just fine (fingers crossed).
- (let ((prefixes (pcomplete--common-quoted-suffix
- pcomplete-stub buftext)))
- (apply-partially
- 'pcomplete--table-subvert
+ (completion-table-with-quoting
+ (if (equal pcomplete-stub buftext)
completions
- (cdr prefixes) (car prefixes))))
- (t
- (lexical-let ((completions completions))
- (lambda (string pred action)
- (let ((res (complete-with-action
- action completions string pred)))
- (if (stringp res)
- (pcomplete-quote-argument res)
- res)))))))
+ ;; This may not always be strictly right, but given the lack
+ ;; of any other info, it's about as good as it gets, and in
+ ;; practice it should work just fine (fingers crossed).
+ (let ((suf-len (pcomplete--common-suffix
+ pcomplete-stub buftext)))
+ (completion-table-subvert
+ completions
+ (substring buftext 0 (- (length buftext) suf-len))
+ (substring pcomplete-stub 0
+ (- (length pcomplete-stub) suf-len)))))
+ pcomplete-unquote-argument-function
+ pcomplete-requote-argument-function))
(pred
;; Pare it down, if applicable.
(when (and pcomplete-use-paring pcomplete-seen)
- (setq pcomplete-seen
- (mapcar (lambda (f)
- (funcall pcomplete-norm-func
- (directory-file-name f)))
- pcomplete-seen))
- (lambda (f)
- (not (when pcomplete-seen
- (member
- (funcall pcomplete-norm-func
- (directory-file-name f))
- pcomplete-seen)))))))
+ ;; Capture the dynbound values for later use.
+ (let ((norm-func pcomplete-norm-func)
+ (seen
+ (mapcar (lambda (f)
+ (funcall pcomplete-norm-func
+ (directory-file-name f)))
+ pcomplete-seen)))
+ (lambda (f)
+ (not (member
+ (funcall norm-func (directory-file-name f))
+ seen)))))))
(when pcomplete-ignore-case
- (setq table
- (apply-partially #'completion-table-case-fold table)))
+ (setq table (completion-table-case-fold table)))
(list beg (point) table
:predicate pred
:exit-function
+ ;; If completion is finished, add a terminating space.
+ ;; We used to also do this if STATUS is `sole', but
+ ;; that does not work right when completion cycling.
(unless (zerop (length pcomplete-termination-string))
- (lambda (_s finished)
- (when (memq finished '(sole finished))
+ (lambda (_s status)
+ (when (eq status 'finished)
(if (looking-at
(regexp-quote pcomplete-termination-string))
(goto-char (match-end 0))
this is `comint-dynamic-complete-functions'."
(set (make-local-variable 'pcomplete-parse-arguments-function)
'pcomplete-parse-comint-arguments)
+ (add-hook 'completion-at-point-functions
+ 'pcomplete-completions-at-point nil 'local)
(set (make-local-variable completef-sym)
(copy-sequence (symbol-value completef-sym)))
(let* ((funs (symbol-value completef-sym))
(defun pcomplete-parse-comint-arguments ()
"Parse whitespace separated arguments in the current region."
+ (declare (obsolete comint-parse-pcomplete-arguments "24.1"))
(let ((begin (save-excursion (comint-bol nil) (point)))
(end (point))
begins args)
(while (< (point) end)
(skip-chars-forward " \t\n")
(push (point) begins)
- (let ((skip t))
- (while skip
- (skip-chars-forward "^ \t\n")
- (if (eq (char-before) ?\\)
- (skip-chars-forward " \t\n")
- (setq skip nil))))
+ (while
+ (progn
+ (skip-chars-forward "^ \t\n\\")
+ (when (eq (char-after) ?\\)
+ (forward-char 1)
+ (unless (eolp)
+ (forward-char 1)
+ t))))
(push (buffer-substring-no-properties (car begins) (point))
args))
(cons (nreverse args) (nreverse begins)))))
(throw 'pcompleted t)
pcomplete-args))))))
-(defun pcomplete-quote-argument (filename)
- "Return FILENAME with magic characters quoted.
-Magic characters are those in `pcomplete-arg-quote-list'."
- (if (null pcomplete-arg-quote-list)
- filename
- (let ((index 0))
- (mapconcat (lambda (c)
- (prog1
- (or (run-hook-with-args-until-success
- 'pcomplete-quote-arg-hook filename index)
- (when (memq c pcomplete-arg-quote-list)
- (string "\\" c))
- (char-to-string c))
- (setq index (1+ index))))
- filename
- ""))))
+(define-obsolete-function-alias
+ 'pcomplete-quote-argument #'comint-quote-filename "24.3")
;; file-system completion lists
(defsubst pcomplete-dirs-or-entries (&optional regexp predicate)
"Return either directories, or qualified entries."
- ;; FIXME: pcomplete-entries doesn't return a list any more.
(pcomplete-entries
nil
- (lexical-let ((re regexp)
- (pred predicate))
- (lambda (f)
- (or (file-directory-p f)
- (and (if (not re) t (string-match re f))
- (if (not pred) t (funcall pred f))))))))
+ (lambda (f)
+ (or (file-directory-p f)
+ (and (or (null regexp) (string-match regexp f))
+ (or (null predicate) (funcall predicate f)))))))
+
+(defun pcomplete--entries (&optional regexp predicate)
+ "Like `pcomplete-entries' but without env-var handling."
+ (let* ((ign-pred
+ (when (or pcomplete-file-ignore pcomplete-dir-ignore)
+ ;; Capture the dynbound value for later use.
+ (let ((file-ignore pcomplete-file-ignore)
+ (dir-ignore pcomplete-dir-ignore))
+ (lambda (file)
+ (not
+ (if (eq (aref file (1- (length file))) ?/)
+ (and dir-ignore (string-match dir-ignore file))
+ (and file-ignore (string-match file-ignore file))))))))
+ (reg-pred (if regexp (lambda (file) (string-match regexp file))))
+ (pred (cond
+ ((null (or ign-pred reg-pred)) predicate)
+ ((null (or ign-pred predicate)) reg-pred)
+ ((null (or reg-pred predicate)) ign-pred)
+ (t (lambda (f)
+ (and (or (null reg-pred) (funcall reg-pred f))
+ (or (null ign-pred) (funcall ign-pred f))
+ (or (null predicate) (funcall predicate f))))))))
+ (lambda (s p a)
+ (if (and (eq a 'metadata) pcomplete-compare-entry-function)
+ `(metadata (cycle-sort-function
+ . ,(lambda (comps)
+ (sort comps pcomplete-compare-entry-function)))
+ ,@(cdr (completion-file-name-table s p a)))
+ (let ((completion-ignored-extensions nil)
+ (completion-ignore-case pcomplete-ignore-case))
+ (completion-table-with-predicate
+ #'comint-completion-file-name-table pred 'strict s p a))))))
+
+(defconst pcomplete--env-regexp
+ "\\(?:\\`\\|[^\\]\\)\\(?:\\\\\\\\\\)*\\(\\$\\(?:{\\([^}]+\\)}\\|\\(?2:[[:alnum:]_]+\\)\\)\\)")
(defun pcomplete-entries (&optional regexp predicate)
"Complete against a list of directory candidates.
\(files for which the PREDICATE returns nil will be excluded).
If no directory information can be extracted from the completed
component, `default-directory' is used as the basis for completion."
- (let* ((name (substitute-env-vars pcomplete-stub))
- (completion-ignore-case pcomplete-ignore-case)
- (default-directory (expand-file-name
- (or (file-name-directory name)
- default-directory)))
- above-cutoff)
- (setq name (file-name-nondirectory name)
- pcomplete-stub name)
- (let ((completions
- (file-name-all-completions name default-directory)))
- (if regexp
- (setq completions
- (pcomplete-pare-list
- completions nil
- (function
- (lambda (file)
- (not (string-match regexp file)))))))
- (if predicate
- (setq completions
- (pcomplete-pare-list
- completions nil
- (function
- (lambda (file)
- (not (funcall predicate file)))))))
- (if (or pcomplete-file-ignore pcomplete-dir-ignore)
- (setq completions
- (pcomplete-pare-list
- completions nil
- (function
- (lambda (file)
- (if (eq (aref file (1- (length file)))
- ?/)
- (and pcomplete-dir-ignore
- (string-match pcomplete-dir-ignore file))
- (and pcomplete-file-ignore
- (string-match pcomplete-file-ignore file))))))))
- (setq above-cutoff (and pcomplete-cycle-cutoff-length
- (> (length completions)
- pcomplete-cycle-cutoff-length)))
- (sort completions
- (function
- (lambda (l r)
- ;; for the purposes of comparison, remove the
- ;; trailing slash from directory names.
- ;; Otherwise, "foo.old/" will come before "foo/",
- ;; since . is earlier in the ASCII alphabet than
- ;; /
- (let ((left (if (eq (aref l (1- (length l)))
- ?/)
- (substring l 0 (1- (length l)))
- l))
- (right (if (eq (aref r (1- (length r)))
- ?/)
- (substring r 0 (1- (length r)))
- r)))
- (if above-cutoff
- (string-lessp left right)
- (funcall pcomplete-compare-entry-function
- left right)))))))))
+ ;; FIXME: The old code did env-var expansion here, so we reproduce this
+ ;; behavior for now, but really env-var handling should be performed globally
+ ;; rather than here since it also applies to non-file arguments.
+ (let ((table (pcomplete--entries regexp predicate)))
+ (lambda (string pred action)
+ (let ((strings nil)
+ (orig-length (length string)))
+ ;; Perform env-var expansion.
+ (while (string-match pcomplete--env-regexp string)
+ (push (substring string 0 (match-beginning 1)) strings)
+ (push (getenv (match-string 2 string)) strings)
+ (setq string (substring string (match-end 1))))
+ (if (not (and strings
+ (or (eq action t)
+ (eq (car-safe action) 'boundaries))))
+ (let ((newstring
+ (mapconcat 'identity (nreverse (cons string strings)) "")))
+ ;; FIXME: We could also try to return unexpanded envvars.
+ (complete-with-action action table newstring pred))
+ (let* ((envpos (apply #'+ (mapcar #' length strings)))
+ (newstring
+ (mapconcat 'identity (nreverse (cons string strings)) ""))
+ (bounds (completion-boundaries newstring table pred
+ (or (cdr-safe action) ""))))
+ (if (>= (car bounds) envpos)
+ ;; The env-var is "out of bounds".
+ (if (eq action t)
+ (complete-with-action action table newstring pred)
+ `(boundaries
+ ,(+ (car bounds) (- orig-length (length newstring)))
+ . ,(cdr bounds)))
+ ;; The env-var is in the file bounds.
+ (if (eq action t)
+ (let ((comps (complete-with-action
+ action table newstring pred))
+ (len (- envpos (car bounds))))
+ ;; Strip the part of each completion that's actually
+ ;; coming from the env-var.
+ (mapcar (lambda (s) (substring s len)) comps))
+ `(boundaries
+ ,(+ envpos (- orig-length (length newstring)))
+ . ,(cdr bounds))))))))))
(defsubst pcomplete-all-entries (&optional regexp predicate)
"Like `pcomplete-entries', but doesn't ignore any entries."
(setq pcomplete-last-window-config (current-window-configuration)))
(with-output-to-temp-buffer "*Completions*"
(display-completion-list completions))
- (message "Hit space to flush")
+ (minibuffer-message "Hit space to flush")
(let (event)
(prog1
(catch 'done
(if (not pcomplete-ignore-case)
(insert-and-inherit (if raw-p
(substring entry (length stub))
- (pcomplete-quote-argument
+ (comint-quote-filename
(substring entry (length stub)))))
;; the stub is not quoted at this time, so to determine the
;; length of what should be in the buffer, we must quote it
;; FIXME: Here we presume that quoting `stub' gives us the exact
;; text in the buffer before point, which is not guaranteed;
;; e.g. it is not the case in eshell when completing ${FOO}tm[TAB].
- (delete-char (- (length (pcomplete-quote-argument stub))))
+ (delete-char (- (length (comint-quote-filename stub))))
;; if there is already a backslash present to handle the first
;; character, don't bother quoting it
(when (eq (char-before) ?\\)
(setq entry (substring entry 1)))
(insert-and-inherit (if raw-p
entry
- (pcomplete-quote-argument entry))))
+ (comint-quote-filename entry))))
(let (space-added)
(when (and (not (memq (char-before) pcomplete-suffix-list))
addsuffix)
pcomplete-last-completion-stub stub)
space-added)))
-;; selection of completions
+;; Selection of completions.
(defun pcomplete-do-complete (stub completions)
"Dynamically complete at point using STUB and COMPLETIONS.
;; general utilities
-(defun pcomplete-pare-list (l r &optional pred)
- "Destructively remove from list L all elements matching any in list R.
-Test is done using `equal'.
-If PRED is non-nil, it is a function used for further removal.
-Returns the resultant list."
- (while (and l (or (and r (member (car l) r))
- (and pred
- (funcall pred (car l)))))
- (setq l (cdr l)))
- (let ((m l))
- (while m
- (while (and (cdr m)
- (or (and r (member (cadr m) r))
- (and pred
- (funcall pred (cadr m)))))
- (setcdr m (cddr m)))
- (setq m (cdr m))))
- l)
-
(defun pcomplete-uniqify-list (l)
"Sort and remove multiples in L."
(setq l (sort l 'string-lessp))
HCoop / bpt / emacs.git / blobdiff