diff options
Diffstat (limited to 'lisp/emacs-lisp/ert.el')
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 230 |
1 files changed, 122 insertions, 108 deletions
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 2c49a634e35..1d69af80639 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -18,7 +18,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -73,6 +73,11 @@ :prefix "ert-" :group 'lisp) +(defcustom ert-batch-backtrace-right-margin 70 + "Maximum length of lines in ERT backtraces in batch mode. +Use nil for no limit (caution: backtrace lines can be very long)." + :type '(choice (const :tag "No truncation" nil) integer)) + (defface ert-test-result-expected '((((class color) (background light)) :background "green1") (((class color) (background dark)) @@ -97,7 +102,7 @@ This is like `equal-including-properties' except that it compares the property values of text properties structurally (by recursing) rather than with `eq'. Perhaps this is what `equal-including-properties' should do in the first place; see -Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." +Emacs bug 6581 at URL `https://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; This implementation is inefficient. Rather than making it ;; efficient, let's hope bug 6581 gets fixed so that we can delete ;; it altogether. @@ -135,7 +140,7 @@ Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." ;; Note that nil is still a valid value for the `name' slot in ;; ert-test objects. It designates an anonymous test. (error "Attempt to define a test named nil")) - (put symbol 'ert--test definition) + (define-symbol-prop symbol 'ert--test definition) definition) (defun ert-make-test-unbound (symbol) @@ -214,12 +219,6 @@ description of valid values for RESULT-TYPE. ,@(when tags-supplied-p `(:tags ,tags)) :body (lambda () ,@body))) - ;; This hack allows `symbol-file' to associate `ert-deftest' - ;; forms with files, and therefore enables `find-function' to - ;; work with tests. However, it leads to warnings in - ;; `unload-feature', which doesn't know how to undefine tests - ;; and has no mechanism for extension. - (push '(ert-deftest . ,name) current-load-list) ',name)))) ;; We use these `put' forms in addition to the (declare (indent)) in @@ -266,6 +265,14 @@ DATA is displayed to the user and should state the reason for skipping." (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) @@ -273,20 +280,26 @@ DATA is displayed to the user and should state the reason for skipping." (and (subrp definition) (eql (cdr (subr-arity definition)) 'unevalled))))) +;; FIXME: Code inside of here should probably be evaluated like it is +;; outside of tests, with the sole exception of error handling (defun ert--expand-should-1 (whole form inner-expander) "Helper function for the `should' macro and its variants." (let ((form - (macroexpand form (append (bound-and-true-p - byte-compile-macro-environment) - (cond - ((boundp 'macroexpand-all-environment) - macroexpand-all-environment) - ((boundp 'cl-macro-environment) - cl-macro-environment)))))) + ;; catch macroexpansion errors + (condition-case err + (macroexpand-all form + (append (bound-and-true-p + byte-compile-macro-environment) + (cond + ((boundp 'macroexpand-all-environment) + macroexpand-all-environment) + ((boundp 'cl-macro-environment) + cl-macro-environment)))) + (error `(signal ',(car err) ',(cdr err)))))) (cond ((or (atom form) (ert--special-operator-p (car form))) - (let ((value (cl-gensym "value-"))) - `(let ((,value (cl-gensym "ert-form-evaluation-aborted-"))) + (let ((value (gensym "value-"))) + `(let ((,value (gensym "ert-form-evaluation-aborted-"))) ,(funcall inner-expander `(setq ,value ,form) `(list ',whole :form ',form :value ,value) @@ -299,12 +312,17 @@ DATA is displayed to the user and should state the reason for skipping." (and (consp fn-name) (eql (car fn-name) 'lambda) (listp (cdr fn-name))))) - (let ((fn (cl-gensym "fn-")) - (args (cl-gensym "args-")) - (value (cl-gensym "value-")) - (default-value (cl-gensym "ert-form-evaluation-aborted-"))) - `(let ((,fn (function ,fn-name)) - (,args (list ,@arg-forms))) + (let ((fn (gensym "fn-")) + (args (gensym "args-")) + (value (gensym "value-")) + (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)) + (error (progn (setq ,fn #'signal) + (list (car err) + (cdr err))))))) (let ((,value ',default-value)) ,(funcall inner-expander `(setq ,value (apply ,fn ,args)) @@ -339,7 +357,7 @@ FORM-DESCRIPTION-FORM before it has called INNER-FORM." (ert--expand-should-1 whole form (lambda (inner-form form-description-form value-var) - (let ((form-description (cl-gensym "form-description-"))) + (let ((form-description (gensym "form-description-"))) `(let (,form-description) ,(funcall inner-expander `(unwind-protect @@ -417,8 +435,8 @@ failed." `(should-error ,form ,@keys) form (lambda (inner-form form-description-form value-var) - (let ((errorp (cl-gensym "errorp")) - (form-description-fn (cl-gensym "form-description-fn-"))) + (let ((errorp (gensym "errorp")) + (form-description-fn (gensym "form-description-fn-"))) `(let ((,errorp nil) (,form-description-fn (lambda () ,form-description-form))) (condition-case -condition- @@ -670,48 +688,12 @@ and is displayed in front of the value of MESSAGE-FORM." (cl-defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) - -(defun ert--record-backtrace () - "Record the current backtrace (as a list) and return it." - ;; Since the backtrace is stored in the result object, result - ;; objects must only be printed with appropriate limits - ;; (`print-level' and `print-length') in place. For interactive - ;; use, the cost of ensuring this possibly outweighs the advantage - ;; of storing the backtrace for - ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we - ;; already have `ert-results-rerun-test-debugging-errors-at-point'. - ;; For batch use, however, printing the backtrace may be useful. - (cl-loop - ;; 6 is the number of frames our own debugger adds (when - ;; compiled; more when interpreted). FIXME: Need to describe a - ;; procedure for determining this constant. - for i from 6 - for frame = (backtrace-frame i) - while frame - collect frame)) - -(defun ert--print-backtrace (backtrace) +(defun ert--print-backtrace (backtrace do-xrefs) "Format the backtrace BACKTRACE to the current buffer." - ;; This is essentially a reimplementation of Fbacktrace - ;; (src/eval.c), but for a saved backtrace, not the current one. (let ((print-escape-newlines t) (print-level 8) (print-length 50)) - (dolist (frame backtrace) - (pcase-exhaustive frame - (`(nil ,special-operator . ,arg-forms) - ;; Special operator. - (insert - (format " %S\n" (cons special-operator arg-forms)))) - (`(t ,fn . ,args) - ;; Function call. - (insert (format " %S(" fn)) - (cl-loop for firstp = t then nil - for arg in args do - (unless firstp - (insert " ")) - (insert (format "%S" arg))) - (insert ")\n")))))) + (debugger-insert-backtrace backtrace do-xrefs))) ;; A container for the state of the execution of a single test and ;; environment data needed during its execution. @@ -750,7 +732,18 @@ run. ARGS are the arguments to `debugger'." ((quit) 'quit) ((ert-test-skipped) 'skipped) (otherwise 'failed))) - (backtrace (ert--record-backtrace)) + ;; 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-frames debugger))) (infos (reverse ert--infos))) (setf (ert--test-execution-info-result info) (cl-ecase type @@ -790,6 +783,10 @@ This mainly sets up debugger-related bindings." ;; 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))) @@ -1336,8 +1333,8 @@ RESULT must be an `ert-test-result-with-condition'." ;;; Running tests in batch mode. -(defvar ert-batch-backtrace-right-margin 70 - "The maximum line length for printing backtraces in `ert-run-tests-batch'.") +(defvar ert-quiet nil + "Non-nil makes ERT only print important information in batch mode.") ;;;###autoload (defun ert-run-tests-batch (&optional selector) @@ -1355,10 +1352,11 @@ Returns the stats object." (lambda (event-type &rest event-args) (cl-ecase event-type (run-started - (cl-destructuring-bind (stats) event-args - (message "Running %s tests (%s)" - (length (ert--stats-tests stats)) - (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (unless ert-quiet + (cl-destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats)))))) (run-ended (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) @@ -1409,17 +1407,23 @@ Returns the stats object." (ert-test-result-with-condition (message "Test %S backtrace:" (ert-test-name test)) (with-temp-buffer - (ert--print-backtrace (ert-test-result-with-condition-backtrace - result)) - (goto-char (point-min)) - (while (not (eobp)) - (let ((start (point)) - (end (progn (end-of-line) (point)))) - (setq end (min end - (+ start ert-batch-backtrace-right-margin))) - (message "%s" (buffer-substring-no-properties - start end))) - (forward-line 1))) + (ert--print-backtrace + (ert-test-result-with-condition-backtrace result) + nil) + (if (not ert-batch-backtrace-right-margin) + (message "%s" + (buffer-substring-no-properties (point-min) + (point-max))) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (line-end-position))) + (setq end (min end + (+ start + ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1)))) (with-temp-buffer (ert--insert-infos result) (insert " ") @@ -1438,16 +1442,17 @@ Returns the stats object." (ert-test-name test))) (ert-test-quit (message "Quit during %S" (ert-test-name test))))) - (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) - (format-string (concat "%9s %" - (prin1-to-string (length max)) - "s/" max " %S"))) - (message format-string - (ert-string-for-test-result result - (ert-test-result-expected-p - test result)) - (1+ (ert--stats-test-pos stats test)) - (ert-test-name test))))))) + (unless ert-quiet + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test)))))))) nil)) ;;;###autoload @@ -1491,7 +1496,7 @@ this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." (with-temp-buffer (while (setq logfile (pop command-line-args-left)) (erase-buffer) - (insert-file-contents logfile) + (when (file-readable-p logfile) (insert-file-contents logfile)) (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t)) (push logfile notests) (setq ntests (+ ntests (string-to-number (match-string 1)))) @@ -1535,7 +1540,7 @@ Ran \\([0-9]+\\) tests, \\([0-9]+\\) results as expected\ (message "%d files contained unexpected results:" (length unexpected)) (mapc (lambda (l) (message " %s" l)) unexpected)) ;; More details on hydra, where the logs are harder to get to. - (when (and (getenv "NIX_STORE") + (when (and (getenv "EMACS_HYDRA_CI") (not (zerop (+ nunexpected nskipped)))) (message "\nDETAILS") (message "-------") @@ -1625,7 +1630,7 @@ default (if any)." (defun ert-find-test-other-window (test-name) "Find, in another window, the definition of TEST-NAME." (interactive (list (ert-read-test-name-at-point "Find test definition: "))) - (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + (find-function-do-it test-name 'ert--test 'switch-to-buffer-other-window)) (defun ert-delete-test (test-name) "Make the test TEST-NAME unbound. @@ -1828,12 +1833,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'." BEGIN and END specify a region in the current buffer." (save-excursion - (save-restriction - (narrow-to-region begin end) - ;; Inhibit optimization in `debugger-make-xrefs' that would - ;; sometimes insert unrelated backtrace info into our buffer. - (let ((debugger-previous-backtrace nil)) - (debugger-make-xrefs))))) + (goto-char begin) + (while (progn + (goto-char (+ (point) 2)) + (skip-syntax-forward "^w_") + (< (point) end)) + (let* ((beg (point)) + (end (progn (skip-syntax-forward "w_") (point))) + (sym (intern-soft (buffer-substring-no-properties + beg end))) + (file (and sym (symbol-file sym 'defun)))) + (when file + (goto-char beg) + ;; help-xref-button needs to operate on something matched + ;; by a regexp, so set that up for it. + (re-search-forward "\\(\\sw\\|\\s_\\)+") + (help-xref-button 0 'help-function-def sym file))) + (forward-line 1)))) (defun ert--string-first-line (s) "Return the first line of S, or S if it contains no newlines. @@ -2417,11 +2433,9 @@ To be used in the ERT results buffer." (buffer-disable-undo) (erase-buffer) (ert-simple-view-mode) - ;; Use unibyte because `debugger-setup-buffer' also does so. - (set-buffer-multibyte nil) + (set-buffer-multibyte t) ; mimic debugger-setup-buffer (setq truncate-lines t) - (ert--print-backtrace backtrace) - (debugger-make-xrefs) + (ert--print-backtrace backtrace t) (goto-char (point-min)) (insert (substitute-command-keys "Backtrace for test `")) (ert-insert-test-name-button (ert-test-name test)) @@ -2552,7 +2566,7 @@ To be used in the ERT results buffer." (insert (if test-name (format "%S" test-name) "<anonymous test>")) (insert " is a test") (let ((file-name (and test-name - (symbol-file test-name 'ert-deftest)))) + (symbol-file test-name 'ert--test)))) (when file-name (insert (format-message " defined in `%s'" (file-name-nondirectory file-name))) @@ -2585,7 +2599,7 @@ To be used in the ERT results buffer." ;;; Actions on load/unload. -(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'find-function-regexp-alist '(ert--test . ert--find-test-regexp)) (add-to-list 'minor-mode-alist '(ert--current-run-stats (:eval (ert--tests-running-mode-line-indicator)))) |