master 268e055e051: Limit VC-Dir status process output processing

branch: master
commit 268e055e0515ccec8159b13d4b2e97428bd63b5e
Author: Sean Whitton <[email protected]>
Commit: Sean Whitton <[email protected]>

    Limit VC-Dir status process output processing
    
    * lisp/emacs-lisp/ewoc.el (ewoc--set-buffer-bind-dll-let*): New
    debug declaration.
    (ewoc-set-hf): Make it possible to set only the header or
    footer.
    * lisp/vc/vc-dir.el (vc-dir--set-header): New RESET-FOOTER
    parameter.
    (vc-dir-refresh): Pass it.
    (vc-dir-process-output-limit): New variable.
    (vc-dir-show-more-button)
    (vc-dir-maybe-narrow-and-show-more-button): New functions.
    * lisp/vc/vc-bzr.el (vc-bzr-dir-status-files):
    * lisp/vc/vc-cvs.el (vc-cvs-dir-status-files):
    * lisp/vc/vc-git.el (vc-git-dir-status-goto-stage):
    * lisp/vc/vc-hg.el (vc-hg-dir-status-files):
    * lisp/vc/vc-svn.el (vc-svn-dir-status-files): Preserve a
    binding of vc-dir-process-output-limit in the delayed process.
    Call vc-dir-maybe-narrow-and-show-more-button.
    * lisp/vc/vc.el (dir-status-files):
    * etc/NEWS: Document the change.
---
 etc/NEWS                | 11 ++++++++++
 lisp/emacs-lisp/ewoc.el | 17 ++++++++++-----
 lisp/vc/vc-bzr.el       | 35 ++++++++++++++++++------------
 lisp/vc/vc-cvs.el       | 11 ++++++++--
 lisp/vc/vc-dir.el       | 57 ++++++++++++++++++++++++++++++++++++++++++++++---
 lisp/vc/vc-git.el       | 11 ++++++++--
 lisp/vc/vc-hg.el        | 14 ++++++++----
 lisp/vc/vc-src.el       |  1 +
 lisp/vc/vc-svn.el       | 20 +++++++++++------
 lisp/vc/vc.el           |  4 +++-
 10 files changed, 144 insertions(+), 37 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index c4e02890bbb..1537464d653 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -121,6 +121,17 @@ obsolete.
 To hide these, you can customize the new user option
 'vc-dir-show-key-binding-hints' to nil.
 
+---
+*** VC-Dir doesn't process very large status output by default.
+If the VCS status process used to populate the VC-Dir buffer produces a
+very large amount of output, it often means that you did something
+accidental like renaming a subdirectory containing thousands of files,
+and Emacs can become unresponsive while trying to process all the
+output.  Now Emacs stops early.  When this happens, VC-Dir includes a
+message saying so, with a button to override it.  You can customize the
+new user option 'vc-dir-process-output-limit' to control how early to
+stop, and to disable this feature.
+
 ** Outline mode
 
 *** New command 'outline-show-entry-and-parents'.
diff --git a/lisp/emacs-lisp/ewoc.el b/lisp/emacs-lisp/ewoc.el
index 387e5d3be5e..118b66eb15f 100644
--- a/lisp/emacs-lisp/ewoc.el
+++ b/lisp/emacs-lisp/ewoc.el
@@ -152,6 +152,7 @@ and (ewoc--node-nth dll -1) returns the last node."
 `dll' will be bound when VARLIST is initialized, but
 the current buffer will *not* have been changed.
 Return value of last form in FORMS."
+  (declare (debug (form let)))
   (let ((hnd (make-symbol "ewoc")))
     `(let* ((,hnd ,ewoc)
             (dll (ewoc--dll ,hnd))
@@ -568,15 +569,21 @@ Return nil if the buffer has been deleted."
 	(ewoc--node-data (ewoc--footer ewoc))))
 
 (defun ewoc-set-hf (ewoc header footer)
-  "Set the HEADER and FOOTER of EWOC."
+  "Set the HEADER and/or FOOTER of EWOC.
+To change only the header (respectively footer), pass nil for
+FOOTER (respectively HEADER).
+To clear the header (respectively footer), pass an empty string for
+HEADER (respectively FOOTER)."
   (ewoc--set-buffer-bind-dll-let* ewoc
       ((head (ewoc--header ewoc))
        (foot (ewoc--footer ewoc))
        (hf-pp (ewoc--hf-pp ewoc)))
-    (setf (ewoc--node-data head) header
-          (ewoc--node-data foot) footer)
-    (ewoc--refresh-node hf-pp head dll)
-    (ewoc--refresh-node hf-pp foot dll)))
+    (when header
+      (setf (ewoc--node-data head) header)
+      (ewoc--refresh-node hf-pp head dll))
+    (when footer
+      (setf (ewoc--node-data foot) footer)
+      (ewoc--refresh-node hf-pp foot dll))))
 
 
 (provide 'ewoc)
diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el
index 3cf9b107913..a8ba9b17172 100644
--- a/lisp/vc/vc-bzr.el
+++ b/lisp/vc/vc-bzr.el
@@ -1030,22 +1030,29 @@ stream.  Standard error output is discarded."
         (forward-line))
       (funcall update-function result)))
 
+(declare-function vc-dir-maybe-narrow-and-show-more-button "vc-dir")
+
 (defun vc-bzr-dir-status-files (dir files update-function)
   "Return a list of conses (file . state) for DIR."
-  (set-process-query-on-exit-flag
-   (apply #'vc-bzr-command "status" (current-buffer) 'async dir "-v" "-S" files)
-   nil)
-  ;; FIXME: Consider `vc-run-delayed-success'.
-  (vc-run-delayed
-   (vc-bzr-after-dir-status update-function
-                            ;; "bzr status" results are relative to
-                            ;; the bzr root directory, NOT to the
-                            ;; directory "bzr status" was invoked in.
-                            ;; Ugh.
-                            ;; We pass the relative directory here so
-                            ;; that `vc-bzr-after-dir-status' can
-                            ;; frob the results accordingly.
-                            (file-relative-name dir (vc-bzr-root dir)))))
+  (require 'vc-dir)
+  (let ((limit vc-dir-process-output-limit))
+    (set-process-query-on-exit-flag
+     (apply #'vc-bzr-command "status" (current-buffer) 'async dir
+            "-v" "-S" files)
+     nil)
+    ;; FIXME: Consider `vc-run-delayed-success'.
+    (vc-run-delayed
+      (let ((vc-dir-process-output-limit limit))
+        (vc-dir-maybe-narrow-and-show-more-button)
+        (vc-bzr-after-dir-status update-function
+                                 ;; "bzr status" results are relative to
+                                 ;; the bzr root directory, NOT to the
+                                 ;; directory "bzr status" was invoked in.
+                                 ;; Ugh.
+                                 ;; We pass the relative directory here so
+                                 ;; that `vc-bzr-after-dir-status' can
+                                 ;; frob the results accordingly.
+                                 (file-relative-name dir (vc-bzr-root dir)))))))
 
 (defvar-keymap vc-bzr-shelve-map
   ;; Turn off vc-dir marking
diff --git a/lisp/vc/vc-cvs.el b/lisp/vc/vc-cvs.el
index 293ebcca3e2..e5fc68ea25e 100644
--- a/lisp/vc/vc-cvs.el
+++ b/lisp/vc/vc-cvs.el
@@ -1077,10 +1077,15 @@ state."
     (if basedir result
       (funcall update-function result))))
 
+(declare-function vc-dir-maybe-narrow-and-show-more-button "vc-dir")
+(defvar vc-dir-process-output-limit)
+
 (defun vc-cvs-dir-status-files (dir files update-function)
   "Create a list of conses (file . state) for FILES in DIR.
 Query all files in DIR if files is nil."
-  (let ((local (vc-cvs-stay-local-p dir)))
+  (require 'vc-dir)
+  (let ((local (vc-cvs-stay-local-p dir))
+        (limit vc-dir-process-output-limit))
     (if (and (not files) local (not (eq local 'only-file)))
         (vc-cvs-dir-status-heuristic dir update-function))
     (set-process-query-on-exit-flag
@@ -1090,7 +1095,9 @@ Query all files in DIR if files is nil."
      nil)
     ;; FIXME: Consider `vc-run-delayed-success'.
     (vc-run-delayed
-      (vc-cvs-after-dir-status update-function))))
+      (let ((vc-dir-process-output-limit limit))
+        (vc-dir-maybe-narrow-and-show-more-button)
+        (vc-cvs-after-dir-status update-function)))))
 
 (defun vc-cvs-file-to-string (file)
   "Read the content of FILE and return it as a string."
diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el
index 189966e43f0..f0a922e6639 100644
--- a/lisp/vc/vc-dir.el
+++ b/lisp/vc/vc-dir.el
@@ -1632,8 +1632,10 @@ specific headers."
        "(\\[vc-dir-hide-up-to-date]) Hide up-to-date"))
      "\n"))))
 
-(defun vc-dir--set-header (def-dir)
-  (ewoc-set-hf vc-ewoc (vc-dir-headers vc-dir-backend def-dir) "")
+(defun vc-dir--set-header (def-dir &optional reset-footer)
+  (ewoc-set-hf vc-ewoc
+               (vc-dir-headers vc-dir-backend def-dir)
+               (and reset-footer ""))
   ;; Clear overlays in the header from the last run.
   (dolist (overlay (overlays-in (point-min)
                                 (length (car (ewoc-get-hf vc-ewoc)))))
@@ -1694,6 +1696,55 @@ specific headers."
   (when vc-dir-auto-hide-up-to-date
     (vc-dir-hide-state)))
 
+;; Assume that user normally has around 50 uncommitted files and the
+;; status output for each is approximately 60 characters long.
+(defcustom vc-dir-process-output-limit 3000
+  "Maximum output from VC-Dir status process to use, in characters.
+If non-nil, ignore status process output beyond this much.
+If nil, process all the status process's output.
+This is useful to prevent Emacs becoming unresponsive trying to process
+too much status output because, say, you accidentally renamed or deleted
+a subdirectory of your repository containing thousands of files."
+  :type 'natnum
+  :group 'vc
+  :version "32.1")
+
+(defun vc-dir-show-more-button (&optional text)
+  "Show a button to refresh VC-Dir with `vc-dir-process-output-limit' nil.
+TEXT is added to the EWOC footer on a line after the button.
+Called by VC backend `dir-status-files' implementations when the output
+to process exceeds a non-nil `vc-dir-process-output-limit'."
+  (ewoc-set-hf
+   vc-ewoc nil
+   (with-temp-buffer
+     (insert (substitute-quotes "\nHit `"))
+     (insert-text-button "vc-dir-process-output-limit"
+                         'type 'help-variable
+                         'help-args '(vc-dir-process-output-limit))
+     (insert (substitute-quotes "': "))
+     (insert-text-button
+      "run again with no limit"
+      'action (lambda (&rest _)
+                (let (vc-dir-process-output-limit)
+                  (vc-dir-refresh)))
+      'help-echo "Regenerate the VC-Dir buffer with no process output limit")
+     (when text (insert "\n" text))
+     (buffer-string))))
+
+(defun vc-dir-maybe-narrow-and-show-more-button (&optional text)
+  "Handle `vc-dir-process-output-limit' in `vc-dir-process-buffer'.
+TEXT is passed on to `vc-dir-show-more-button'.
+Called by VC backend `dir-status-files' implementations."
+  (when (and (natnump vc-dir-process-output-limit)
+             (> (buffer-size) vc-dir-process-output-limit))
+    (narrow-to-region (point-min)
+                      (save-excursion
+                        (goto-char (+ (point-min)
+                                      vc-dir-process-output-limit))
+                        (pos-bol)))
+    (with-current-buffer vc-parent-buffer
+      (vc-dir-show-more-button text))))
+
 (defun vc-dir-refresh ()
   "Refresh the contents of the *VC-Dir* buffer.
 Throw an error if another update process is in progress."
@@ -1718,7 +1769,7 @@ Throw an error if another update process is in progress."
                 vc-ewoc)
       ;; Bzr has serious locking problems, so setup the headers first (this is
       ;; mostly synchronous) rather than doing it while dir-status is running.
-      (vc-dir--set-header def-dir)
+      (vc-dir--set-header def-dir 'reset-footer)
       (let ((buffer (current-buffer)))
         (with-current-buffer vc-dir-process-buffer
           (setq default-directory def-dir)
diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el
index 83e624e618c..73b0df4d16b 100644
--- a/lisp/vc/vc-git.el
+++ b/lisp/vc/vc-git.el
@@ -722,14 +722,18 @@ or an empty string if none."
 ;; Follows vc-exec-after.
 (declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
 
+(declare-function vc-dir-maybe-narrow-and-show-more-button "vc-dir")
+
 (defun vc-git-dir-status-goto-stage (git-state)
   ;; TODO: Look into reimplementing this using `git status --porcelain=v2'.
+  (require 'vc-dir)
   (cl-flet ((git-cmd (&rest args)
               (set-process-query-on-exit-flag
                (apply #'vc-git-command (current-buffer) 'async args)
                nil)))
     (let ((files (vc-git-dir-status-state->files git-state))
-          (allowed-exit 1))
+          (allowed-exit 1)
+          (limit vc-dir-process-output-limit))
       (erase-buffer)
       (pcase (vc-git-dir-status-state->stage git-state)
         ('update-index
@@ -756,7 +760,10 @@ or an empty string if none."
         ('diff-index
          (git-cmd files "diff-index" "--relative" "-z" "-M" "HEAD" "--")))
       (vc-run-delayed-success allowed-exit
-        (vc-git-after-dir-status-stage git-state)))))
+        (let ((vc-dir-process-output-limit limit))
+          (vc-dir-maybe-narrow-and-show-more-button
+           "(reported states may be incorrect)")
+          (vc-git-after-dir-status-stage git-state))))))
 
 (defun vc-git-dir-status-files (_dir files update-function)
   "Return a list of (FILE STATE EXTRA) entries for DIR."
diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el
index a3ede6ad0ac..b3000534e7c 100644
--- a/lisp/vc/vc-hg.el
+++ b/lisp/vc/vc-hg.el
@@ -1528,6 +1528,8 @@ REV is the revision to check out into WORKFILE."
 ;; Follows vc-exec-after.
 (declare-function vc-set-async-update "vc-dispatcher" (process-buffer))
 
+(declare-function vc-dir-maybe-narrow-and-show-more-button "vc-dir")
+
 (defvar vc-hg--program-version nil)
 
 (defun vc-hg--program-version ()
@@ -1542,18 +1544,22 @@ REV is the revision to check out into WORKFILE."
                  (string-trim-right (match-string 1) "\\.")))))))
 
 (defun vc-hg-dir-status-files (dir files update-function)
+  (require 'vc-dir)
   ;; XXX: We can't pass DIR directly to 'hg status' because that
   ;; returns all ignored files if FILES is non-nil (bug#22481).
-  (let ((default-directory dir))
+  (let ((default-directory dir)
+        (limit vc-dir-process-output-limit))
     (set-process-query-on-exit-flag
      (apply #'vc-hg-command '(t nil) 'async files
             "status" (concat "-mardu" (if files "i")) "-C"
             (if (version<= "4.2" (vc-hg--program-version))
                 '("--config" "commands.status.relative=1")
               '("re:" "-I" ".")))
-     nil))
-  (vc-run-delayed-success 0
-    (vc-hg-after-dir-status update-function)))
+     nil)
+    (vc-run-delayed-success 0
+      (let ((vc-dir-process-output-limit limit))
+        (vc-dir-maybe-narrow-and-show-more-button)
+        (vc-hg-after-dir-status update-function)))))
 
 (defun vc-hg-dir-extra-headers (dir)
   "Generate extra status headers for a repository in DIR.
diff --git a/lisp/vc/vc-src.el b/lisp/vc/vc-src.el
index fbfbfa52228..6639f4e9f1e 100644
--- a/lisp/vc/vc-src.el
+++ b/lisp/vc/vc-src.el
@@ -176,6 +176,7 @@ For a description of possible values, see `vc-check-master-templates'."
 
 (autoload 'vc-expand-dirs "vc")
 
+;; FIXME: Respect `vc-dir-process-output-limit'.
 (defun vc-src-dir-status-files (dir files update-function)
   (let* ((result nil)
          (status nil)
diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el
index 2aacc9229e7..3639e697c4d 100644
--- a/lisp/vc/vc-svn.el
+++ b/lisp/vc/vc-svn.el
@@ -222,16 +222,24 @@ A value of `default' means to use the value of `vc-resolve-conflicts'."
 
 (autoload 'vc-expand-dirs "vc")
 
+(declare-function vc-dir-maybe-narrow-and-show-more-button "vc-dir")
+(defvar vc-dir-process-output-limit)
+
 (defun vc-svn-dir-status-files (_dir files callback)
   "Run \"svn status\" for DIR and update BUFFER via CALLBACK.
 CALLBACK is called as (CALLBACK RESULT BUFFER), where
 RESULT is a list of conses (FILE . STATE) for directory DIR."
-  ;; FIXME shouldn't this rather default to all the files in dir?
-  (set-process-query-on-exit-flag
-   (apply #'vc-svn-command (current-buffer) 'async nil "status" "-u" files)
-   nil)
-  ;; FIXME: Consider `vc-run-delayed-success'.
-  (vc-run-delayed (vc-svn-after-dir-status callback t)))
+  (require 'vc-dir)
+  (let ((limit vc-dir-process-output-limit))
+    ;; FIXME shouldn't this rather default to all the files in dir?
+    (set-process-query-on-exit-flag
+     (apply #'vc-svn-command (current-buffer) 'async nil "status" "-u" files)
+     nil)
+    ;; FIXME: Consider `vc-run-delayed-success'.
+    (vc-run-delayed
+      (let ((vc-dir-process-output-limit limit))
+        (vc-dir-maybe-narrow-and-show-more-button)
+        (vc-svn-after-dir-status callback t)))))
 
 (defun vc-svn-dir-extra-headers (_dir)
   "Generate extra status headers for a Subversion working copy."
diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el
index 734cea24113..ecfca3847f0 100644
--- a/lisp/vc/vc.el
+++ b/lisp/vc/vc.el
@@ -177,7 +177,9 @@
 ;;
 ;;   If a command needs to be run to compute this list, it should be
 ;;   run asynchronously using (current-buffer) as the buffer for the
-;;   command.
+;;   command.  It should respect `vc-dir-process-output-limit', usually
+;;   by calling `vc-dir-maybe-narrow-and-show-more-button' to narrow the
+;;   output buffer before processing it.
 ;;
 ;;   When RESULT is computed, it should be passed back by doing:
 ;;   (funcall UPDATE-FUNCTION RESULT nil).  If the backend uses a