;;; User Functions:
-;;;###autoload
-(defun pcomplete (&optional interactively)
- "Support extensible programmable completion.
-To use this function, just bind the TAB key to it, or add it to your
-completion functions list (it should occur fairly early in the list)."
- (interactive "p")
- (if (and interactively
- pcomplete-cycle-completions
- pcomplete-current-completions
- (memq last-command '(pcomplete
- pcomplete-expand-and-complete
- pcomplete-reverse)))
- (progn
- (delete-backward-char pcomplete-last-completion-length)
- (if (eq this-command 'pcomplete-reverse)
- (progn
- (setq pcomplete-current-completions
- (cons (car (last pcomplete-current-completions))
- pcomplete-current-completions))
- (setcdr (last pcomplete-current-completions 2) nil))
- (nconc pcomplete-current-completions
- (list (car pcomplete-current-completions)))
- (setq pcomplete-current-completions
- (cdr pcomplete-current-completions)))
- (pcomplete-insert-entry pcomplete-last-completion-stub
- (car pcomplete-current-completions)
- nil pcomplete-last-completion-raw))
- (setq pcomplete-current-completions nil
- pcomplete-last-completion-raw nil)
- (catch 'pcompleted
- (let* ((pcomplete-stub)
- pcomplete-seen pcomplete-norm-func
- pcomplete-args pcomplete-last pcomplete-index
- (pcomplete-autolist pcomplete-autolist)
- (pcomplete-suffix-list pcomplete-suffix-list)
- (completions (pcomplete-completions))
- (result (pcomplete-do-complete pcomplete-stub completions)))
- (and result
- (not (eq (car result) 'listed))
- (cdr result)
- (pcomplete-insert-entry pcomplete-stub (cdr result)
- (memq (car result)
- '(sole shortest))
- pcomplete-last-completion-raw))))))
+;;; Alternative front-end using the standard completion facilities.
+
+;; The way pcomplete-parse-arguments, pcomplete-stub, and
+;; pcomplete-quote-argument work only works because of some deep
+;; hypothesis about the way the completion work. Basically, it makes
+;; 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.
+
+(defvar pcomplete-unquote-argument-function nil)
+
+(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))))
-(defun pcomplete-common-suffix (s1 s2)
+(defun pcomplete--common-suffix (s1 s2)
(assert (not (or (string-match "\n" s1) (string-match "\n" s2))))
- (let ((case-fold-search pcomplete-ignore-case))
+ ;; 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))
(- (match-end 1) (match-beginning 1))))
-(defun pcomplete-table-subvert (table s1 s2 string pred action)
+(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 (substring string (length s1)))))
+ (concat s2 (pcomplete-unquote-argument
+ (substring string (length s1))))))
(res (if str (complete-with-action action table str pred))))
(when res
(cond
(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 (substring res (length s2)))))
+ (concat s1 (pcomplete-quote-argument
+ (substring res (length s2))))))
((eq action t)
(let ((bounds (completion-boundaries str table pred "")))
(if (>= (car bounds) (length s2))
(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-std-complete ()
"Provide standard completion using pcomplete's completion tables.
Same as `pcomplete' but using the standard completion UI."
(interactive)
- ;; FIXME: it fails to unquote/requote the arguments.
;; FIXME: it doesn't implement paring.
- ;; FIXME: when we bring up *Completions* we never bring it back down.
(catch 'pcompleted
(let* ((pcomplete-stub)
pcomplete-seen pcomplete-norm-func
;; 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 pcomplete--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))
- ;; Rather than `point-min' we should use the
- ;; beginning position of the current arg.
- (point-min)))
+ (pcomplete-begin)))
(buftext (buffer-substring beg (point)))
- ;; 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).
- (suflen (pcomplete-common-suffix pcomplete-stub buftext)))
- (unless (= suflen (length pcomplete-stub))
- (setq completions
- (apply-partially
- 'pcomplete-table-subvert
- completions
- (substring buftext 0 (- (length buftext) suflen))
- (substring pcomplete-stub
- 0 (- (length pcomplete-stub) suflen)))))
+ (table
+ (if (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
+ completions
+ (cdr prefixes) (car prefixes)))
+ (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)))))))
+
(let ((ol (make-overlay beg (point) nil nil t))
(minibuffer-completion-table
;; Add a space at the end of completion. Use a terminator-regexp
;; that never matches since the terminator cannot appear
;; within the completion field anyway.
(if (zerop (length pcomplete-termination-string))
- completions
+ table
(apply-partially 'completion-table-with-terminator
(cons pcomplete-termination-string
"\\`a\\`")
- completions)))
+ table)))
(minibuffer-completion-predicate nil))
(overlay-put ol 'field 'pcomplete)
(unwind-protect
(call-interactively 'minibuffer-complete)
(delete-overlay ol))))))
+;;; Pcomplete's native UI.
+
+;;;###autoload
+(defun pcomplete (&optional interactively)
+ "Support extensible programmable completion.
+To use this function, just bind the TAB key to it, or add it to your
+completion functions list (it should occur fairly early in the list)."
+ (interactive "p")
+ (if (and interactively
+ pcomplete-cycle-completions
+ pcomplete-current-completions
+ (memq last-command '(pcomplete
+ pcomplete-expand-and-complete
+ pcomplete-reverse)))
+ (progn
+ (delete-backward-char pcomplete-last-completion-length)
+ (if (eq this-command 'pcomplete-reverse)
+ (progn
+ (setq pcomplete-current-completions
+ (cons (car (last pcomplete-current-completions))
+ pcomplete-current-completions))
+ (setcdr (last pcomplete-current-completions 2) nil))
+ (nconc pcomplete-current-completions
+ (list (car pcomplete-current-completions)))
+ (setq pcomplete-current-completions
+ (cdr pcomplete-current-completions)))
+ (pcomplete-insert-entry pcomplete-last-completion-stub
+ (car pcomplete-current-completions)
+ nil pcomplete-last-completion-raw))
+ (setq pcomplete-current-completions nil
+ pcomplete-last-completion-raw nil)
+ (catch 'pcompleted
+ (let* ((pcomplete-stub)
+ pcomplete-seen pcomplete-norm-func
+ pcomplete-args pcomplete-last pcomplete-index
+ (pcomplete-autolist pcomplete-autolist)
+ (pcomplete-suffix-list pcomplete-suffix-list)
+ (completions (pcomplete-completions))
+ (result (pcomplete-do-complete pcomplete-stub completions)))
+ (and result
+ (not (eq (car result) 'listed))
+ (cdr result)
+ (pcomplete-insert-entry pcomplete-stub (cdr result)
+ (memq (car result)
+ '(sole shortest))
+ pcomplete-last-completion-raw))))))
+
;;;###autoload
(defun pcomplete-reverse ()
"If cycling completion is in use, cycle backwards."
;;;###autoload
(defun pcomplete-shell-setup ()
"Setup `shell-mode' to use pcomplete."
+ ;; FIXME: insufficient
(pcomplete-comint-setup 'comint-dynamic-complete-functions))
(declare-function comint-bol "comint" (&optional arg))
Magic characters are those in `pcomplete-arg-quote-list'."
(if (null pcomplete-arg-quote-list)
filename
- (let ((len (length filename))
- (index 0)
- (result "")
- replacement char)
- (while (< index len)
- (setq replacement (run-hook-with-args-until-success
- 'pcomplete-quote-arg-hook filename index))
- (cond
- (replacement
- (setq result (concat result replacement)))
- ((memq (setq char (aref filename index))
- pcomplete-arg-quote-list)
- (setq result (concat result (string "\\" char))))
- (t
- (setq result (concat result (char-to-string char)))))
- (setq index (1+ index)))
- result)))
+ (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
+ ""))))
;; file-system completion lists
\(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: obey pcomplete-file-ignore and pcomplete-dir-ignore.
+ ;; FIXME: obey pcomplete-compare-entry-function (tho only if there
+ ;; are less than pcomplete-cycle-cutoff-length completions).
+ ;; FIXME: expand envvars? shouldn't this be done globally instead?
+ (let* ((reg-pred (when regexp
+ (lexical-let ((re regexp))
+ (lambda (f)
+ ;; (let ((name (file-name-nondirectory f)))
+ ;; (if (zerop (length name))
+ ;; (setq name (file-name-as-directory
+ ;; (file-name-nondirectory
+ ;; (directory-file-name f)))))
+ ;; (string-match re name))
+ (string-match re f)))))
+ (pred (cond
+ ((null predicate) reg-pred)
+ ((null reg-pred) predicate)
+ (t (lexical-let ((predicate predicate)
+ (reg-pred reg-pred))
+ (lambda (f)
+ (and (funcall predicate f)
+ (funcall reg-pred f)))))))
+ (fun
+ (lexical-let ((pred pred)
+ (dir default-directory))
+ (lambda (s p a)
+ ;; Remember the default-directory that was active when we built
+ ;; the completion table.
+ (let ((default-directory dir)
+ ;; The old code used only file-name-all-completions
+ ;; which ignores completion-ignored-extensions.
+ (completion-ignored-extensions nil))
+ (completion-table-with-predicate
+ 'completion-file-name-table pred 'strict s p a)))))
+ ;; Indirect through a symbol rather than returning a lambda
+ ;; expression, so as to help catch bugs where the caller
+ ;; might treat the lambda expression as a list of completions.
+ (sym (make-symbol "pcomplete-read-file-name-internal")))
+ (fset sym fun)
+ sym))
(defsubst pcomplete-all-entries (&optional regexp predicate)
"Like `pcomplete-entries', but doesn't ignore any entries."
projects / emacs.git / commitdiff