bug#51037: [PATCH] Make `print-level` & `print-length` customizable in ERT batch tests

[Lars Ingebrigtsen <larsi@gnus.org>]

Lars Ingebrigtsen <larsi@gnus.org> writes:

> Michael <sp1ff@runbox.com> writes:
>
>> OK-- here's the revised patch.
>
> Thanks; applied to Emacs 29 (with some whitespace changes to make the
> lines less wide).

I spoke to soon -- we don't seem to have copyright assignment papers on
file?  Is that in the process of happening?

So here's the patch again with the whitespace tweaks while we wait for
that.  🤨

diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi
index 440c61add8..522b09dd61 100644
--- a/doc/misc/ert.texi
+++ b/doc/misc/ert.texi
@@ -390,6 +390,31 @@ Running Tests in Batch Mode
 emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log
 @end example
 
+@vindex ert-batch-print-level
+@vindex ert-batch-print-length
+ERT attempts to limit the output size for failed tests by choosing
+conservative values for @code{print-level} & @code{print-length}
+when printing Lisp values.  This can in some cases make it difficult
+to see which portions of those values are incorrect.  Use
+@code{ert-batch-print-level} and @code{ert-batch-print-length}
+to customize that:
+
+@example
+emacs -batch -l ert -l my-tests.el \
+      --eval "(let ((ert-batch-print-level 10) \
+                    (ert-batch-print-length 120)) \
+                (ert-run-tests-batch-and-exit))"
+@end example
+
+@vindex ert-batch-backtrace-line-length
+Even modest settings for @code{print-level} & @code{print-length} can
+produce extremely long lines in backtraces, however, with attendant
+pauses in execution progress. Set
+@code{ert-batch-backtrace-line-length} to t to use the value of
+@code{backtrace-line-length}, nil to stop any limitations on backtrace
+line lengths (i.e. to get full backtraces), or a positive integer to
+limit backtrace line length to that number.
+
 @vindex ert-quiet
 By default, ERT in batch mode is quite verbose, printing a line with
 result after each test.  This gives you progress information: how many
diff --git a/etc/NEWS b/etc/NEWS
index 312fc18f4f..ccae7a052c 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -54,6 +54,13 @@ This is in addition to previously-supported ways of discovering 24-bit
 color support: either via the "RGB" or "setf24" capabilities, or if
 the 'COLORTERM' environment variable is set to the value "truecolor".
 
++++
+** New ERT variables 'ert-batch-print-length' and 'ert-batch-print-level'.
+These variables will override 'print-length' and 'print-level' when
+printing Lisp values in ERT batch test results.
+
+** Emacs now supports Unicode Standard version 14.0.
+
 ** Emoji
 
 +++
diff --git a/lisp/emacs-lisp/backtrace.el b/lisp/emacs-lisp/backtrace.el
index a5721aa319..90201442f0 100644
--- a/lisp/emacs-lisp/backtrace.el
+++ b/lisp/emacs-lisp/backtrace.el
@@ -55,9 +55,9 @@ backtrace-fontify
 (defcustom backtrace-line-length 5000
   "Target length for lines in Backtrace buffers.
 Backtrace mode will attempt to abbreviate printing of backtrace
-frames to make them shorter than this, but success is not
-guaranteed.  If set to nil or zero, Backtrace mode will not
-abbreviate the forms it prints."
+frames by setting `print-level' & `print-length' to make them
+shorter than this, but success is not guaranteed.  If set to nil
+or zero, Backtrace mode will not abbreviate the forms it prints."
   :type 'integer
   :group 'backtrace
   :version "27.1")
@@ -751,6 +751,13 @@ backtrace--print-flags
     (insert (make-string (- backtrace--flags-width (- (point) beg)) ?\s))
     (put-text-property beg (point) 'backtrace-section 'func)))
 
+(defun backtrace--line-length-or-nil ()
+  "Return `backtrace-line-length' if valid, nil else."
+  ;; mirror the logic in `cl-print-to-string-with-limits'
+  (and (natnump backtrace-line-length)
+       (not (zerop backtrace-line-length))
+       backtrace-line-length))
+
 (defun backtrace--print-func-and-args (frame _view)
   "Print the function, arguments and buffer position of a backtrace FRAME.
 Format it according to VIEW."
@@ -769,11 +776,13 @@ backtrace--print-func-and-args
       (if (atom fun)
           (funcall backtrace-print-function fun)
         (insert
-         (backtrace--print-to-string fun (when args (/ backtrace-line-length 2)))))
+         (backtrace--print-to-string fun (when (and args (backtrace--line-length-or-nil)) (/ backtrace-line-length 2)))))
       (if args
           (insert (backtrace--print-to-string
-                   args (max (truncate (/ backtrace-line-length 5))
-                             (- backtrace-line-length (- (point) beg)))))
+                   args
+                   (if (backtrace--line-length-or-nil)
+                       (max (truncate (/ backtrace-line-length 5))
+                            (- backtrace-line-length (- (point) beg))))))
         ;; The backtrace-form property is so that backtrace-multi-line
         ;; will find it.  backtrace-multi-line doesn't do anything
         ;; useful with it, just being consistent.
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index 8ebc81fd41..5396cbbd5d 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -77,6 +77,37 @@ ert-batch-backtrace-right-margin
 Use nil for no limit (caution: backtrace lines can be very long)."
   :type '(choice (const :tag "No truncation" nil) integer))
 
+(defvar ert-batch-print-length 10
+  "`print-length' setting used in `ert-run-tests-batch'.
+
+When formatting lists in test conditions, `print-length' will be
+temporarily set to this value.  See also
+`ert-batch-backtrace-line-length' for its effect on stack
+traces.")
+
+(defvar ert-batch-print-level 5
+  "`print-level' setting used in `ert-run-tests-batch'.
+
+When formatting lists in test conditions, `print-level' will be
+temporarily set to this value.  See also
+`ert-batch-backtrace-line-length' for its effect on stack
+traces.")
+
+(defvar ert-batch-backtrace-line-length t
+  "Target length for lines in ERT batch backtraces.
+
+Even modest settings for `print-length' & `print-level' can
+produce extremely long lines in backtraces & lengthy delays in
+forming them.  This variable governs the target maximum line
+length by manipulating these two variables while printing stack
+traces.  Setting this variable to t will re-use the value of
+`backtrace-line-length' while print stack traces in ERT batch
+mode.  A value of nil will short-circuit this mechanism; line
+lengths will be completely determined by `ert-batch-line-length'
+& `ert-batch-line-level'.  Any other value will be temporarily
+bound to `backtrace-line-length' when producing stack traces
+in batch mode.")
+
 (defface ert-test-result-expected '((((class color) (background light))
                                      :background "green1")
                                     (((class color) (background dark))
@@ -1402,8 +1433,7 @@ ert-run-tests-batch
                                       (ert-reason-for-test-result result)
                                     ""))))
               (message "%s" "")))))
-       (test-started
-        )
+       (test-started)
        (test-ended
         (cl-destructuring-bind (stats test result) event-args
           (unless (ert-test-result-expected-p test result)
@@ -1413,8 +1443,19 @@ ert-run-tests-batch
               (ert-test-result-with-condition
                (message "Test %S backtrace:" (ert-test-name test))
                (with-temp-buffer
-                 (insert (backtrace-to-string
-                          (ert-test-result-with-condition-backtrace result)))
+                 (let ((backtrace-line-length
+                        (cond
+                         ((eq ert-batch-backtrace-line-length t)
+                          backtrace-line-length)
+                         ((eq ert-batch-backtrace-line-length nil)
+                          nil)
+                         (t
+                          ert-batch-backtrace-line-length)))
+                       (print-level ert-batch-print-level)
+                       (print-length ert-batch-print-length))
+                   (insert (backtrace-to-string
+                            (ert-test-result-with-condition-backtrace
+                             result))))
                  (if (not ert-batch-backtrace-right-margin)
                      (message "%s"
                               (buffer-substring-no-properties (point-min)
@@ -1433,8 +1474,8 @@ ert-run-tests-batch
                  (ert--insert-infos result)
                  (insert "    ")
                  (let ((print-escape-newlines t)
-                       (print-level 5)
-                       (print-length 10))
+                       (print-level ert-batch-print-level)
+                       (print-length ert-batch-print-length))
                    (ert--pp-with-indentation-and-newline
                     (ert-test-result-with-condition-condition result)))
                  (goto-char (1- (point-max)))
@@ -1962,13 +2003,13 @@ ert--results-font-lock-function
   (ewoc-refresh ert--results-ewoc)
   (font-lock-default-function enabledp))
 
-(defun ert--setup-results-buffer (stats listener buffer-name)
+(defvar ert--output-buffer-name "*ert*")
+
+(defun ert--setup-results-buffer (stats listener)
   "Set up a test results buffer.
 
-STATS is the stats object; LISTENER is the results listener;
-BUFFER-NAME, if non-nil, is the buffer name to use."
-  (unless buffer-name (setq buffer-name "*ert*"))
-  (let ((buffer (get-buffer-create buffer-name)))
+STATS is the stats object; LISTENER is the results listener."
+  (let ((buffer (get-buffer-create ert--output-buffer-name)))
     (with-current-buffer buffer
       (let ((inhibit-read-only t))
         (buffer-disable-undo)
@@ -2000,18 +2041,11 @@ ert--setup-results-buffer
 (defvar ert--selector-history nil
   "List of recent test selectors read from terminal.")
 
-;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here?
-;; They are needed only for our automated self-tests at the moment.
-;; Or should there be some other mechanism?
 ;;;###autoload
-(defun ert-run-tests-interactively (selector
-                                    &optional output-buffer-name message-fn)
+(defun ert-run-tests-interactively (selector)
   "Run the tests specified by SELECTOR and display the results in a buffer.
 
-SELECTOR works as described in `ert-select-tests'.
-OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they
-are used for automated self-tests and specify which buffer to use
-and how to display message."
+SELECTOR works as described in `ert-select-tests'."
   (interactive
    (list (let ((default (if ert--selector-history
                             ;; Can't use `first' here as this form is
@@ -2024,23 +2058,17 @@ ert-run-tests-interactively
                              obarray #'ert-test-boundp nil nil
                              'ert--selector-history default nil)))
          nil))
-  (unless message-fn (setq message-fn 'message))
-  (let ((output-buffer-name output-buffer-name)
-        buffer
-        listener
-        (message-fn message-fn))
+  (let (buffer listener)
     (setq listener
           (lambda (event-type &rest event-args)
             (cl-ecase event-type
               (run-started
                (cl-destructuring-bind (stats) event-args
-                 (setq buffer (ert--setup-results-buffer stats
-                                                         listener
-                                                         output-buffer-name))
+                 (setq buffer (ert--setup-results-buffer stats listener))
                  (pop-to-buffer buffer)))
               (run-ended
                (cl-destructuring-bind (stats abortedp) event-args
-                 (funcall message-fn
+                 (message
                           "%sRan %s tests, %s results were as expected%s%s"
                           (if (not abortedp)
                               ""
@@ -2394,7 +2422,7 @@ ert-results-rerun-all-tests
   (interactive nil ert-results-mode)
   (cl-assert (eql major-mode 'ert-results-mode))
   (let ((selector (ert--stats-selector ert--results-stats)))
-    (ert-run-tests-interactively selector (buffer-name))))
+    (ert-run-tests-interactively selector)))
 
 (defun ert-results-rerun-test-at-point ()
   "Re-run the test at point.
diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el
index 79576d2403..1a8c9bf4f0 100644
--- a/test/lisp/emacs-lisp/ert-tests.el
+++ b/test/lisp/emacs-lisp/ert-tests.el
@@ -39,10 +39,11 @@ ert-test-body-runs
 (defun ert-self-test ()
   "Run ERT's self-tests and make sure they actually ran."
   (let ((window-configuration (current-window-configuration)))
-    (let ((ert--test-body-was-run nil))
+    (let ((ert--test-body-was-run nil)
+          (ert--output-buffer-name " *ert self-tests*"))
       ;; The buffer name chosen here should not compete with the default
       ;; results buffer name for completion in `switch-to-buffer'.
-      (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*")))
+      (let ((stats (ert-run-tests-interactively "^ert-")))
         (cl-assert ert--test-body-was-run)
         (if (zerop (ert-stats-completed-unexpected stats))
             ;; Hide results window only when everything went well.
@@ -519,17 +520,18 @@ ert-test-run-tests-interactively
                                      :body (lambda () (ert-skip
                                                        "skip message")))))
     (let ((ert-debug-on-error nil))
-      (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*"))
-             (messages nil)
-             (mock-message-fn
-              (lambda (format-string &rest args)
-                (push (apply #'format format-string args) messages))))
+      (cl-letf* ((buffer-name (generate-new-buffer-name
+                               " *ert-test-run-tests*"))
+                 (ert--output-buffer-name buffer-name)
+                 (messages nil)
+                 ((symbol-function 'message)
+                  (lambda (format-string &rest args)
+                    (push (apply #'format format-string args) messages))))
         (save-window-excursion
           (unwind-protect
               (let ((case-fold-search nil))
                 (ert-run-tests-interactively
-                 `(member ,passing-test ,failing-test, skipped-test) buffer-name
-                 mock-message-fn)
+                 `(member ,passing-test ,failing-test, skipped-test))
                 (should (equal messages `(,(concat
                                             "Ran 3 tests, 1 results were "
                                             "as expected, 1 unexpected, "
@@ -551,6 +553,68 @@ ert-test-run-tests-interactively
             (when (get-buffer buffer-name)
               (kill-buffer buffer-name))))))))
 
+(ert-deftest ert-test-run-tests-batch ()
+  (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))
+	 (long-list (make-list 11 1))
+	 (failing-test-1
+          (make-ert-test :name 'failing-test-1
+			 :body (lambda () (should (equal complex-list 1)))))
+	 (failing-test-2
+          (make-ert-test :name 'failing-test-2
+			 :body (lambda () (should (equal long-list 1))))))
+    (let ((ert-debug-on-error nil)
+          messages)
+      (cl-letf* (((symbol-function 'message)
+                  (lambda (format-string &rest args)
+                    (push (apply #'format format-string args) messages))))
+        (save-window-excursion
+          (unwind-protect
+              (let ((case-fold-search nil)
+                    (ert-batch-backtrace-right-margin nil)
+		    (ert-batch-print-level 10)
+		    (ert-batch-print-length 11))
+                (ert-run-tests-batch
+                 `(member ,failing-test-1 ,failing-test-2))))))
+      (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$")
+	    (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$")
+            found-long
+	    found-complex)
+	(cl-loop for msg in (reverse messages)
+		 do
+		 (unless found-long
+		   (setq found-long (string-match long-text msg)))
+		 (unless found-complex
+		   (setq found-complex (string-match complex-text msg))))
+	(should found-long)
+	(should found-complex)))))
+
+(ert-deftest ert-test-run-tests-batch-expensive ()
+  (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc"))))))))
+	 (failing-test-1
+          (make-ert-test :name 'failing-test-1
+			 :body (lambda () (should (equal complex-list 1))))))
+    (let ((ert-debug-on-error nil)
+          messages)
+      (cl-letf* (((symbol-function 'message)
+                  (lambda (format-string &rest args)
+                    (push (apply #'format format-string args) messages))))
+        (save-window-excursion
+          (unwind-protect
+              (let ((case-fold-search nil)
+                    (ert-batch-backtrace-right-margin nil)
+                    (ert-batch-backtrace-line-length nil)
+		    (ert-batch-print-level 6)
+		    (ert-batch-print-length 11))
+                (ert-run-tests-batch
+                 `(member ,failing-test-1))))))
+      (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))")
+            found-frame)
+	(cl-loop for msg in (reverse messages)
+		 do
+		 (unless found-frame
+		   (setq found-frame (cl-search frame msg :test 'equal))))
+        (should found-frame)))))
+
 (ert-deftest ert-test-special-operator-p ()
   (should (ert--special-operator-p 'if))
   (should-not (ert--special-operator-p 'car))
diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el
index 9baa994158..5813fc44bf 100644
--- a/test/lisp/emacs-lisp/ert-x-tests.el
+++ b/test/lisp/emacs-lisp/ert-x-tests.el
@@ -103,23 +103,26 @@ ert-propertized-string
 
 (ert-deftest ert-test-run-tests-interactively-2 ()
   :tags '(:causes-redisplay)
-  (let* ((passing-test (make-ert-test :name 'passing-test
-                                      :body (lambda () (ert-pass))))
-         (failing-test (make-ert-test :name 'failing-test
-                                      :body (lambda ()
-                                              (ert-info ((propertize "foo\nbar"
-                                                                     'a 'b))
-                                                (ert-fail
-                                                 "failure message")))))
-         (skipped-test (make-ert-test :name 'skipped-test
-                                      :body (lambda () (ert-skip
-							"skip message"))))
-         (ert-debug-on-error nil)
-         (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
-         (messages nil)
-         (mock-message-fn
-          (lambda (format-string &rest args)
-            (push (apply #'format format-string args) messages))))
+  (cl-letf* ((passing-test (make-ert-test
+                            :name 'passing-test
+                            :body (lambda () (ert-pass))))
+             (failing-test (make-ert-test
+                            :name 'failing-test
+                            :body (lambda ()
+                                    (ert-info ((propertize "foo\nbar"
+                                                           'a 'b))
+                                              (ert-fail
+                                               "failure message")))))
+             (skipped-test (make-ert-test :name 'skipped-test
+                                          :body (lambda () (ert-skip
+							    "skip message"))))
+             (ert-debug-on-error nil)
+             (messages nil)
+             (buffer-name (generate-new-buffer-name "*ert-test-run-tests*"))
+             ((symbol-function 'message)
+              (lambda (format-string &rest args)
+                (push (apply #'format format-string args) messages)))
+             (ert--output-buffer-name buffer-name))
     (cl-flet ((expected-string (with-font-lock-p)
                 (ert-propertized-string
                  "Selector: (member <passing-test> <failing-test> "
@@ -152,14 +155,12 @@ ert-test-run-tests-interactively-2
                  "failing-test"
                  nil "\n    Info: " '(a b) "foo\n"
                  nil "          " '(a b) "bar"
-                 nil "\n    (ert-test-failed \"failure message\")\n\n\n"
-                 )))
+                 nil "\n    (ert-test-failed \"failure message\")\n\n\n")))
       (save-window-excursion
         (unwind-protect
             (let ((case-fold-search nil))
               (ert-run-tests-interactively
-               `(member ,passing-test ,failing-test ,skipped-test) buffer-name
-               mock-message-fn)
+               `(member ,passing-test ,failing-test ,skipped-test))
               (should (equal messages `(,(concat
                                           "Ran 3 tests, 1 results were "
                                           "as expected, 1 unexpected, "