* lisp/minibuffer.el (complete-with-action): Return nil for the metadata and

boundaries of non-functional tables.
(completion-table-dynamic): Return nil for the metadata.
(completion-table-with-terminator): Add default case, using
complete-with-action.
(completion--metadata): New function.
(completion-all-sorted-completions, minibuffer-completion-help): Use it
to try and avoid pathological performance problems.
(completion--embedded-envvar-table): Return `category' metadata.

2 files changed, 72 insertions, 39 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 384a30cb7cd..8f96a838cc5 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,15 @@
+2011-05-31  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * minibuffer.el (complete-with-action): Return nil for the metadata and
+        boundaries of non-functional tables.
+        (completion-table-dynamic): Return nil for the metadata.
+        (completion-table-with-terminator): Add default case, using
+        complete-with-action.
+        (completion--metadata): New function.
+        (completion-all-sorted-completions, minibuffer-completion-help): Use it
+        to try and avoid pathological performance problems.
+        (completion--embedded-envvar-table): Return `category' metadata.
+
 2011-05-31  Lars Magne Ingebrigtsen  <larsi@gnus.org>
 
         * subr.el (process-alive-p): New tiny convenience function.
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el
index 0f96f7905eb..972c65f62e3 100644
--- a/lisp/minibuffer.el
+++ b/lisp/minibuffer.el
@@ -26,11 +26,15 @@
 ;; internal use only.
 
 ;; Functional completion tables have an extended calling conventions:
-;; - The `action' can be (additionally to nil, t, and lambda) of the form
-;;   (boundaries . SUFFIX) in which case it should return
+;; The `action' can be (additionally to nil, t, and lambda) of the form
+;; - (boundaries . SUFFIX) in which case it should return
 ;;   (boundaries START . END).  See `completion-boundaries'.
 ;;   Any other return value should be ignored (so we ignore values returned
 ;;   from completion tables that don't know about this new `action' form).
+;; - `metadata' in which case it should return (metadata . ALIST) where
+;;   ALIST is the metadata of this table.  See `completion-metadata'.
+;;   Any other return value should be ignored (so we ignore values returned
+;;   from completion tables that don't know about this new `action' form).
 
 ;;; Bugs:
 
@@ -107,7 +111,8 @@ E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
 and for file names the result is the positions delimited by
 the closest directory separators."
   (let ((boundaries (if (functionp table)
-                        (funcall table string pred (cons 'boundaries suffix)))))
+                        (funcall table string pred
+                                 (cons 'boundaries suffix)))))
     (if (not (eq (car-safe boundaries) 'boundaries))
         (setq boundaries nil))
     (cons (or (cadr boundaries) 0)
@@ -125,7 +130,8 @@ This metadata is an alist.  Currently understood keys are:
    Takes one argument (COMPLETIONS) and should return a new list
    of completions.  Can operate destructively.
 - `cycle-sort-function': function to sort entries when cycling.
-   Works like `display-sort-function'."
+   Works like `display-sort-function'.
+The metadata of a completion table should be constant between two boundaries."
   (let ((metadata (if (functionp table)
                       (funcall table string pred 'metadata))))
     (if (eq (car-safe metadata) 'metadata)
@@ -160,8 +166,8 @@ PRED is a completion predicate.
 ACTION can be one of nil, t or `lambda'."
   (cond
    ((functionp table) (funcall table string pred action))
-   ((eq (car-safe action) 'boundaries)
-    (cons 'boundaries (completion-boundaries string table pred (cdr action))))
+   ((eq (car-safe action) 'boundaries) nil)
+   ((eq action 'metadata) nil)
    (t
     (funcall
      (cond
@@ -182,7 +188,7 @@ The result of the `completion-table-dynamic' form is a function
 that can be used as the COLLECTION argument to `try-completion' and
 `all-completions'.  See Info node `(elisp)Programmed Completion'."
   (lambda (string pred action)
-    (if (eq (car-safe action) 'boundaries)
+    (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
         ;; `fun' is not supposed to return another function but a plain old
         ;; completion table, whose boundaries are always trivial.
         nil
@@ -287,18 +293,18 @@ instead of a string, a function that takes the completion and returns the
                 (funcall terminator comp)
               (concat comp terminator))
           comp))))
-   ((eq action t)
+   ;; completion-table-with-terminator is always used for
+   ;; "sub-completions" so it's only called if the terminator is missing,
+   ;; in which case `test-completion' should return nil.
+   ((eq action 'lambda) nil)
+   (t
     ;; FIXME: We generally want the `try' and `all' behaviors to be
     ;; consistent so pcm can merge the `all' output to get the `try' output,
     ;; but that sometimes clashes with the need for `all' output to look
     ;; good in *Completions*.
     ;; (mapcar (lambda (s) (concat s terminator))
     ;;         (all-completions string table pred))))
-    (all-completions string table pred))
-   ;; completion-table-with-terminator is always used for
-   ;; "sub-completions" so it's only called if the terminator is missing,
-   ;; in which case `test-completion' should return nil.
-   ((eq action 'lambda) nil)))
+    (complete-with-action action table string pred))))
 
 (defun completion-table-with-predicate (table pred1 strict string pred2 action)
   "Make a completion table equivalent to TABLE but filtered through PRED1.
@@ -769,22 +775,33 @@ scroll the window of possible completions."
   (setq completion-cycling nil)
   (setq completion-all-sorted-completions nil))
 
+(defun completion--metadata (string base md-at-point table pred)
+  ;; Like completion-metadata, but for the specific case of getting the
+  ;; metadata at `base', which tends to trigger pathological behavior for old
+  ;; completion tables which don't understand `metadata'.
+  (let ((bounds (completion-boundaries string table pred "")))
+    (if (eq (car bounds) base) md-at-point
+      (completion-metadata (substring string 0 base) table pred))))
+
 (defun completion-all-sorted-completions ()
   (or completion-all-sorted-completions
       (let* ((start (field-beginning))
              (end (field-end))
              (string (buffer-substring start end))
+             (md (completion--field-metadata start))
              (all (completion-all-completions
                    string
                    minibuffer-completion-table
                    minibuffer-completion-predicate
                    (- (point) start)
-                   (completion--field-metadata start)))
+                   md))
              (last (last all))
              (base-size (or (cdr last) 0))
-             (all-md (completion-metadata (substring string 0 base-size)
-                                          minibuffer-completion-table
-                                          minibuffer-completion-predicate))
+             (all-md (completion--metadata (buffer-substring-no-properties
+                                            start (point))
+                                           base-size md
+                                           minibuffer-completion-table
+                                           minibuffer-completion-predicate))
              (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
         (when last
           (setcdr last nil)
@@ -1272,12 +1289,13 @@ variables.")
   (let* ((start (field-beginning))
          (end (field-end))
          (string (field-string))
+         (md (completion--field-metadata start))
          (completions (completion-all-completions
                        string
                        minibuffer-completion-table
                        minibuffer-completion-predicate
                        (- (point) (field-beginning))
-                       (completion--field-metadata start))))
+                       md)))
     (message nil)
     (if (or (null completions)
             (and (not (consp (cdr completions)))
@@ -1293,12 +1311,11 @@ variables.")
       (let* ((last (last completions))
              (base-size (cdr last))
              (prefix (unless (zerop base-size) (substring string 0 base-size)))
-             ;; FIXME: This function is for the output of all-completions,
-             ;; not completion-all-completions.  Often it's the same, but
-             ;; not always.
-             (all-md (completion-metadata (substring string 0 base-size)
-                                          minibuffer-completion-table
-                                          minibuffer-completion-predicate))
+             (all-md (completion--metadata (buffer-substring-no-properties
+                                            start (point))
+                                           base-size md
+                                           minibuffer-completion-table
+                                           minibuffer-completion-predicate))
              (afun (or (completion-metadata-get all-md 'annotation-function)
                        (plist-get completion-extra-properties
                                   :annotation-function)
@@ -1673,8 +1690,8 @@ same as `substitute-in-file-name'."
         ;; other table that provides the "main" completion.  Let the
         ;; other table handle the test-completion case.
         nil)
-       ((eq (car-safe action) 'boundaries)
-        ;; Only return boundaries if there's something to complete,
+       ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
+        ;; Only return boundaries/metadata if there's something to complete,
         ;; since otherwise when we're used in
         ;; completion-table-in-turn, we could return boundaries and
         ;; let some subsequent table return a list of completions.
@@ -1684,11 +1701,13 @@ same as `substitute-in-file-name'."
         (when (try-completion (substring string beg) table nil)
           ;; Compute the boundaries of the subfield to which this
           ;; completion applies.
-          (let ((suffix (cdr action)))
-            (list* 'boundaries
-                   (or (match-beginning 2) (match-beginning 1))
-                   (when (string-match "[^[:alnum:]_]" suffix)
-                     (match-beginning 0))))))
+          (if (eq action 'metadata)
+              '(metadata (category . environment-variable))
+            (let ((suffix (cdr action)))
+              (list* 'boundaries
+                     (or (match-beginning 2) (match-beginning 1))
+                     (when (string-match "[^[:alnum:]_]" suffix)
+                       (match-beginning 0)))))))
        (t
         (if (eq (aref string (1- beg)) ?{)
             (setq table (apply-partially 'completion-table-with-terminator
@@ -2299,7 +2318,8 @@ PATTERN is as returned by `completion-pcm--string->pattern'."
            (case-fold-search completion-ignore-case)
            (completion-regexp-list (cons regex completion-regexp-list))
            (compl (all-completions
-                   (concat prefix (if (stringp (car pattern)) (car pattern) ""))
+                   (concat prefix
+                           (if (stringp (car pattern)) (car pattern) ""))
                    table pred)))
       (if (not (functionp table))
           ;; The internal functions already obeyed completion-regexp-list.
@@ -2397,13 +2417,14 @@ filter out additional entries (because TABLE migth not obey PRED)."
                                    (- (length newbeforepoint)
                                       (car newbounds)))))
                   (dolist (submatch suball)
-                    (setq all (nconc (mapcar
-                                      (lambda (s) (concat submatch between s))
-                                      (funcall filter
-                                               (completion-pcm--all-completions
-                                                (concat subprefix submatch between)
-                                                pattern table pred)))
-                                     all)))
+                    (setq all (nconc
+                               (mapcar
+                                (lambda (s) (concat submatch between s))
+                                (funcall filter
+                                         (completion-pcm--all-completions
+                                          (concat subprefix submatch between)
+                                          pattern table pred)))
+                               all)))
                   ;; FIXME: This can come in handy for try-completion,
                   ;; but isn't right for all-completions, since it lists
                   ;; invalid completions.