From 2d0853070d1353348e6ef067b138d971cf52f341 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 25 Oct 2009 20:38:06 +0000 Subject: [PATCH] (pcomplete-unquote-argument-function): New var. (pcomplete-unquote-argument): New function. (pcomplete--common-suffix): Always pay attention to case. (pcomplete--table-subvert): Quote and unquote the text. (pcomplete--common-quoted-suffix): New function. (pcomplete-std-complete): Use it and pcomplete-begin. --- lisp/ChangeLog | 7 + lisp/pcomplete.el | 330 +++++++++++++++++++++++++--------------------- 2 files changed, 189 insertions(+), 148 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c6a8287942c..0ff59e4ef35 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,12 @@ 2009-10-25 Stefan Monnier + * pcomplete.el (pcomplete-unquote-argument-function): New var. + (pcomplete-unquote-argument): New function. + (pcomplete--common-suffix): Always pay attention to case. + (pcomplete--table-subvert): Quote and unquote the text. + (pcomplete--common-quoted-suffix): New function. + (pcomplete-std-complete): Use it and pcomplete-begin. + * bookmark.el (bookmark-bmenu-list): Don't use switch-to-buffer if we're inside a dedicated or minibuffer window. diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index f23b219e1e1..371b61eea1b 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -351,65 +351,69 @@ modified to be an empty string, or the desired separation string." ;;; 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 @@ -417,12 +421,14 @@ in the same way as TABLE completes strings of the form (concat S2 S)." (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)) @@ -435,14 +441,14 @@ in the same way as TABLE completes strings of the form (concat S2 S)." (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 @@ -465,46 +471,98 @@ 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 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." @@ -713,6 +771,7 @@ this is `comint-dynamic-complete-functions'." ;;;###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)) @@ -789,23 +848,17 @@ this is `comint-dynamic-complete-functions'." 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 @@ -829,65 +882,46 @@ If PREDICATE is non-nil, it will also be used to refine the match \(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." -- 2.39.5