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."