;;; ert.el --- Emacs Lisp Regression Testing
-;; Copyright (C) 2007, 2008, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2008, 2010-2012 Free Software Foundation, Inc.
;; Author: Christian Ohler <ohler@gnu.org>
;; Keywords: lisp, tools
;; This implementation is inefficient. Rather than making it
;; efficient, let's hope bug 6581 gets fixed so that we can delete
;; it altogether.
- (not (ert--explain-not-equal-including-properties a b)))
+ (not (ert--explain-equal-including-properties a b)))
;;; Defining and locating tests.
;; We disallow nil since `ert-test-at-point' and related functions
;; want to return a test name, but also need an out-of-band value
;; on failure. Nil is the most natural out-of-band value; using 0
- ;; or "" or signalling an error would be too awkward.
+ ;; or "" or signaling an error would be too awkward.
;;
;; Note that nil is still a valid value for the `name' slot in
;; ert-test objects. It designates an anonymous test.
;; compiling doesn't depend on cl and thus doesn't need an
;; environment arg for `macroexpand'.
(if (fboundp 'cl-macroexpand)
- ;; Suppress warning about run-time call to cl funtion: we
+ ;; Suppress warning about run-time call to cl function: we
;; only call it if it's fboundp.
(with-no-warnings
(cl-macroexpand form (and (boundp 'cl-macro-environment)
is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is
an expression that returns a description of FORM. INNER-EXPANDER
should return code that calls INNER-FORM and performs the checks
-and error signalling specific to the particular variant of
+and error signaling specific to the particular variant of
`should'. The code that INNER-EXPANDER returns must not call
FORM-DESCRIPTION-FORM before it has called INNER-FORM."
(lexical-let ((inner-expander inner-expander))
Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES,
and aborts the current test as failed if it doesn't."
- (let ((signalled-conditions (get (car condition) 'error-conditions))
+ (let ((signaled-conditions (get (car condition) 'error-conditions))
(handled-conditions (etypecase type
(list type)
(symbol (list type)))))
- (assert signalled-conditions)
- (unless (ert--intersection signalled-conditions handled-conditions)
+ (assert signaled-conditions)
+ (unless (ert--intersection signaled-conditions handled-conditions)
(ert-fail (append
(funcall form-description-fn)
(list
:condition condition
- :fail-reason (concat "the error signalled did not"
+ :fail-reason (concat "the error signaled did not"
" have the expected type")))))
(when exclude-subtypes
(unless (member (car condition) handled-conditions)
(funcall form-description-fn)
(list
:condition condition
- :fail-reason (concat "the error signalled was a subtype"
+ :fail-reason (concat "the error signaled was a subtype"
" of the expected type"))))))))
;; FIXME: The expansion will evaluate the keyword args (if any) in
(defmacro* should-error (form &rest keys &key type exclude-subtypes)
"Evaluate FORM and check that it signals an error.
-The error signalled needs to match TYPE. TYPE should be a list
+The error signaled needs to match TYPE. TYPE should be a list
of condition names. (It can also be a non-nil symbol, which is
equivalent to a singleton list containing that symbol.) If
EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its
non-nil, the error matches TYPE if it is an element of TYPE.
If the error matches, returns (ERROR-SYMBOL . DATA) from the
-error. If not, or if no error was signalled, abort the test as
+error. If not, or if no error was signaled, abort the test as
failed."
(unless type (setq type ''error))
(ert--expand-should
(when (and (not firstp) (eq fast slow)) (return nil))))
(defun ert--explain-format-atom (x)
- "Format the atom X for `ert--explain-not-equal'."
+ "Format the atom X for `ert--explain-equal'."
(typecase x
(fixnum (list x (format "#x%x" x) (format "?%c" x)))
(t x)))
-(defun ert--explain-not-equal (a b)
- "Explainer function for `equal'.
-
-Returns a programmer-readable explanation of why A and B are not
-`equal', or nil if they are."
+(defun ert--explain-equal-rec (a b)
+ "Return a programmer-readable explanation of why A and B are not `equal'.
+Returns nil if they are."
(if (not (equal (type-of a) (type-of b)))
`(different-types ,a ,b)
(etypecase a
(loop for i from 0
for ai in a
for bi in b
- for xi = (ert--explain-not-equal ai bi)
+ for xi = (ert--explain-equal-rec ai bi)
do (when xi (return `(list-elt ,i ,xi)))
finally (assert (equal a b) t)))
- (let ((car-x (ert--explain-not-equal (car a) (car b))))
+ (let ((car-x (ert--explain-equal-rec (car a) (car b))))
(if car-x
`(car ,car-x)
- (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b))))
+ (let ((cdr-x (ert--explain-equal-rec (cdr a) (cdr b))))
(if cdr-x
`(cdr ,cdr-x)
(assert (equal a b) t)
(loop for i from 0
for ai across a
for bi across b
- for xi = (ert--explain-not-equal ai bi)
+ for xi = (ert--explain-equal-rec ai bi)
do (when xi (return `(array-elt ,i ,xi)))
finally (assert (equal a b) t))))
(atom (if (not (equal a b))
`(different-atoms ,(ert--explain-format-atom a)
,(ert--explain-format-atom b)))
nil)))))
-(put 'equal 'ert-explainer 'ert--explain-not-equal)
+
+(defun ert--explain-equal (a b)
+ "Explainer function for `equal'."
+ ;; Do a quick comparison in C to avoid running our expensive
+ ;; comparison when possible.
+ (if (equal a b)
+ nil
+ (ert--explain-equal-rec a b)))
+(put 'equal 'ert-explainer 'ert--explain-equal)
(defun ert--significant-plist-keys (plist)
"Return the keys of PLIST that have non-null values, in order."
(value-b (plist-get b key)))
(assert (not (equal value-a value-b)) t)
`(different-properties-for-key
- ,key ,(ert--explain-not-equal-including-properties value-a
- value-b)))))
+ ,key ,(ert--explain-equal-including-properties value-a
+ value-b)))))
(cond (keys-in-a-not-in-b
(explain-with-key (first keys-in-a-not-in-b)))
(keys-in-b-not-in-a
(t
(substring s 0 len)))))
-(defun ert--explain-not-equal-including-properties (a b)
+;; TODO(ohler): Once bug 6581 is fixed, rename this to
+;; `ert--explain-equal-including-properties-rec' and add a fast-path
+;; wrapper like `ert--explain-equal'.
+(defun ert--explain-equal-including-properties (a b)
"Explainer function for `ert-equal-including-properties'.
Returns a programmer-readable explanation of why A and B are not
`ert-equal-including-properties', or nil if they are."
(if (not (equal a b))
- (ert--explain-not-equal a b)
+ (ert--explain-equal a b)
(assert (stringp a) t)
(assert (stringp b) t)
(assert (eql (length a) (length b)) t)
)))
(put 'ert-equal-including-properties
'ert-explainer
- 'ert--explain-not-equal-including-properties)
+ 'ert--explain-equal-including-properties)
;;; Implementation of `ert-info'.
(make-ert-test-failed :condition condition
:backtrace backtrace
:infos infos))))
- ;; Work around Emacs' heuristic (in eval.c) for detecting
+ ;; Work around Emacs's heuristic (in eval.c) for detecting
;; errors in the debugger.
(incf num-nonmacro-input-events)
;; FIXME: We should probably implement more fine-grained
(ert-test-result-type-p result (ert-test-expected-result-type test)))
(defun ert-select-tests (selector universe)
- "Return the tests that match SELECTOR.
+ "Return a list of tests that match SELECTOR.
-UNIVERSE specifies the set of tests to select from; it should be
-a list of tests, or t, which refers to all tests named by symbols
-in `obarray'.
+UNIVERSE specifies the set of tests to select from; it should be a list
+of tests, or t, which refers to all tests named by symbols in `obarray'.
-Returns the set of tests as a list.
+Valid SELECTORs:
-Valid selectors:
-
-nil -- Selects the empty set.
-t -- Selects UNIVERSE.
+nil -- Selects the empty set.
+t -- Selects UNIVERSE.
:new -- Selects all tests that have not been run yet.
-:failed, :passed -- Select tests according to their most recent result.
+:failed, :passed -- Select tests according to their most recent result.
:expected, :unexpected -- Select tests according to their most recent result.
-a string -- Selects all tests that have a name that matches the string,
- a regexp.
-a test -- Selects that test.
+a string -- A regular expression selecting all tests with matching names.
+a test -- (i.e., an object of the ert-test data-type) Selects that test.
a symbol -- Selects the test that the symbol names, errors if none.
-\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests.
+\(member TESTS...) -- Selects the elements of TESTS, a list of tests
+ or symbols naming tests.
\(eql TEST\) -- Selects TEST, a test or a symbol naming a test.
-\(and SELECTORS...\) -- Selects the tests that match all SELECTORS.
-\(or SELECTORS...\) -- Selects the tests that match any SELECTOR.
-\(not SELECTOR\) -- Selects all tests that do not match SELECTOR.
+\(and SELECTORS...) -- Selects the tests that match all SELECTORS.
+\(or SELECTORS...) -- Selects the tests that match any of the SELECTORS.
+\(not SELECTOR) -- Selects all tests that do not match SELECTOR.
\(tag TAG) -- Selects all tests that have TAG on their tags list.
-\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE.
+ A tag is an arbitrary label you can apply when you define a test.
+\(satisfies PREDICATE) -- Selects all tests that satisfy PREDICATE.
+ PREDICATE is a function that takes an ert-test object as argument,
+ and returns non-nil if it is selected.
Only selectors that require a superset of tests, such
as (satisfies ...), strings, :new, etc. make use of UNIVERSE.
-Selectors that do not, such as \(member ...\), just return the
+Selectors that do not, such as (member ...), just return the
set implied by them without checking whether it is really
contained in UNIVERSE."
;; This code needs to match the etypecase in
(ert-test-passed (incf (ert--stats-passed-expected stats) d))
(ert-test-failed (incf (ert--stats-failed-expected stats) d))
(null)
- (ert-test-aborted-with-non-local-exit))
+ (ert-test-aborted-with-non-local-exit)
+ (ert-test-quit))
(etypecase (aref results pos)
(ert-test-passed (incf (ert--stats-passed-unexpected stats) d))
(ert-test-failed (incf (ert--stats-failed-unexpected stats) d))
(null)
- (ert-test-aborted-with-non-local-exit)))))
+ (ert-test-aborted-with-non-local-exit)
+ (ert-test-quit)))))
;; Adjust counters to remove the result that is currently in stats.
(update -1)
;; Put new test and result into stats.
(ert-test-passed ".P")
(ert-test-failed "fF")
(null "--")
- (ert-test-aborted-with-non-local-exit "aA"))))
+ (ert-test-aborted-with-non-local-exit "aA")
+ (ert-test-quit "qQ"))))
(elt s (if expectedp 0 1))))
(defun ert-string-for-test-result (result expectedp)
(ert-test-passed '("passed" "PASSED"))
(ert-test-failed '("failed" "FAILED"))
(null '("unknown" "UNKNOWN"))
- (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED")))))
+ (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))
+ (ert-test-quit '("quit" "QUIT")))))
(elt s (if expectedp 0 1))))
(defun ert--pp-with-indentation-and-newline (object)
;;; Running tests in batch mode.
(defvar ert-batch-backtrace-right-margin 70
- "*The maximum line length for printing backtraces in `ert-run-tests-batch'.")
+ "The maximum line length for printing backtraces in `ert-run-tests-batch'.")
;;;###autoload
(defun ert-run-tests-batch (&optional selector)
(let ((print-escape-newlines t)
(print-level 5)
(print-length 10))
- (let ((begin (point)))
- (ert--pp-with-indentation-and-newline
- (ert-test-result-with-condition-condition result))))
+ (ert--pp-with-indentation-and-newline
+ (ert-test-result-with-condition-condition result)))
(goto-char (1- (point-max)))
(assert (looking-at "\n"))
(delete-char 1)
(message "%s" (buffer-string))))
(ert-test-aborted-with-non-local-exit
(message "Test %S aborted with non-local exit"
- (ert-test-name test)))))
+ (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))
(defun ert-delete-all-tests ()
"Make all symbols in `obarray' name no test."
(interactive)
- (when (interactive-p)
+ (when (called-interactively-p 'any)
(unless (y-or-n-p "Delete all tests? ")
(error "Aborted")))
;; We can't use `ert-select-tests' here since that gives us only
BEGIN and END specify a region in the current buffer."
(save-excursion
(save-restriction
- (narrow-to-region begin (point))
+ (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))
(ert-test-result-with-condition-condition result))
(ert--make-xrefs-region begin (point)))))
(ert-test-aborted-with-non-local-exit
- (insert " aborted\n")))
+ (insert " aborted\n"))
+ (ert-test-quit
+ (insert " quit\n")))
(insert "\n")))))
nil)
(unless buffer-name (setq buffer-name "*ert*"))
(let ((buffer (get-buffer-create buffer-name)))
(with-current-buffer buffer
- (setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
;;; Simple view mode for auxiliary information like stack traces or
;;; messages. Mainly binds "q" for quit.
-(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View"
+(define-derived-mode ert-simple-view-mode special-mode "ERT-View"
"Major mode for viewing auxiliary information in ERT.")
-(loop for (key binding) in
- '(("q" quit-window)
- )
- do
- (define-key ert-simple-view-mode-map key binding))
-
-
;;; Commands and button actions for the results buffer.
-(define-derived-mode ert-results-mode fundamental-mode "ERT-Results"
+(define-derived-mode ert-results-mode special-mode "ERT-Results"
"Major mode for viewing results of ERT test runs.")
(loop for (key binding) in
("\t" forward-button)
([backtab] backward-button)
("j" ert-results-jump-between-summary-and-result)
- ("q" quit-window)
("L" ert-results-toggle-printer-limits-for-test-at-point)
("n" ert-results-next-test)
("p" ert-results-previous-test)
EWOC-FN specifies the direction and should be either `ewoc-prev'
or `ewoc-next'. If there are no more nodes in that direction, an
-error is signalled with the message ERROR-MESSAGE."
+error is signaled with the message ERROR-MESSAGE."
(loop
(setq node (funcall ewoc-fn ert--results-ewoc node))
(when (null node)
(let ((backtrace (ert-test-result-with-condition-backtrace result))
(buffer (get-buffer-create "*ERT Backtrace*")))
(pop-to-buffer buffer)
- (setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
(result (aref (ert--stats-test-results stats) pos)))
(let ((buffer (get-buffer-create "*ERT Messages*")))
(pop-to-buffer buffer)
- (setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
(result (aref (ert--stats-test-results stats) pos)))
(let ((buffer (get-buffer-create "*ERT list of should forms*")))
(pop-to-buffer buffer)
- (setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
(setq data (sort data (lambda (a b)
(> (second a) (second b)))))
(pop-to-buffer buffer)
- (setq buffer-read-only t)
(let ((inhibit-read-only t))
(buffer-disable-undo)
(erase-buffer)
HCoop / bpt / emacs.git / blobdiff