Mercurial > emacs
changeset 105762:5f2c736569a0
(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.
| author | Stefan Monnier <monnier@iro.umontreal.ca> |
|---|---|
| date | Sun, 25 Oct 2009 20:38:06 +0000 |
| parents | 2a4b89270020 |
| children | 5041ae86859e |
| files | lisp/ChangeLog lisp/pcomplete.el |
| diffstat | 2 files changed, 226 insertions(+), 185 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Oct 25 18:09:57 2009 +0000 +++ b/lisp/ChangeLog Sun Oct 25 20:38:06 2009 +0000 @@ -1,5 +1,12 @@ 2009-10-25 Stefan Monnier <monnier@iro.umontreal.ca> + * 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.
--- a/lisp/pcomplete.el Sun Oct 25 18:09:57 2009 +0000 +++ b/lisp/pcomplete.el Sun Oct 25 20:38:06 2009 +0000 @@ -351,6 +351,173 @@ ;;; User Functions: +;;; 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) + (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)) + (- (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-std-complete () + "Provide standard completion using pcomplete's completion tables. +Same as `pcomplete' but using the standard completion UI." + (interactive) + ;; FIXME: it doesn't implement paring. + (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) + ;; Apparently the vars above are global vars modified by + ;; side-effects, whereas pcomplete-completions is the core + ;; function that finds the chunk of text to complete + ;; (returned indirectly in pcomplete-stub) and the set of + ;; possible completions. + (completions (pcomplete-completions)) + ;; Usually there's some close connection between pcomplete-stub + ;; and the text before point. But depending on what + ;; pcomplete-parse-arguments-function does, that connection + ;; might not be that close. E.g. in eshell, + ;; pcomplete-parse-arguments-function expands envvars. + ;; + ;; Since we use minibuffer-complete, which doesn't know + ;; 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 + ;; 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))) + (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)) + table + (apply-partially 'completion-table-with-terminator + (cons pcomplete-termination-string + "\\`a\\`") + 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. @@ -396,115 +563,6 @@ '(sole shortest)) pcomplete-last-completion-raw)))))) -(defun pcomplete-common-suffix (s1 s2) - (assert (not (or (string-match "\n" s1) (string-match "\n" s2)))) - (let ((case-fold-search 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) - "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))))) - (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) - (+ 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))))) - ((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)))))))))) - - -(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-args pcomplete-last pcomplete-index - (pcomplete-autolist pcomplete-autolist) - (pcomplete-suffix-list pcomplete-suffix-list) - ;; Apparently the vars above are global vars modified by - ;; side-effects, whereas pcomplete-completions is the core - ;; function that finds the chunk of text to complete - ;; (returned indirectly in pcomplete-stub) and the set of - ;; possible completions. - (completions (pcomplete-completions)) - ;; Usually there's some close connection between pcomplete-stub - ;; and the text before point. But depending on what - ;; pcomplete-parse-arguments-function does, that connection - ;; might not be that close. E.g. in eshell, - ;; pcomplete-parse-arguments-function expands envvars. - ;; - ;; Since we use minibuffer-complete, which doesn't know - ;; 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 - ;; 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))) - (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))))) - (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 - (apply-partially 'completion-table-with-terminator - (cons pcomplete-termination-string - "\\`a\\`") - completions))) - (minibuffer-completion-predicate nil)) - (overlay-put ol 'field 'pcomplete) - (unwind-protect - (call-interactively 'minibuffer-complete) - (delete-overlay ol)))))) - ;;;###autoload (defun pcomplete-reverse () "If cycling completion is in use, cycle backwards." @@ -713,6 +771,7 @@ ;;;###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 @@ 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 @@ \(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."