From e08577437af595325c950dad261a912093af76af Mon Sep 17 00:00:00 2001 From: Noam Postavsky Date: Mon, 13 Aug 2018 21:33:04 -0400 Subject: [PATCH v1 1/3] Use signal-hook-function in ert, not debugger Stop (ab)using the `debugger' in ert.el for backtrace recording. Instead, use `signal-hook-function' for this purpose, which makes ert's behavior independent of `debug-on-error'. * lisp/emacs-lisp/ert.el (ert--should-signal-hook): Remove. (ert--expand-should-1): Don't bind signal-hook-function. (ert-debug-on-error): Obsolete, alias to debug-on-error (replace all uses accordingly). (ert--test-execution-info): Remove exit-continuation, next-debugger, and ert-debug-on-error fields. (ert--run-test-debugger): Remove. (ert--store-backtrace): New function, to replace it. (ert--run-test-internal): Use condition-case and bind `signal-hook-function' rather than binding `debugger'. (ert-run-test): Remove the `cl-block' for the now removed exit-continuation. * test/lisp/emacs-lisp/ert-tests.el (ert-test-fail-debug-nested-with-debugger): Remove. (ert-nested-should): New test (Bug#30745). (ert-with-demoted-errors): New test (Bug#11218). --- lisp/emacs-lisp/ert.el | 224 ++++++++++++++---------------------- test/lisp/emacs-lisp/ert-tests.el | 101 +++++++--------- test/lisp/emacs-lisp/ert-x-tests.el | 2 +- 3 files changed, 130 insertions(+), 197 deletions(-) diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index eb9695d0c1..09b0240c90 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -266,14 +266,6 @@ ert--signal-should-execution (when ert--should-execution-observer (funcall ert--should-execution-observer form-description))) -;; See Bug#24402 for why this exists -(defun ert--should-signal-hook (error-symbol data) - "Stupid hack to stop `condition-case' from catching ert signals. -It should only be stopped when ran from inside ert--run-test-internal." - (when (and (not (symbolp debugger)) ; only run on anonymous debugger - (memq error-symbol '(ert-test-failed ert-test-skipped))) - (funcall debugger 'error data))) - (defun ert--special-operator-p (thing) "Return non-nil if THING is a symbol naming a special operator." (and (symbolp thing) @@ -319,8 +311,7 @@ ert--expand-should-1 (default-value (gensym "ert-form-evaluation-aborted-"))) `(let* ((,fn (function ,fn-name)) (,args (condition-case err - (let ((signal-hook-function #'ert--should-signal-hook)) - (list ,@arg-forms)) + (list ,@arg-forms) (error (progn (setq ,fn #'signal) (list (car err) (cdr err))))))) @@ -658,7 +649,7 @@ ert--infos ;;; Facilities for running a single test. -(defvar ert-debug-on-error nil +(define-obsolete-variable-alias 'ert-debug-on-error 'debug-on-error "27.1" "Non-nil means enter debugger when a test fails or terminates with an error.") ;; The data structures that represent the result of running a test. @@ -682,109 +673,68 @@ ert-debug-on-error ;; environment data needed during its execution. (cl-defstruct ert--test-execution-info (test (cl-assert nil)) - (result (cl-assert nil)) - ;; A thunk that may be called when RESULT has been set to its final - ;; value and test execution should be terminated. Should not - ;; return. - (exit-continuation (cl-assert nil)) - ;; The binding of `debugger' outside of the execution of the test. - next-debugger - ;; The binding of `ert-debug-on-error' that is in effect for the - ;; execution of the current test. We store it to avoid being - ;; affected by any new bindings the test itself may establish. (I - ;; don't remember whether this feature is important.) - ert-debug-on-error) - -(defun ert--run-test-debugger (info args) - "During a test run, `debugger' is bound to a closure that calls this function. - -This function records failures and errors and either terminates -the test silently or calls the interactive debugger, as -appropriate. + (result (cl-assert nil))) +(defun ert--store-backtrace (info error-symbol data) + "Record backtrace into INFO. INFO is the ert--test-execution-info corresponding to this test -run. ARGS are the arguments to `debugger'." - (cl-destructuring-bind (first-debugger-arg &rest more-debugger-args) - args - (cl-ecase first-debugger-arg - ((lambda debug t exit nil) - (apply (ert--test-execution-info-next-debugger info) args)) - (error - (let* ((condition (car more-debugger-args)) - (type (cl-case (car condition) - ((quit) 'quit) - ((ert-test-skipped) 'skipped) - (otherwise 'failed))) - ;; We store the backtrace in the result object for - ;; `ert-results-pop-to-backtrace-for-test-at-point'. - ;; This means we have to limit `print-level' and - ;; `print-length' when printing result objects. That - ;; might not be worth while when we can also use - ;; `ert-results-rerun-test-debugging-errors-at-point', - ;; (i.e., when running interactively) but having the - ;; backtrace ready for printing is important for batch - ;; use. - ;; - ;; Grab the frames above the debugger. - (backtrace (cdr (backtrace-get-frames debugger))) - (infos (reverse ert--infos))) - (setf (ert--test-execution-info-result info) - (cl-ecase type - (quit - (make-ert-test-quit :condition condition - :backtrace backtrace - :infos infos)) - (skipped - (make-ert-test-skipped :condition condition - :backtrace backtrace - :infos infos)) - (failed - (make-ert-test-failed :condition condition - :backtrace backtrace - :infos infos)))) - ;; Work around Emacs's heuristic (in eval.c) for detecting - ;; errors in the debugger. - (cl-incf num-nonmacro-input-events) - ;; FIXME: We should probably implement more fine-grained - ;; control a la non-t `debug-on-error' here. - (cond - ((ert--test-execution-info-ert-debug-on-error info) - (apply (ert--test-execution-info-next-debugger info) args)) - (t)) - (funcall (ert--test-execution-info-exit-continuation info))))))) +run. ERROR-SYMBOL and DATA are the same as for `signal'." + (let* (;; We store the backtrace in the result object for + ;; `ert-results-pop-to-backtrace-for-test-at-point'. + ;; This means we have to limit `print-level' and + ;; `print-length' when printing result objects. That + ;; might not be worth while when we can also use + ;; `ert-results-rerun-test-debugging-errors-at-point', + ;; (i.e., when running interactively) but having the + ;; backtrace ready for printing is important for batch + ;; use. + ;; + ;; Drop frames starting from the closure which calls this + ;; function (see lambda in `ert--run-test-internal'). + (backtrace (cddr (backtrace-get-frames #'ert--store-backtrace))) + (condition (cons error-symbol data)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (cl-case error-symbol + ((quit) + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + ((ert-test-skipped) + (make-ert-test-skipped :condition condition + :backtrace backtrace + :infos infos)) + (otherwise + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))))) (defun ert--run-test-internal (test-execution-info) "Low-level function to run a test according to TEST-EXECUTION-INFO. This mainly sets up debugger-related bindings." - (setf (ert--test-execution-info-next-debugger test-execution-info) debugger - (ert--test-execution-info-ert-debug-on-error test-execution-info) - ert-debug-on-error) - (catch 'ert--pass - ;; For now, each test gets its own temp buffer and its own - ;; window excursion, just to be safe. If this turns out to be - ;; too expensive, we can remove it. - (with-temp-buffer - (save-window-excursion - ;; FIXME: Use `signal-hook-function' instead of `debugger' to - ;; handle ert errors. Once that's done, remove - ;; `ert--should-signal-hook'. See Bug#24402 and Bug#11218 for - ;; details. - (let ((debugger (lambda (&rest args) - (ert--run-test-debugger test-execution-info - args))) - (debug-on-error t) - (debug-on-quit t) - ;; FIXME: Do we need to store the old binding of this - ;; and consider it in `ert--run-test-debugger'? - (debug-ignored-errors nil) - (ert--infos '())) - (funcall (ert-test-body (ert--test-execution-info-test - test-execution-info)))))) - (ert-pass)) - (setf (ert--test-execution-info-result test-execution-info) - (make-ert-test-passed)) - nil) + (condition-case-unless-debug () + (progn + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((signal-hook-function + (lambda (errsym errdata) + ;; Rebind `signal-hook-function' to avoid + ;; accidental recursion. + (let ((signal-hook-function nil)) + (ert--store-backtrace test-execution-info + errsym errdata)))) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test + test-execution-info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result test-execution-info) + (make-ert-test-passed))) + (t nil))) (defun ert--force-message-log-buffer-truncation () "Immediately truncate *Messages* buffer according to `message-log-max'. @@ -822,35 +772,32 @@ ert-run-test Returns the result and stores it in ERT-TEST's `most-recent-result' slot." (setf (ert-test-most-recent-result ert-test) nil) - (cl-block error - (let ((begin-marker - (with-current-buffer (messages-buffer) - (point-max-marker)))) - (unwind-protect - (let ((info (make-ert--test-execution-info - :test ert-test - :result - (make-ert-test-aborted-with-non-local-exit) - :exit-continuation (lambda () - (cl-return-from error nil)))) - (should-form-accu (list))) - (unwind-protect - (let ((ert--should-execution-observer - (lambda (form-description) - (push form-description should-form-accu))) - (message-log-max t) - (ert--running-tests (cons ert-test ert--running-tests))) - (ert--run-test-internal info)) - (let ((result (ert--test-execution-info-result info))) - (setf (ert-test-result-messages result) - (with-current-buffer (messages-buffer) - (buffer-substring begin-marker (point-max)))) - (ert--force-message-log-buffer-truncation) - (setq should-form-accu (nreverse should-form-accu)) - (setf (ert-test-result-should-forms result) - should-form-accu) - (setf (ert-test-most-recent-result ert-test) result)))) - (set-marker begin-marker nil)))) + (let ((begin-marker + (with-current-buffer (messages-buffer) + (point-max-marker)))) + (unwind-protect + (let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (messages-buffer) + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil))) (ert-test-most-recent-result ert-test)) (defun ert-running-test () @@ -2424,11 +2371,10 @@ ert-results-rerun-test-at-point (goto-char point)))))) (defun ert-results-rerun-test-at-point-debugging-errors () - "Re-run the test at point with `ert-debug-on-error' bound to t. - + "Re-run the test at point with `debug-on-error' bound to t. To be used in the ERT results buffer." (interactive) - (let ((ert-debug-on-error t)) + (let ((debug-on-error t)) (ert-results-rerun-test-at-point))) (defun ert-results-pop-to-backtrace-for-test-at-point () diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 1fe5b79ef3..ac516135ca 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -85,7 +85,7 @@ ert-self-test-and-exit (ert-deftest ert-test-fail () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (cl-assert (ert-test-failed-p result) t) (cl-assert (equal (ert-test-result-with-condition-condition result) @@ -94,51 +94,29 @@ ert-self-test-and-exit (ert-deftest ert-test-fail-debug-with-condition-case () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (condition-case condition - (progn - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (cl-assert nil)) - ((error) - (cl-assert (equal condition '(ert-test-failed "failure message")) t))))) + (should (equal (ert-test-result-with-condition-condition + (let ((debug-on-error t)) + (ert-run-test test))) + '(ert-test-failed "failure message"))))) (ert-deftest ert-test-fail-debug-with-debugger-1 () - (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) - (let ((debugger (lambda (&rest _args) - (cl-assert nil)))) - (let ((ert-debug-on-error nil)) - (ert-run-test test))))) + (let ((test (make-ert-test :body (lambda () (ert-fail "failure message")))) + (debugger (lambda (&rest _) (cl-assert nil))) + (debug-on-error nil)) + (ert-run-test test))) (ert-deftest ert-test-fail-debug-with-debugger-2 () (let ((test (make-ert-test :body (lambda () (ert-fail "failure message"))))) (cl-block nil (let ((debugger (lambda (&rest _args) - (cl-return-from nil nil)))) - (let ((ert-debug-on-error t)) - (ert-run-test test)) + (cl-return-from nil nil))) + (debug-on-error t)) + (ert-run-test test) (cl-assert nil))))) -(ert-deftest ert-test-fail-debug-nested-with-debugger () - (let ((test (make-ert-test :body (lambda () - (let ((ert-debug-on-error t)) - (ert-fail "failure message")))))) - (let ((debugger (lambda (&rest _args) - (cl-assert nil nil "Assertion a")))) - (let ((ert-debug-on-error nil)) - (ert-run-test test)))) - (let ((test (make-ert-test :body (lambda () - (let ((ert-debug-on-error nil)) - (ert-fail "failure message")))))) - (cl-block nil - (let ((debugger (lambda (&rest _args) - (cl-return-from nil nil)))) - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (cl-assert nil nil "Assertion b"))))) - (ert-deftest ert-test-error () (let ((test (make-ert-test :body (lambda () (error "Error message"))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (cl-assert (ert-test-failed-p result) t) (cl-assert (equal (ert-test-result-with-condition-condition result) @@ -147,19 +125,18 @@ ert-self-test-and-exit (ert-deftest ert-test-error-debug () (let ((test (make-ert-test :body (lambda () (error "Error message"))))) - (condition-case condition - (progn - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (cl-assert nil)) - ((error) - (cl-assert (equal condition '(error "Error message")) t))))) + (let ((debug-on-error t) + (debugger #'ignore)) ; Don't print backtrace. + (should + (equal (ert-test-result-with-condition-condition + (ert-run-test test)) + '(error "Error message")))))) ;;; Test that `should' works. (ert-deftest ert-test-should () (let ((test (make-ert-test :body (lambda () (should nil))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (cl-assert (ert-test-failed-p result) t) (cl-assert (equal (ert-test-result-with-condition-condition result) @@ -175,7 +152,7 @@ ert-self-test-and-exit (ert-deftest ert-test-should-not () (let ((test (make-ert-test :body (lambda () (should-not t))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (cl-assert (ert-test-failed-p result) t) (cl-assert (equal (ert-test-result-with-condition-condition result) @@ -190,7 +167,7 @@ ert-self-test-and-exit (let ((test (make-ert-test :body (lambda () (cl-macrolet ((foo () `(progn t nil))) (should (foo))))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (should (ert-test-failed-p result)) (should (equal @@ -202,7 +179,7 @@ ert-self-test-and-exit (ert-deftest ert-test-should-error () ;; No error. (let ((test (make-ert-test :body (lambda () (should-error (progn)))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (should (ert-test-failed-p result)) (should (equal (ert-test-result-with-condition-condition result) @@ -345,13 +322,23 @@ ert--test-my-list (error "Foo"))) do (let ((test (make-ert-test :body body))) - (condition-case actual-condition - (progn - (let ((ert-debug-on-error t)) - (ert-run-test test)) - (cl-assert nil)) - ((error) - (should (equal actual-condition expected-condition))))))) + (should (equal (ert-test-result-with-condition-condition + (let ((debug-on-error nil)) + (ert-run-test test))) + expected-condition))))) + +(ert-deftest ert-nested-should () + "Test (dynamically) nested `should' forms (Bug#30745)." + (let ((test (make-ert-test :body (lambda () (should (eq 1 2)))))) + (should (equal (ert-test-result-with-condition-condition + (ert-run-test test)) + '(ert-test-failed + ((should (eq 1 2)) :form (eq 1 2) :value nil)))))) + +(ert-deftest ert-with-demoted-errors () + "An error which is caught shouldn't fail the test (Bug#11218)." + (should (progn (with-demoted-errors (error "error!")) + t))) (defun ert-test--which-file () "Dummy function to help test `symbol-file' for tests.") @@ -518,7 +505,7 @@ ert-test--which-file (skipped-test (make-ert-test :name 'skipped-test :body (lambda () (ert-skip "skip message"))))) - (let ((ert-debug-on-error nil)) + (let ((debug-on-error nil)) (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) (messages nil) (mock-message-fn @@ -566,7 +553,7 @@ ert-test--which-file (should (null '())) (should nil) (should t))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (should (equal (ert-test-result-should-forms result) '(((should t) :form t :value t) @@ -581,7 +568,7 @@ ert-test--which-file (should t))))) (let ((result (ert-run-test test2))) (should (ert-test-passed-p result)))))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (should (ert-test-passed-p result)) (should (eql (length (ert-test-result-should-forms result)) @@ -593,7 +580,7 @@ ert-test--which-file (should (equal obj '(a))) (setf (car obj) 'b) (should (equal obj '(b)))))))) - (let ((result (let ((ert-debug-on-error nil)) + (let ((result (let ((debug-on-error nil)) (ert-run-test test)))) (should (ert-test-passed-p result)) (should (equal (ert-test-result-should-forms result) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9798f0c824..16b4751a38 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -114,7 +114,7 @@ ert--hash-table-to-alist (skipped-test (make-ert-test :name 'skipped-test :body (lambda () (ert-skip "skip message")))) - (ert-debug-on-error nil) + (debug-on-error nil) (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) (messages nil) (mock-message-fn -- 2.11.0