Browse files

Much simplification and improvements

* remove ASDF-system-connection stuff

* switch from handler-case to handler-bind for better reporting

* Move away from the test-environment stuff and back to slots

    I can no longer recall why I moved away from slots to using the test-environment
variable. I think it had something to do with the experiments back in 2003/4 in
running the same tests in different environments via a mini-process-like language...

    The only change noted so far is that you can no longer treat slot-initforms
as if previous slots have been defined (i.e., the slot initforms behave like
let rather than let* (or, indeed, like slot initforms)). This will require
moving this sort of code from the initform and into the setup.

* the above improves default-initarg handlinga<

* slot-initforms are evaluated only once (previously it was
  every time) and are effectively test-suite setup rather
  than test-case setup.

* dynamic variables happen after initforms rather than before

* since we determine all the tests we're going to run
  up-front, the counts of skipped test-suites changes.

* since an error may occur during test-suite creation, we
  cannot rely on the test-suite being there during error
  reporting so we move both testsuite-initargs and
  current-step from the suite to the result.

* several bits in test-running can be simplified from methods
  into defuns (yeah!)

* remove quite a few unused slots from test-mixin

* add *last-testsuite-name* and *last-test-case-name* to
  resolve confusion when running tests from within tests.

* add and use test-case-tested-p

* rework how test options are tracked and managed

* rework how expected errors, etc are tracked

* greatly simplify the code in run-test

* add :depends-on option to addtest. It should be an atom or
  list of test-case names that this case depends on. I.e.,
  cases that must be run before this case is run.

* added tests for :depends-on

* Test problem instances store suite-name rather than instance which
  simplifies code in several other places
  • Loading branch information...
1 parent 4525265 commit 5c3b4003eea6b122decf68c244da50d1502b0a4a Gary King committed Jan 24, 2010
View
149 dev/class-defs.lisp
@@ -0,0 +1,149 @@
+;;;-*- Mode: Lisp; Package: lift -*-
+
+(in-package #:lift)
+
+;;; ---------------------------------------------------------------------------
+;;; classes
+;;; ---------------------------------------------------------------------------
+
+(defclass test-mixin ()
+ ((name :initform nil :initarg :name :accessor name :reader testsuite-name)
+ (run-setup :reader run-setup :initarg :run-setup)
+ (done-setup? :initform nil :reader done-setup?)
+ (done-dynamics? :initform nil :reader done-dynamics?)
+ (current-method :initform nil :accessor current-method)
+ (log-file :initform nil :initarg :log-file :reader log-file)
+ (test-data :initform nil :accessor test-data)
+ (profile
+ :initform nil
+ :initarg :profile
+ :accessor profile))
+ (:documentation "A test suite")
+ (:default-initargs
+ :run-setup :once-per-test-case))
+
+(defclass test-result ()
+ ((results-for :initform nil
+ :initarg :results-for
+ :accessor results-for)
+ (tests-run :initform nil :accessor tests-run)
+ (suites-run :initform nil :accessor suites-run)
+ (failures :initform nil :accessor failures)
+ (expected-failures :initform nil :accessor expected-failures)
+ (errors :initform nil :accessor errors)
+ (expected-errors :initform nil :accessor expected-errors)
+ (skipped-test-cases :initform nil :accessor skipped-test-cases)
+ (skipped-testsuites :initform nil :accessor skipped-testsuites)
+ (test-mode :initform :single :initarg :test-mode :accessor test-mode)
+ (test-interactive? :initform nil
+ :initarg :test-interactive? :accessor test-interactive?)
+ (real-start-time :initarg :real-start-time :reader real-start-time)
+ (start-time :accessor start-time :initform nil)
+ (end-time :accessor end-time)
+ (real-end-time :accessor real-end-time)
+ (real-start-time-universal
+ :initarg :real-start-time-universal :reader real-start-time-universal)
+ (start-time-universal :accessor start-time-universal :initform nil)
+ (end-time-universal :accessor end-time-universal)
+ (real-end-time-universal :accessor real-end-time-universal)
+ (properties :initform nil :accessor test-result-properties)
+ (current-step :initform :created :accessor current-step)
+ (testsuite-initargs
+ :initform nil
+ :initarg :testsuite-initargs
+ :accessor testsuite-initargs))
+ (:documentation
+"A `test-result` instance contains all of the information collectd by
+LIFT during a test run.")
+ (:default-initargs
+ :test-interactive? *test-is-being-defined?*
+ :real-start-time (get-internal-real-time)
+ :real-start-time-universal (get-universal-time)))
+
+(defclass test-problem-mixin ()
+ ((testsuite :initform nil :initarg :testsuite :reader testsuite)
+ (test-method :initform nil :initarg :test-method :reader test-method)
+ (test-condition :initform nil
+ :initarg :test-condition
+ :reader test-condition)
+ (test-problem-kind :reader test-problem-kind :allocation :class)
+ (test-step :initform nil :initarg :test-step :reader test-step)))
+
+(defmethod print-object ((problem test-problem-mixin) stream)
+ (print-unreadable-object (problem stream)
+ (format stream "TEST-~@:(~A~): ~A in ~A"
+ (test-problem-kind problem)
+ (testsuite problem)
+ (test-method problem))))
+
+(defclass generic-problem (test-problem-mixin)
+ ((test-problem-kind :initarg :test-problem-kind
+ :allocation :class)))
+
+(defclass expected-problem-mixin ()
+ ((documentation :initform nil
+ :initarg :documentation
+ :accessor failure-documentation)))
+
+(defclass test-expected-failure (expected-problem-mixin generic-problem)
+ ())
+
+(defmethod test-problem-kind ((problem test-expected-failure))
+ "Expected failure")
+
+(defclass test-failure (generic-problem)
+ ()
+ (:default-initargs
+ :test-problem-kind "failure"))
+
+(defclass test-error-mixin (generic-problem)
+ ((backtrace :initform nil :initarg :backtrace :reader backtrace)))
+
+(defclass test-expected-error (expected-problem-mixin test-error-mixin)
+ ()
+ (:default-initargs
+ :test-problem-kind "Expected error"))
+
+(defclass test-error (test-error-mixin)
+ ()
+ (:default-initargs
+ :test-problem-kind "Error"))
+
+(defclass test-serious-condition (test-error-mixin)
+ ()
+ (:default-initargs
+ :test-problem-kind "Serious condition"))
+
+(defclass testsuite-error (test-error-mixin)
+ ()
+ (:default-initargs
+ :test-problem-kind "Testsuite error"))
+
+(defclass testsuite-serious-condition (test-error-mixin)
+ ()
+ (:default-initargs
+ :test-problem-kind "Testsuite serious condition"))
+
+(defclass testsuite-failure (generic-problem)
+ ()
+ (:default-initargs
+ :test-problem-kind "Testsuite failure"))
+
+(defclass testcase-skipped (generic-problem)
+ ()
+ (:default-initargs
+ :test-problem-kind "Test case skipped"))
+
+(defclass testsuite-skipped (generic-problem)
+ ()
+ (:default-initargs
+ :test-problem-kind "Testsuite skipped"))
+
+(defclass process-test-mixin (test-mixin)
+ ((maximum-time :initform *test-maximum-time*
+ :accessor maximum-time
+ :initarg :maximum-time)))
+
+(defclass test-timeout-failure (test-failure)
+ ((test-problem-kind :initform "Timeout" :allocation :class)))
+
View
12 dev/config.lisp
@@ -133,7 +133,8 @@ use asdf:test-op or bind *current-asdf-system-name* yourself."))))))
:direction :input
:if-does-not-exist :error)
(let ((form nil)
- (run-tests-p t))
+ (run-tests-p t)
+ (*lift-report-pathname* (report-summary-pathname)))
(loop while (not (eq (setf form (read *current-configuration-stream*
nil :eof nil)) :eof))
collect
@@ -172,15 +173,6 @@ use asdf:test-op or bind *current-asdf-system-name* yourself."))))))
path))
(declare (ignore result))
(values nil t)))
- #+(or)
- (with-simple-restart (cancel-testing-from-configuration
- "Cancel testing from file ~a" path)
- (if (find-testsuite name :errorp nil)
- (run-tests :suite name
- :result *test-result*
- :testsuite-initargs args)
- (show-test-warning
- "~&Warning: testsuite ~s not found, skipping" name)))
(declare (ignore _))
;; no more testing; continue to process commands
(when restartedp
View
156 dev/definitions.lisp
@@ -0,0 +1,156 @@
+;;;-*- Mode: Lisp; Package: lift -*-
+
+(in-package #:lift)
+
+;;; ---------------------------------------------------------------------------
+;;; global environment thingies
+;;; ---------------------------------------------------------------------------
+
+(defvar *current-testsuite-name* nil)
+(defvar *current-test-case-name* nil)
+
+(defvar *last-testsuite-name* nil)
+(defvar *last-test-case-name* nil)
+
+(defvar *test-is-being-defined?* nil)
+(defvar *test-is-being-compiled?* nil)
+(defvar *test-is-being-loaded?* nil)
+(defvar *test-is-being-executed?* nil)
+
+(defvar *test-maximum-error-count* nil
+ "The maximum numbers of errors to allow during a [run-tests][].
+
+If `*test-maximum-error-count*` is nil, then a call to run-tests
+will continue regardless of the number of errors. If it a positive
+integer, then run-tests will stop as soon as the number of test-errors
+if greater than or equal to its value. Setting this to some small
+value can help prevent running lengthly test-suites when there are many
+errors. See also [\\*test-maximum-failure-count\\*][].")
+
+(defvar *test-maximum-failure-count* nil
+ "The maximum numbers of failures to allow during a [run-tests][].
+
+If `*test-maximum-failure-count*` is nil, then a call to run-tests
+will continue regardless of the number of failures. If it a positive
+integer, then run-tests will stop as soon as the number of test-failures
+if greater than or equal to its value. Setting this to some small
+value can help prevent running lengthly test-suites when there are many
+failures. See also [\\*test-maximum-error-count\\*][].")
+
+(defvar *test-maximum-time* 2
+ "Maximum number of seconds a process test is allowed to run before we give up.")
+
+(defvar *test-break-on-errors?* nil)
+(defvar *test-break-on-failures?* nil)
+(defvar *test-run-subsuites?* t)
+
+(defparameter *test-ignore-warnings?* nil
+ "If true, LIFT will not cause a test to fail if a warning occurs while
+the test is running. Note that this may interact oddly with ensure-warning.")
+(defparameter *test-print-when-defined?* nil)
+(defparameter *test-evaluate-when-defined?* t)
+(defparameter *test-scratchpad* nil
+ "A place to put things. This is set to nil before every test.")
+(defparameter *test-notepad* nil
+ "Another place to put things \(see {ref *test-scratchpad*}\).")
+
+(defparameter *lift-equality-test* 'equal
+ "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
+
+(defvar *test-describe-if-not-successful?* nil
+ ;; Was t, but this behavior was extremely annoying since each
+ ;; time a test-restul appears in a stack backtrace it is printed
+ ;; over many unstructured lines.
+ "If true, then a complete test description is printed when there are any test warnings or failures. Otherwise, one would need to explicity call describe.")
+
+(defvar *test-print-length* :follow-print
+ "The print-length in effect when LIFT prints test results. It works exactly like `*print-length*` except that it can also take on the value :follow-print. In this case, it will be set to the value of `*print-length*`.")
+(defvar *test-print-level* :follow-print
+ "The print-level in effect when LIFT prints test results. It works exactly like `*print-level*` except that it can also take on the value :follow-print. In this case, it will be set to whatever `*print-level*` is.")
+
+(defparameter *skip-tests* nil
+ "A lift of test-suites and (testsuite test-case) pairs that LIFT will ignore
+during calls to run-tests.")
+
+(defvar *test-result* nil
+ "Set to the most recent test result by calls to run-test or run-tests.")
+
+(defvar *test-environment* nil)
+
+(defvar *test-metadata* (list)
+ "A place for LIFT to put stuff.")
+
+(defvar *current-test* nil
+ "The current testsuite.")
+
+(defvar *testsuite-test-count* nil
+ "Temporary variable used to 'communicate' between deftestsuite and addtest.")
+
+(defvar *lift-dribble-pathname* nil
+ "If bound, then test output from run-tests will be sent to this file in
+in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
+
+(defvar *lift-report-pathname* nil
+ "If bound to a pathname or stream, then a summary of test information will
+be written to it for later processing. It can be set to:
+
+* `nil` - generate no output
+* pathname designator - send output to this pathname
+* `t` - send output to a pathname constructed from the name of the system
+being tested (this only works if ASDF is being used to test the system).
+
+As an example of the last case, if LIFT is testing a system named ...
+")
+
+(defvar *lift-standard-output* *standard-output*
+ "Output from tests will be sent to this stream. If can set to nil or
+to an output stream. It defaults to *standard-output*.")
+
+(defvar *lift-if-dribble-exists* :append
+ "Specifies what to do to any existing file at *lift-dribble-pathname*. It
+can be :supersede, :append, or :error.")
+
+(defvar *test-show-expected-p* t)
+
+(defvar *test-show-details-p* t)
+
+(defvar *test-show-code-p* t)
+
+(defvar *current-definition* nil
+ "An associative-container which saves interesting information about
+the thing being defined.")
+
+(defvar *code-blocks* nil)
+
+(defvar *deftest-clauses*
+ '(:setup :teardown :test :documentation :tests :export-p :export-slots
+ :run-setup :dynamic-variables :equality-test :categories :function))
+
+;;; ---------------------------------------------------------------------------
+;;; Error messages and warnings
+;;; ---------------------------------------------------------------------------
+
+(defparameter +lift-test-name-not-supplied-with-test-class+
+ "if you specify a test-class, you must also specify a test-name.")
+
+(defparameter +lift-test-class-not-found+
+ "test class '~S' not found.")
+
+(defparameter +lift-confused-about-arguments+
+ "I'm confused about what you said?!")
+
+(defparameter +lift-no-current-test-class+
+ "There is no current-test-class to use as a default.")
+
+(defparameter +lift-could-not-find-test+
+ "Could not find test: ~S.~S")
+
+(defparameter +run-tests-null-test-case+
+ "There is no current testsuite (possibly because
+ none have been defined yet?). You can specify the
+ testsuite to test by evaluating (run-tests :suite <suitename>).")
+
+(defparameter +lift-unable-to-parse-test-name-and-class+
+ "")
+
+
View
16 dev/generics.lisp
@@ -13,9 +13,6 @@
(:documentation
"Returns whether or not the testsuite as a whole expects to fail."))
-(defgeneric testsuite-run (testsuite result)
- (:documentation "Run the cases in this suite and it's children."))
-
(defgeneric testsuite-teardown (testsuite result)
(:documentation "Cleanup at the testsuite level."))
@@ -30,16 +27,6 @@
(:documentation "Returns a list of the test methods defined for test. I.e.,
the methods that should be run to do the tests for this test."))
-(defgeneric do-testing (testsuite result fn)
- (:documentation ""))
-
-(defgeneric run-test-internal (suite name result &rest args)
- (:documentation ""))
-
-(defgeneric run-tests-internal (suite &rest args
- &key &allow-other-keys)
- (:documentation ""))
-
(defgeneric test-report-code (testsuite method)
(:documentation ""))
@@ -58,9 +45,6 @@ the methods that should be run to do the tests for this test."))
(defgeneric equality-test (testsuite)
(:documentation ""))
-(defgeneric do-testing-in-environment (testsuite result function)
- (:documentation ""))
-
;;?? probably just defuns (since they are hard to specialize on in any case)
;;?? or change signature to take testsuite instead of suite-name
(defgeneric skip-test-case (result suite-name test-case-name))
View
38 dev/introspection.lisp
@@ -40,6 +40,28 @@ all suites. This is equivalent to the behavior of [find-test-cases][]."))
;;;;;
;; some introspection
+(defmethod testsuite-p ((classname symbol))
+ (let ((class (find-class classname nil)))
+ (handler-case
+ (and class
+ (typep (allocate-instance class) 'test-mixin)
+ classname)
+ (error (c) (declare (ignore c)) (values nil)))))
+
+(defmethod testsuite-p ((object standard-object))
+ (testsuite-p (class-name (class-of object))))
+
+(defmethod testsuite-p ((class standard-class))
+ (testsuite-p (class-name class)))
+
+(defmethod testsuite-methods ((classname symbol))
+ (testsuite-tests classname))
+
+(defmethod testsuite-methods ((test test-mixin))
+ (testsuite-methods (class-name (class-of test))))
+
+(defmethod testsuite-methods ((test standard-class))
+ (testsuite-methods (class-name test)))
(defun liftpropos (string &key (include-cases? nil) (start-at 'test-mixin))
"Returns a list of testsuites whose name contains `string`."
@@ -168,7 +190,7 @@ control over where in the test hierarchy the search begins."
(defmethod find-testsuite ((suite test-mixin) &key (errorp nil))
(declare (ignore errorp))
- suite)
+ (class-name (class-of suite)))
(defmethod find-testsuite ((suite symbol) &key (errorp nil))
(or (testsuite-p suite)
@@ -281,6 +303,17 @@ control over where in the test hierarchy the search begins."
(t
nil)))
+(defun test-case-tested-p (suite name &key (result *test-result*))
+ (let ((suite-name (find-testsuite suite)))
+ (and result
+ (typep *test-result* 'test-result)
+ (slot-exists-p result 'tests-run)
+ (slot-boundp result 'suites-run)
+ (third (find-if (lambda (datum)
+ (and (eq (first datum) suite-name)
+ (eq (second datum) name)))
+ (tests-run result))))))
+
(defun suite-tested-p (suite &key (result *test-result*))
(let ((suite (find-testsuite suite)))
(and result
@@ -440,4 +473,5 @@ control over where in the test hierarchy the search begins."
(lift:run-tests
:suite (lift::suites-in-portion
(lift::collect-test-cases 'db.agraph.tests)
- '(:b)))
+ '(:b)))
+
View
669 dev/lift.lisp
@@ -2,295 +2,6 @@
(in-package #:lift)
-;;; ---------------------------------------------------------------------------
-;;; global environment thingies
-;;; ---------------------------------------------------------------------------
-
-(defparameter *make-testsuite-arguments*
- '(:run-setup :test-slot-names :equality-test :log-file :timeout
- :default-initargs :profile :expected-failure :expected-error))
-
-(defvar *current-testsuite-name* nil)
-(defvar *current-test-case-name* nil)
-
-(defvar *test-is-being-defined?* nil)
-(defvar *test-is-being-compiled?* nil)
-(defvar *test-is-being-loaded?* nil)
-(defvar *test-is-being-executed?* nil)
-
-(defvar *test-maximum-error-count* nil
- "The maximum numbers of errors to allow during a [run-tests][].
-
-If `*test-maximum-error-count*` is nil, then a call to run-tests
-will continue regardless of the number of errors. If it a positive
-integer, then run-tests will stop as soon as the number of test-errors
-if greater than or equal to its value. Setting this to some small
-value can help prevent running lengthly test-suites when there are many
-errors. See also [\\*test-maximum-failure-count\\*][].")
-
-(defvar *test-maximum-failure-count* nil
- "The maximum numbers of failures to allow during a [run-tests][].
-
-If `*test-maximum-failure-count*` is nil, then a call to run-tests
-will continue regardless of the number of failures. If it a positive
-integer, then run-tests will stop as soon as the number of test-failures
-if greater than or equal to its value. Setting this to some small
-value can help prevent running lengthly test-suites when there are many
-failures. See also [\\*test-maximum-error-count\\*][].")
-
-(defvar *test-maximum-time* 2
- "Maximum number of seconds a process test is allowed to run before we give up.")
-
-(defvar *test-break-on-errors?* nil)
-(defvar *test-break-on-failures?* nil)
-(defvar *test-run-subsuites?* t)
-
-(defparameter *test-ignore-warnings?* nil
- "If true, LIFT will not cause a test to fail if a warning occurs while
-the test is running. Note that this may interact oddly with ensure-warning.")
-(defparameter *test-print-when-defined?* nil)
-(defparameter *test-evaluate-when-defined?* t)
-(defparameter *test-scratchpad* nil
- "A place to put things. This is set to nil before every test.")
-(defparameter *test-notepad* nil
- "Another place to put things \(see {ref *test-scratchpad*}\).")
-
-(defparameter *lift-equality-test* 'equal
- "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
-
-(defvar *test-describe-if-not-successful?* nil
- ;; Was t, but this behavior was extremely annoying since each
- ;; time a test-restul appears in a stack backtrace it is printed
- ;; over many unstructured lines.
- "If true, then a complete test description is printed when there are any test warnings or failures. Otherwise, one would need to explicity call describe.")
-
-(defvar *test-print-length* :follow-print
- "The print-length in effect when LIFT prints test results. It works exactly like `*print-length*` except that it can also take on the value :follow-print. In this case, it will be set to the value of `*print-length*`.")
-(defvar *test-print-level* :follow-print
- "The print-level in effect when LIFT prints test results. It works exactly like `*print-level*` except that it can also take on the value :follow-print. In this case, it will be set to whatever `*print-level*` is.")
-
-(defparameter *skip-tests* nil
- "A lift of test-suites and (testsuite test-case) pairs that LIFT will ignore
-during calls to run-tests.")
-
-(defvar *test-result* nil
- "Set to the most recent test result by calls to run-test or run-tests.")
-
-(defvar *test-environment* nil)
-
-(defvar *test-metadata* (list)
- "A place for LIFT to put stuff.")
-
-(defvar *current-test* nil
- "The current testsuite.")
-
-(defvar *testsuite-test-count* nil
- "Temporary variable used to 'communicate' between deftestsuite and addtest.")
-
-(defvar *lift-dribble-pathname* nil
- "If bound, then test output from run-tests will be sent to this file in
-in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
-
-(defvar *lift-report-pathname* nil
- "If bound to a pathname or stream, then a summary of test information will
-be written to it for later processing. It can be set to:
-
-* `nil` - generate no output
-* pathname designator - send output to this pathname
-* `t` - send output to a pathname constructed from the name of the system
-being tested (this only works if ASDF is being used to test the system).
-
-As an example of the last case, if LIFT is testing a system named ...
-")
-
-(defvar *lift-standard-output* *standard-output*
- "Output from tests will be sent to this stream. If can set to nil or
-to an output stream. It defaults to *standard-output*.")
-
-(defvar *lift-if-dribble-exists* :append
- "Specifies what to do to any existing file at *lift-dribble-pathname*. It
-can be :supersede, :append, or :error.")
-
-(defvar *test-show-expected-p* t)
-
-(defvar *test-show-details-p* t)
-
-(defvar *test-show-code-p* t)
-
-
-;;; ---------------------------------------------------------------------------
-;;; Error messages and warnings
-;;; ---------------------------------------------------------------------------
-
-(defparameter +lift-test-name-not-supplied-with-test-class+
- "if you specify a test-class, you must also specify a test-name.")
-
-(defparameter +lift-test-class-not-found+
- "test class '~S' not found.")
-
-(defparameter +lift-confused-about-arguments+
- "I'm confused about what you said?!")
-
-(defparameter +lift-no-current-test-class+
- "There is no current-test-class to use as a default.")
-
-(defparameter +lift-could-not-find-test+
- "Could not find test: ~S.~S")
-
-(defparameter +run-tests-null-test-case+
- "There is no current testsuite (possibly because
- none have been defined yet?). You can specify the
- testsuite to test by evaluating (run-tests :suite <suitename>).")
-
-(defparameter +lift-unable-to-parse-test-name-and-class+
- "")
-
-
-;;; ---------------------------------------------------------------------------
-;;; classes
-;;; ---------------------------------------------------------------------------
-
-(defclass test-mixin ()
- ((name :initform nil :initarg :name :accessor name :reader testsuite-name)
- (run-setup :reader run-setup :initarg :run-setup)
- (done-setup? :initform nil :reader done-setup?)
- (done-dynamics? :initform nil :reader done-dynamics?)
- (test-slot-names :initform nil :initarg :test-slot-names
- :reader test-slot-names)
- (current-step :initform :created :accessor current-step)
- (current-method :initform nil :accessor current-method)
- (save-equality-test :initform nil :reader save-equality-test)
- (log-file :initform nil :initarg :log-file :reader log-file)
- (test-data :initform nil :accessor test-data)
- (expected-failure-p :initform nil :initarg :expected-failure-p
- :reader expected-failure-p)
- (expected-error-p :initform nil :initarg :expected-error-p
- :reader expected-error-p)
- (expected-problem-p :initform nil :initarg :expected-problem-p
- :reader expected-problem-p)
- (suite-initargs
- :initform nil
- :accessor suite-initargs)
- (profile
- :initform nil
- :initarg :profile
- :accessor profile))
- (:documentation "A test suite")
- (:default-initargs
- :run-setup :once-per-test-case))
-
-(defclass test-result ()
- ((results-for :initform nil
- :initarg :results-for
- :accessor results-for)
- (tests-run :initform nil :accessor tests-run)
- (suites-run :initform nil :accessor suites-run)
- (failures :initform nil :accessor failures)
- (expected-failures :initform nil :accessor expected-failures)
- (errors :initform nil :accessor errors)
- (expected-errors :initform nil :accessor expected-errors)
- (skipped-test-cases :initform nil :accessor skipped-test-cases)
- (skipped-testsuites :initform nil :accessor skipped-testsuites)
- (test-mode :initform :single :initarg :test-mode :accessor test-mode)
- (test-interactive? :initform nil
- :initarg :test-interactive? :accessor test-interactive?)
- (real-start-time :initarg :real-start-time :reader real-start-time)
- (start-time :accessor start-time :initform nil)
- (end-time :accessor end-time)
- (real-end-time :accessor real-end-time)
- (real-start-time-universal
- :initarg :real-start-time-universal :reader real-start-time-universal)
- (start-time-universal :accessor start-time-universal :initform nil)
- (end-time-universal :accessor end-time-universal)
- (real-end-time-universal :accessor real-end-time-universal)
- (properties :initform nil :accessor test-result-properties))
- (:documentation
-"A `test-result` instance contains all of the information collectd by
-LIFT during a test run.")
- (:default-initargs
- :test-interactive? *test-is-being-defined?*
- :real-start-time (get-internal-real-time)
- :real-start-time-universal (get-universal-time)))
-
-(defclass test-problem-mixin ()
- ((testsuite :initform nil :initarg :testsuite :reader testsuite)
- (test-method :initform nil :initarg :test-method :reader test-method)
- (test-condition :initform nil
- :initarg :test-condition
- :reader test-condition)
- (test-problem-kind :reader test-problem-kind :allocation :class)
- (test-step :initform nil :initarg :test-step :reader test-step)))
-
-(defmethod print-object ((problem test-problem-mixin) stream)
- (print-unreadable-object (problem stream)
- (format stream "TEST-~@:(~A~): ~A in ~A"
- (test-problem-kind problem)
- (name (testsuite problem))
- (test-method problem))))
-
-(defclass generic-problem (test-problem-mixin)
- ((test-problem-kind :initarg :test-problem-kind
- :allocation :class)))
-
-(defclass expected-problem-mixin ()
- ((documentation :initform nil
- :initarg :documentation
- :accessor failure-documentation)))
-
-(defclass test-expected-failure (expected-problem-mixin generic-problem)
- ())
-
-(defmethod test-problem-kind ((problem test-expected-failure))
- "Expected failure")
-
-(defclass test-failure (generic-problem)
- ()
- (:default-initargs
- :test-problem-kind "failure"))
-
-(defclass test-error-mixin (generic-problem)
- ((backtrace :initform nil :initarg :backtrace :reader backtrace)))
-
-(defclass test-expected-error (expected-problem-mixin test-error-mixin)
- ()
- (:default-initargs
- :test-problem-kind "Expected error"))
-
-(defclass test-error (test-error-mixin)
- ()
- (:default-initargs
- :test-problem-kind "Error"))
-
-(defclass test-serious-condition (test-error-mixin)
- ()
- (:default-initargs
- :test-problem-kind "Serious condition"))
-
-(defclass testsuite-error (test-error-mixin)
- ()
- (:default-initargs
- :test-problem-kind "Testsuite error"))
-
-(defclass testsuite-serious-condition (test-error-mixin)
- ()
- (:default-initargs
- :test-problem-kind "Testsuite serious condition"))
-
-(defclass testsuite-failure (generic-problem)
- ()
- (:default-initargs
- :test-problem-kind "Testsuite failure"))
-
-(defclass testcase-skipped (generic-problem)
- ()
- (:default-initargs
- :test-problem-kind "Test case skipped"))
-
-(defclass testsuite-skipped (generic-problem)
- ()
- (:default-initargs
- :test-problem-kind "Testsuite skipped"))
-
(defmethod accumulate-problem ((problem test-failure) result)
(setf (failures result) (append (failures result) (list problem))))
@@ -325,16 +36,6 @@ LIFT during a test run.")
(setf (skipped-testsuites result)
(append (skipped-testsuites result) (list problem))))
-
-(defclass process-test-mixin (test-mixin)
- ((maximum-time :initform *test-maximum-time*
- :accessor maximum-time
- :initarg :maximum-time)))
-
-(defclass test-timeout-failure (test-failure)
- ((test-problem-kind :initform "Timeout" :allocation :class)))
-
-
;;; ---------------------------------------------------------------------------
;;; test conditions
;;; ---------------------------------------------------------------------------
@@ -532,11 +233,6 @@ LIFT during a test run.")
(gb (gensym "b-"))
(gtest (gensym "test-")))
`(block ,gblock
- #+(or)
- (when *current-test*
- (when (atom (current-step *current-test*))
- (setf (current-step *current-test*) (list (current-step *current-test*))))
- (push :comparison (current-step *current-test*)))
(flet ((,gtest (,ga ,gb)
(,@(cond (test-specified-p
(if (atom test)
@@ -557,9 +253,6 @@ LIFT during a test run.")
,(if test-specified-p (list 'quote test) '*lift-equality-test*)
,report ,@arguments)
(return-from ,gblock nil))))
- #+(or)
- (when *current-test*
- (setf (current-step *current-test*) (second (current-step *current-test*))))
(values t))))
(defun maybe-raise-not-same-condition (value-1 value-2 test
@@ -598,10 +291,10 @@ LIFT during a test run.")
(defmethod testsuite-setup :before ((testsuite test-mixin) (result test-result))
(push (type-of testsuite) (suites-run result))
- (setf (current-step testsuite) :testsuite-setup))
+ (setf (current-step result) :testsuite-setup))
(defmethod testsuite-expects-error ((testsuite test-mixin))
- nil)
+ nil)
(defmethod testsuite-expects-failure ((testsuite test-mixin))
nil)
@@ -612,32 +305,30 @@ LIFT during a test run.")
(defmethod testsuite-teardown :after
((testsuite test-mixin) (result test-result))
- (setf (current-step testsuite) :testsuite-teardown
+ (setf (current-step result) :testsuite-teardown
(real-end-time result) (get-internal-real-time)
(real-end-time-universal result) (get-universal-time)))
;;;;
-(defun canonize-skip-tests ()
- (when *skip-tests*
- (setf *skip-tests*
- (mapcar
- (lambda (datum)
- (cond ((or (atom datum)
- (and (= (length datum) 1)
- (setf datum (first datum)))
- (and (= (length datum) 2) (null (second datum))
- (setf datum (first datum))))
- (cons (find-testsuite datum :errorp t) nil))
- ((= (length datum) 2)
- (cons (find-testsuite (first datum) :errorp t)
- (or (and (keywordp (second datum)) (second datum))
- (find-test-case (find-testsuite (first datum))
- (second datum) :errorp t))))
- (t
- (warn "Unable to interpret skip datum ~a. Ignoring."
- datum))))
- *skip-tests*))))
+(defun canonize-skip-tests (skip-tests)
+ (mapcar
+ (lambda (datum)
+ (cond ((or (atom datum)
+ (and (= (length datum) 1)
+ (setf datum (first datum)))
+ (and (= (length datum) 2) (null (second datum))
+ (setf datum (first datum))))
+ (cons (find-testsuite datum :errorp t) nil))
+ ((= (length datum) 2)
+ (cons (find-testsuite (first datum) :errorp t)
+ (or (and (keywordp (second datum)) (second datum))
+ (find-test-case (find-testsuite (first datum))
+ (second datum) :errorp t))))
+ (t
+ (warn "Unable to interpret skip datum ~a. Ignoring."
+ datum))))
+ skip-tests))
(defun test-result-property (result property &optional default)
(getf (test-result-properties result) property default))
@@ -652,29 +343,28 @@ LIFT during a test run.")
#'equal)
(defmethod setup-test :before ((test test-mixin))
- (setf *test-scratchpad* nil
- (current-step test) :test-setup))
+ (setf *test-scratchpad* nil))
(defmethod setup-test ((test test-mixin))
(values))
(defmethod setup-test ((test symbol))
- (setup-test (make-testsuite test nil)))
+ (let ((*current-test* (make-testsuite test nil)))
+ (setup-test *current-test*)
+ *current-test*))
(defmethod test-case-teardown progn ((test test-mixin) (result test-result))
(values))
(defmethod test-case-teardown :around ((test test-mixin) (result test-result))
- (setf (current-step test) :test-teardown)
+ (setf (current-step result) :test-teardown)
(call-next-method))
(defmethod initialize-instance :after ((testsuite test-mixin) &rest initargs
&key &allow-other-keys)
(when (null (testsuite-name testsuite))
(setf (slot-value testsuite 'name)
- (symbol-name (type-of testsuite))))
- ;; FIXME - maybe remove LIFT standard arguments?
- (setf (suite-initargs testsuite) initargs))
+ (symbol-name (type-of testsuite)))))
(defmethod print-object ((tc test-mixin) stream)
(print-unreadable-object (tc stream :identity t :type t)
@@ -684,10 +374,6 @@ LIFT during a test run.")
;;; macros
;;; ---------------------------------------------------------------------------
-(defvar *current-definition* nil
- "An associative-container which saves interesting information about
-the thing being defined.")
-
(defun initialize-current-definition ()
(setf *current-definition* nil))
@@ -705,8 +391,6 @@ the thing being defined.")
(defun (setf def) (value name)
(set-definition name value))
-(defvar *code-blocks* nil)
-
(defstruct (code-block (:type list) (:conc-name nil))
block-name (priority 0) filter code operate-when)
@@ -729,10 +413,6 @@ the thing being defined.")
:key (lambda (name.cb)
(priority (cdr name.cb))))))
-(defvar *deftest-clauses*
- '(:setup :teardown :test :documentation :tests :export-p :export-slots
- :run-setup :dynamic-variables :equality-test :categories :function))
-
(defmacro deftest (testsuite-name superclasses slots &rest
clauses-and-options)
"The `deftest` form is obsolete, see [deftestsuite][]."
@@ -744,8 +424,7 @@ the thing being defined.")
(add-code-block
:setup 1 :methods
- (lambda ()
- (or (def :setup) (def :direct-slot-names)))
+ (lambda () t)
'((setf (def :setup) (cleanup-parsed-parameter value)))
'build-setup-test-method)
@@ -953,8 +632,8 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
,(build-test-class)
(unwind-protect
(let ((*test-is-being-defined?* t))
- (setf *current-test-case-name* nil)
- (setf *current-testsuite-name* ',(def :testsuite-name)
+ (setf *last-test-case-name* nil)
+ (setf *last-testsuite-name* ',(def :testsuite-name)
(test-slots ',(def :testsuite-name))
',(def :slot-names)
(testsuite-dynamic-variables ',(def :testsuite-name))
@@ -985,15 +664,16 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(special
,@(mapcar
#'car (def :dynamic-variables))))
- (cond ((done-dynamics? suite)
- (call-next-method))
- (t
- (setf (slot-value suite 'done-dynamics?) t)
- (let* (,@(def :dynamic-variables))
- (declare (special
- ,@(mapcar
- #'car (def :dynamic-variables))))
- (call-next-method)))))))
+ (with-test-slots
+ (cond ((done-dynamics? suite)
+ (call-next-method))
+ (t
+ (setf (slot-value suite 'done-dynamics?) t)
+ (let* (,@(def :dynamic-variables))
+ (declare (special
+ ,@(mapcar
+ #'car (def :dynamic-variables))))
+ (call-next-method))))))))
;; tests
,@(when test-list
`((let ((*test-evaluate-when-defined?* nil))
@@ -1080,8 +760,8 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
;; the 'name' is really part of the test...
(setf body (cons name test))))
(unless (def :testsuite-name)
- (when *current-testsuite-name*
- (setf (def :testsuite-name) *current-testsuite-name*)))
+ (when *last-testsuite-name*
+ (setf (def :testsuite-name) *last-testsuite-name*)))
(unless (def :testsuite-name)
(signal-lift-error 'add-test +lift-no-current-test-class+))
(unless (or (def :deftestsuite)
@@ -1099,7 +779,7 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(let ((*test-is-being-defined?* t))
(muffle-redefinition-warnings
,(build-test-test-method (def :testsuite-name) body options))
- (setf *current-testsuite-name* ',(def :testsuite-name))
+ (setf *last-testsuite-name* ',(def :testsuite-name))
(if *test-evaluate-when-defined?*
(unless (or *test-is-being-compiled?*
*test-is-being-loaded?*)
@@ -1147,20 +827,30 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
;; FIXME - stub
nil)
-(defun remove-test (&key (test-case *current-test-case-name*)
- (suite *current-testsuite-name*))
+(defun remove-test (&key (test-case *last-test-case-name*)
+ (suite *last-testsuite-name*))
(assert suite nil "Test suite could not be determined.")
(assert test-case nil "Test-case could not be determined.")
(setf (testsuite-tests suite)
(remove test-case (testsuite-tests suite))))
-
+#+(or)
(defun make-testsuite (suite-name args)
- (let ((testsuite (find-testsuite suite-name :errorp t)))
+ (let ((testsuite (find-testsuite suite-name :errorp t))
+ result)
(if testsuite
- (apply #'make-instance testsuite args)
- (error "Testsuite ~a not found." suite-name))))
+ (setf result (apply #'make-instance testsuite args))
+ (error "Testsuite ~a not found." suite-name))
+ (setf (testsuite-initargs result) args)
+ result))
+(defun make-testsuite (suite-name args)
+ (let ((testsuite (find-testsuite suite-name :errorp t))
+ result)
+ (if testsuite
+ (setf result (apply #'make-instance testsuite args))
+ (error "Testsuite ~a not found." suite-name))
+ result))
(defun skip-test-case-p (result suite-name test-case-name)
(declare (ignore result))
@@ -1179,91 +869,81 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
*skip-tests*))
(defmethod skip-test-case (result suite-name test-case-name)
- (declare (ignore suite-name))
- (report-test-problem
- 'testcase-skipped result *current-test* test-case-name nil))
+ (report-test-problem 'testcase-skipped result suite-name test-case-name nil))
(defmethod skip-testsuite (result suite-name)
- (declare (ignore suite-name))
- (report-test-problem
- 'testsuite-skipped result *current-test* nil nil))
-
-(defun testcase-expects-error-p (&optional (test *current-test*))
- (let* ((options (getf (test-data test) :options)))
- (or (testsuite-expects-error test)
- (second (member :expected-error options)))))
-
-(defun testcase-expects-failure-p (&optional (test *current-test*))
- (let* ((options (getf (test-data test) :options)))
- (or (testsuite-expects-failure test)
- (second (member :expected-failure options)))))
-
-(defun testcase-expects-problem-p (&optional (test *current-test*))
- (let* ((options (getf (test-data test) :options)))
- (second (member :expected-problem options))))
-
-(defun check-for-surprises (testsuite)
- (let* ((expected-failure-p (testcase-expects-failure-p testsuite))
- (expected-error-p (testcase-expects-error-p testsuite))
- (expected-problem-p (testcase-expects-problem-p testsuite))
+ (report-test-problem 'testsuite-skipped result suite-name nil nil))
+
+(defun test-case-expects-error-p (suite-name test-case-name)
+ (or (testsuite-expects-error *current-test*)
+ (test-case-option suite-name test-case-name :expected-error)))
+
+(defun test-case-expects-failure-p (suite-name test-case-name)
+ (or (testsuite-expects-failure *current-test*)
+ (test-case-option suite-name test-case-name :expected-failure)))
+
+(defun test-case-expects-problem-p (suite-name test-case-name)
+ (test-case-option suite-name test-case-name :expected-problem))
+
+(defun check-for-surprises (suite-name test-case-name)
+ (let* ((expected-failure-p (test-case-expects-failure-p
+ suite-name test-case-name))
+ (expected-error-p (test-case-expects-error-p
+ suite-name test-case-name))
+ (expected-problem-p (test-case-expects-problem-p
+ suite-name test-case-name))
(condition nil))
- (cond
- (expected-failure-p
- (setf (slot-value testsuite 'expected-failure-p) expected-failure-p))
- (expected-error-p
- (setf (slot-value testsuite 'expected-error-p) expected-error-p))
- (expected-problem-p
- (setf (slot-value testsuite 'expected-problem-p) expected-problem-p)))
(cond
- ((expected-failure-p testsuite)
+ (expected-failure-p
(setf condition
(make-condition 'unexpected-success-failure
:expected :failure
- :expected-more (expected-failure-p testsuite))))
- ((expected-error-p testsuite)
+ :expected-more expected-failure-p)))
+ (expected-error-p
(setf condition
(make-condition 'unexpected-success-failure
:expected :error
- :expected-more (expected-error-p testsuite))))
- ((expected-problem-p testsuite)
+ :expected-more expected-error-p)))
+ (expected-problem-p
(setf condition
(make-condition 'unexpected-success-failure
:expected :problem
- :expected-more (expected-problem-p testsuite)))))
+ :expected-more expected-problem-p))))
(when condition
(if (find-restart 'ensure-failed)
(invoke-restart 'ensure-failed condition)
(warn condition)))))
-(defun report-test-problem (problem-type result suite method condition
+(defun report-test-problem (problem-type result suite-name method condition
&rest args)
;; ick
(let ((docs nil)
(option nil))
(declare (ignorable docs option))
(cond ((and (eq problem-type 'test-failure)
(not (typep condition 'unexpected-success-failure))
- (testcase-expects-failure-p suite))
+ (test-case-expects-failure-p suite-name method))
(setf problem-type 'test-expected-failure
option :expected-failure))
((and (eq problem-type 'test-error)
- (testcase-expects-error-p suite))
+ (test-case-expects-error-p suite-name method))
(setf problem-type 'test-expected-error
option :expected-error))
((and (or (eq problem-type 'test-failure)
(eq problem-type 'test-error))
- (testcase-expects-problem-p suite))
+ (test-case-expects-problem-p suite-name method))
(setf problem-type (or (and (eq problem-type 'test-failure)
'test-expected-failure)
(and (eq problem-type 'test-error)
'test-expected-error))
option :expected-problem)))
(let ((problem (apply #'make-instance problem-type
- :testsuite suite
+ :testsuite suite-name
:test-method method
:test-condition condition
- :test-step (current-step suite) args)))
- (setf (getf (test-data suite) :problem) problem)
+ :test-step (current-step result) args)))
+ (when *current-test*
+ (setf (getf (test-data *current-test*) :problem) problem))
(accumulate-problem problem result)
(when (and *test-maximum-failure-count*
(numberp *test-maximum-failure-count*)
@@ -1295,16 +975,14 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(let ((foo *test-print-level*))
(if (eq foo :follow-print) *print-level* foo)))
-(defun record-start-times (suite)
- (declare (ignore name))
- (setf (current-step suite) :start-test
+(defun record-start-times (result suite)
+ (setf (current-step result) :start-test
(test-data suite)
`(:start-time ,(get-internal-real-time)
:start-time-universal ,(get-universal-time))))
(defun record-end-times (result suite)
- (declare (ignore name))
- (setf (current-step suite) :end-test
+ (setf (current-step result) :end-test
(getf (test-data suite) :end-time) (get-internal-real-time)
(end-time result) (get-internal-real-time)
(getf (test-data suite) :end-time-universal) (get-universal-time)
@@ -1463,19 +1141,18 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
show-code-p))))
(defun print-test-problem (prefix report stream show-code-p)
- (let* ((suite (testsuite report))
+ (let* ((suite-name (testsuite report))
(method (test-method report))
(condition (test-condition report))
- (code (test-report-code suite method))
+ (code (test-report-code suite-name method))
(step (test-step report))
(testsuite-name method)
(*print-level* (get-test-print-level))
(*print-length* (get-test-print-length)))
(let ((*package* (symbol-package method))
(doc-string (gethash testsuite-name
- (test-case-documentation
- (class-name (class-of suite))))))
- (format stream "~&~A~(~A : ~A~)" prefix (type-of suite) testsuite-name)
+ (test-case-documentation suite-name))))
+ (format stream "~&~A~(~A : ~A~)" prefix suite-name testsuite-name)
(if show-code-p
(setf code (with-output-to-string (out)
(pprint code out)))
@@ -1492,12 +1169,15 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
;;; test-reports
;;; ---------------------------------------------------------------------------
-
+#+(or)
(defmethod test-report-code ((testsuite test-mixin) (method symbol))
(let* ((class-name (class-name (class-of testsuite))))
(gethash method
(test-name->code-table class-name))))
+(defmethod test-report-code ((testsuite symbol) (method symbol))
+ (gethash method (test-name->code-table testsuite)))
+
;;; ---------------------------------------------------------------------------
;;; utilities
;;; ---------------------------------------------------------------------------
@@ -1535,9 +1215,17 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(not (length-1-list-p classes-removed)))))))
(defun (setf test-environment-value) (value name)
+ (setf (slot-value *current-test* name) value))
+
+(defun test-environment-value (name)
+ (slot-value *current-test* name))
+
+#+(or)
+(defun (setf test-environment-value) (value name)
(push (cons name value) *test-environment*)
(values value))
+#+(or)
(defun test-environment-value (name)
(cdr (assoc name *test-environment*)))
@@ -1623,34 +1311,13 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(setf setup (list setup)))
(when (symbolp (first setup))
(setf setup (list setup))))
- (let ((ginitargs (gensym "initargs-")))
- (multiple-value-bind (slots initforms)
- (%gather-up-initforms)
- (when (or setup slots)
- `(progn
- (defmethod setup-test :after ((testsuite ,test-name))
- (with-test-slots
- ,@(when slots
- `((let ((,ginitargs (suite-initargs testsuite)))
- ,@(loop for slot-name in slots
- for initform in initforms
- for keyword = (intern (symbol-name slot-name)
- :keyword)
- collect
- `(setf (test-environment-value ',slot-name)
- (or (getf ,ginitargs ,keyword)
- ,initform))))))
- ,@setup))))))))
-
-(defun %gather-up-initforms ()
- (let ((initforms nil)
- (slot-names nil)
- (slot-specs (def :slot-specs)))
- (loop for slot in (def :direct-slot-names)
- for spec = (assoc slot slot-specs) do
- (push (getf (rest spec) :initform) initforms)
- (push (first spec) slot-names))
- (values (nreverse slot-names) (nreverse initforms))))
+ (if setup
+ `(defmethod setup-test :after ((testsuite ,test-name))
+ (with-test-slots
+ ,@setup))
+ ;; rather use remove-method
+ `(defmethod setup-test :after ((testsuite ,test-name))
+ ))))
(defmethod setup-test :around ((test test-mixin))
(when (run-setup-p test)
@@ -1698,28 +1365,32 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(unless (find ',test-name (testsuite-tests ',test-class))
(setf (testsuite-tests ',test-class)
(append (testsuite-tests ',test-class) (list ',test-name))))
+ ;;?? to defer until after compile...?
+ (load-time-value
+ ,@(when options
+ (list (build-test-case-options
+ test-class test-name options))))
(setf (gethash ',test-name (test-name->methods ',test-class))
(lambda (testsuite)
(declare (ignorable testsuite))
- ,@(when options
- `((setf (getf (test-data testsuite) :options)
- (list ,@(loop for (k v) on options by #'cddr append
- (list k v))))))
+ ,@(when options
+ (list (build-test-case-options
+ test-class test-name options)))
(with-test-slots ,@body)))
- (setf *current-test-case-name* ',test-name)
+ (setf *last-test-case-name* ',test-name)
(when (and *test-print-when-defined?*
(not (or *test-is-being-compiled?*
)))
(format *debug-io* "~&;Test Created: ~(~S.~S~)."
',test-class ',test-name))
- *current-test-case-name*)))
+ *last-test-case-name*)))
(defun parse-test-body (test-body)
(let ((test-name nil)
(body nil)
(parsed-body nil)
(documentation nil)
- (test-number (1+ (testsuite-test-count *current-testsuite-name*)))
+ (test-number (1+ (testsuite-test-count *last-testsuite-name*)))
(name-supplied? nil))
;; parse out any documentation
(loop for form in test-body do
@@ -1735,10 +1406,10 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(intern (format nil "~A" test-name))
body (rest test-body)
name-supplied? t))
- ((and (test-code->name-table *current-testsuite-name*)
+ ((and (test-code->name-table *last-testsuite-name*)
(setf test-name
(gethash test-body
- (test-code->name-table *current-testsuite-name*))))
+ (test-code->name-table *last-testsuite-name*))))
(setf body test-body))
(t
(setf test-name
@@ -1763,11 +1434,13 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(pushnew 'test-mixin (def :superclasses)))
;; build basic class and standard class
`(defclass ,(def :testsuite-name) (,@(def :superclasses))
- nil
+ ,(loop for name in (def :direct-slot-names) collect
+ (let ((it (find name (def :slot-specs) :key #'car)))
+ (assert it)
+ it))
,@(when (def :documentation)
`((:documentation ,(def :documentation))))
(:default-initargs
- :test-slot-names ',(def :slot-names)
,@(def :default-initargs))))
(defun parse-test-slots (slot-specs)
@@ -1779,30 +1452,6 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(subseq parsed-spec (+ pos 2))))
parsed-spec))))
-(defmethod testsuite-p ((classname symbol))
- (let ((class (find-class classname nil)))
- (handler-case
- (and class
- (typep (allocate-instance class) 'test-mixin)
- classname)
- (error (c) (declare (ignore c)) (values nil)))))
-
-(defmethod testsuite-p ((object standard-object))
- (testsuite-p (class-name (class-of object))))
-
-(defmethod testsuite-p ((class standard-class))
- (testsuite-p (class-name class)))
-
-(defmethod testsuite-methods ((classname symbol))
- (testsuite-tests classname))
-
-(defmethod testsuite-methods ((test test-mixin))
- (testsuite-methods (class-name (class-of test))))
-
-(defmethod testsuite-methods ((test standard-class))
- (testsuite-methods (class-name test)))
-
-
;; some handy properties
(defclass-property test-slots)
(defclass-property test-code->name-table)
@@ -1867,10 +1516,11 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
(timeout-error
(c)
(declare (ignore c))
- (report-test-problem
- 'test-timeout-failure result testsuite (current-method testsuite)
- (make-instance 'test-timeout-condition
- :maximum-time (maximum-time testsuite))))))
+ (let ((suite-name (class-name (class-of testsuite))))
+ (report-test-problem
+ 'test-timeout-failure result suite-name (current-method testsuite)
+ (make-instance 'test-timeout-condition
+ :maximum-time (maximum-time testsuite)))))))
;;?? might be "cleaner" with a macrolet (cf. lift-result)
(defun lift-property (name)
@@ -1889,11 +1539,44 @@ Test options are one of :setup, :teardown, :test, :tests, :documentation, :expor
#+Later
(defmacro with-test (&body forms)
"Execute forms in the context of the current test class."
- (let* ((testsuite-name *current-testsuite-name*)
+ (let* ((testsuite-name *last-testsuite-name*)
(test-case (make-instance test-class)))
`(eval-when (:execute)
(prog2
(setup-test ,test-case)
(progn
(with-test-slots ,@forms))
(test-case-teardown ,test-case result)))))
+
+(defvar *test-case-options* (make-hash-table))
+
+(defun remove-test-case-options (suite-name)
+ (remhash suite-name *test-case-options*))
+
+(defun test-case-option (suite-name case-name option-name)
+ (let* ((suite-options (gethash suite-name *test-case-options*))
+ (case-options (and suite-options
+ (gethash case-name suite-options))))
+ (getf (car case-options) option-name)))
+
+(defun (setf test-case-option) (value suite-name case-name option-name)
+ (let ((suite-options (gethash suite-name *test-case-options*)))
+ (unless suite-options
+ (setf suite-options (setf (gethash suite-name *test-case-options*)
+ (make-hash-table))))
+ (multiple-value-bind (case-options found?)
+ (gethash case-name suite-options)
+ (unless found?
+ (setf case-options
+ (setf (gethash case-name suite-options) (cons nil nil))))
+ (setf (getf (car case-options) option-name) value))))
+
+(defun build-test-case-options (suite-name case-name options)
+ (loop for (k v) on options by #'cddr append
+ `(setf (test-case-option ',suite-name ',case-name ,k) ,v)))
+
+#|
+(test-case-option 'test-dependencies-helper 'test-c :depends-on)
+(setf (test-case-option 'test-dependencies-helper 'test-c :depends-on) :test-c)
+(remove-test-case-options 'test-dependencies-helper)
+|#
View
2 dev/port.lisp
@@ -58,6 +58,7 @@ returns a string with the corresponding backtrace.")
#+allegro
(defun get-backtrace-as-string (error)
+ (declare (ignore error))
(with-output-to-string (s)
(with-standard-io-syntax
(let ((*print-readably* nil)
@@ -66,6 +67,7 @@ returns a string with the corresponding backtrace.")
(tpl:*zoom-print-circle* t)
(tpl:*zoom-print-level* nil)
(tpl:*zoom-print-length* nil))
+ #+(or)
(cl:ignore-errors
(format *terminal-io* "~&~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
error))
View
21 dev/reports.lisp
@@ -330,7 +330,7 @@ lift::(progn
(report-tests-by-suite
format
(mapcar (lambda (problem)
- `(,(type-of (testsuite problem))
+ `(,(testsuite problem)
,(test-method problem)
(:problem ,problem)))
problems)
@@ -901,9 +901,9 @@ lift::(progn
(package-name (symbol-package symbol)))))
(mapcar (lambda (glitch)
(if (test-method glitch)
- (list (encode-symbol (type-of (testsuite glitch)))
+ (list (encode-symbol (testsuite glitch))
(encode-symbol (test-method glitch)))
- (encode-symbol (type-of (testsuite glitch)))))
+ (encode-symbol (testsuite glitch))))
list))))
#+(or)
@@ -977,14 +977,11 @@ lift::(progn
(unwind-protect
(multiple-value-bind (result measures errorp)
(while-measuring (t measure-seconds measure-space)
- (handler-case
- (with-timeout (timeout)
- (funcall profile-fn style count-calls-p))
- (timeout-error
- (c)
- (declare (ignore c)))
- (error (c)
- (error c))))
+ (handler-bind
+ ((timeout-error (lambda (_) (declare (ignore _))))
+ (error (lambda (c) (error c))))
+ (with-timeout (timeout)
+ (funcall profile-fn style count-calls-p))))
(setf seconds (first measures) conses (second measures)
results result error errorp))
;; cleanup / ensure we get report
@@ -1181,7 +1178,7 @@ lift::(progn
(report-tests-by-suite
format
(mapcar (lambda (problem)
- `(,(type-of (testsuite problem))
+ `(,(testsuite problem)
,(test-method problem)
(:problem ,problem)))
cases)
View
316 dev/test-runner.lisp
@@ -2,130 +2,90 @@
(defvar *in-middle-of-failure?* t)
-(defun run-test (&rest args
- &key (test-case *current-test-case-name*)
- (name test-case name-supplied-p)
- (suite *current-testsuite-name*)
+(defun run-test (&key
+ (name *last-test-case-name*)
+ (suite *last-testsuite-name*)
(break-on-errors? *test-break-on-errors?*)
(break-on-failures? *test-break-on-failures?*)
- (do-children? *test-run-subsuites?*)
(result nil)
(profile nil)
(testsuite-initargs nil))
- "Run a single testcase in a test suite. Will run the most recently defined or run testcase unless the name and suite arguments are used to override them."
- (when name-supplied-p
- (setf test-case name))
+ "Run a single test-case in a testsuite. Will run the most recently
+defined or run testcase unless the name and suite arguments are used
+to override them."
(assert suite nil "Test suite could not be determined.")
- (assert test-case nil "Test-case could not be determined.")
- (let ((args-copy (copy-list args)))
- (declare (ignore args-copy))
- (remf args :suite)
- (remf args :break-on-errors?)
- (remf args :break-on-failures?)
- (remf args :run-setup)
- (remf args :dribble)
- (remf args :config)
- (remf args :report-pathname)
- (remf args :do-children?)
- (remf args :skip-tests)
- (remf args :testsuite-initargs)
- (let* ((*test-break-on-errors?* break-on-errors?)
- (*test-break-on-failures?* break-on-failures?)
- (*test-run-subsuites?* do-children?)
- (*current-test*
- (make-testsuite
- suite
- (if (find :profile testsuite-initargs)
- testsuite-initargs
- (setf testsuite-initargs
- `(:profile ,profile ,@testsuite-initargs))))))
- (unless result
- (setf result (make-test-result suite :single)))
- (prog1
- (let ((*current-test-case-name* (find-test-case suite test-case))
- (*current-testsuite-name* suite)
- (*test-result* result))
- (do-testing-in-environment
- *current-test* result
- (lambda ()
- (apply #'run-test-internal
- *current-test* *current-test-case-name* result nil))))
- (setf *test-result* result)
- (setf *current-test-case-name* (find-test-case suite test-case)
- *current-testsuite-name* suite)))))
+ (assert name nil "Test-case could not be determined.")
+ (when profile
+ (push profile testsuite-initargs)
+ (push :profile testsuite-initargs))
+ (let* ((*test-break-on-errors?* break-on-errors?)
+ (*test-break-on-failures?* break-on-failures?))
+ (unless result
+ (setf result (make-test-result
+ suite :single :testsuite-initargs testsuite-initargs)))
+ (prog1
+ (let ((*current-test-case-name* (find-test-case suite name))
+ (*test-result* result))
+ (do-testing-in-environment
+ suite result
+ (lambda ()
+ (run-test-internal *current-test* *current-test-case-name* result))))
+ (setf *test-result* result)
+ (setf *last-test-case-name* (find-test-case suite name)
+ *last-testsuite-name* suite))))
-(defmethod do-testing-in-environment :around ((suite test-mixin) result fn)
- (declare (ignore fn))
- (catch :test-end
- (tagbody
- :test-start
- (restart-case
- (handler-bind ((warning #'muffle-warning)
+(defun do-testing-in-environment (suite-name result fn)
+ (let ((suite nil)
+ (*current-testsuite-name* suite-name))
+ (catch :test-end
+ (tagbody
+ :test-start
+ (restart-case
+ (handler-bind ((warning #'muffle-warning)
; ignore warnings...
- #+(and allegro)
- (excl:interrupt-signal
- (lambda (_)
- (declare (ignore _))
- (cancel-testing :interrupt)))
- (error
- (lambda (condition)
- (handle-error-while-testing
- condition 'testsuite-error suite result)
- (go :test-end)))
- (serious-condition
- (lambda (condition)
- (handle-error-while-testing
- condition 'testsuite-serious-condition
- suite result)
- (go :test-end))))
- (unwind-protect
- (let ((*lift-equality-test* (equality-test suite)))
- (%start-test-suite (type-of suite) result)
- (testsuite-setup suite result)
- (call-next-method)
- result)
- ;; cleanup
- (testsuite-teardown suite result)))
- (ensure-failed (condition)
- :test (lambda (c) (declare (ignore c)) *in-middle-of-failure?*)
- (report-test-problem
- 'testsuite-failure result suite
- *current-test-case-name* condition))
- (retry-test ()
- :report (lambda (s) (format s "Re-run testsuite ~a"
- *current-testsuite-name*))
- (go :test-start)))
- :test-end))
- (values result))
-
-(defmethod do-testing-in-environment ((suite test-mixin) result fn)
- (do-testing suite result fn)
+ #+(and allegro)
+ (excl:interrupt-signal
+ (lambda (_)
+ (declare (ignore _))
+ (cancel-testing :interrupt)))
+ (error
+ (lambda (condition)
+ (handle-error-while-testing
+ condition 'testsuite-error suite-name result)
+ (go :test-end)))
+ (serious-condition
+ (lambda (condition)
+ (handle-error-while-testing
+ condition 'testsuite-serious-condition
+ suite-name result)
+ (go :test-end))))
+ (setf (current-step result) :create)
+ (setf suite (make-testsuite
+ suite-name (testsuite-initargs result)))
+ (let ((*current-test* suite))
+ (unwind-protect
+ (let ((*lift-equality-test* (equality-test suite)))
+ (%start-test-suite (type-of suite) result)
+ (testsuite-setup suite result)
+ (do-testing suite result fn)
+ result)
+ ;; cleanup
+ (testsuite-teardown suite result))))
+ (ensure-failed (condition)
+ :test (lambda (c) (declare (ignore c)) *in-middle-of-failure?*)
+ (report-test-problem
+ 'testsuite-failure result suite-name
+ *current-test-case-name* condition))
+ (retry-test ()
+ :report (lambda (s) (format s "Re-run testsuite ~a"
+ *current-testsuite-name*))
+ (go :test-start)))
+ :test-end)))
(values result))
(defmethod do-testing ((suite test-mixin) result fn)
(funcall fn)
- (values result))
-
-(defmethod run-tests-internal ((suite symbol) &rest args
- &key &allow-other-keys)
- (let ((*current-test* (make-testsuite suite args))
- (passthrough-arguments nil))
- (loop for arg in '(:result :do-children?)
- when (getf args arg) do
- (push (getf args arg) passthrough-arguments)
- (push arg passthrough-arguments))
- (apply #'run-tests-internal *current-test* passthrough-arguments)))
-
-(defmethod run-tests-internal
- ((case test-mixin) &key
- (result (make-test-result (class-of case) :multiple))
- (do-children? *test-run-subsuites?*))
- (let ((*test-run-subsuites?* do-children?))
- (do-testing-in-environment
- case result
- (lambda ()
- (testsuite-run case result)))
- (setf *test-result* result)))
+ result)
(defun run-tests (&rest args &key
(suite nil)
@@ -142,7 +102,6 @@
result
&allow-other-keys)
"Run all of the tests in a suite."
- (declare (ignore profile))
(prog1
(let ((args-copy (copy-list args)))
(remf args :suite)
@@ -156,17 +115,19 @@
(remf args :do-children?)
(remf args :testsuite-initargs)
(remf args :profile)
+ (when profile
+ (push profile testsuite-initargs)
+ (push :profile testsuite-initargs))
(let* ((*lift-report-pathname*
(cond ((null report-pathname) nil)
((eq report-pathname t)
(report-summary-pathname))
(t
report-pathname)))
(*test-run-subsuites?* do-children?)
- (*skip-tests* skip-tests)
+ (*skip-tests* (canonize-skip-tests skip-tests))
(*print-readably* nil)
(report-pathname *lift-report-pathname*))
- (canonize-skip-tests)
(when report-pathname
(ensure-directories-exist report-pathname))
(cond ((and suite config)
@@ -180,10 +141,12 @@ but not both."))
(write-log-header report-pathname result args-copy))
(let* ((*test-result* result))
(setf result (run-tests-from-file config))))
- ((or suite (setf suite *current-testsuite-name*))
+ ((or suite (setf suite *last-testsuite-name*))
(unless result
(setf result
- (apply #'make-test-result suite :multiple args)))
+ (apply #'make-test-result suite
+ :multiple
+ :testsuite-initargs testsuite-initargs args)))
(when report-pathname
(write-log-header report-pathname result args-copy))
(let* ((*test-break-on-errors?* break-on-errors?)
@@ -204,13 +167,7 @@ but not both."))
*debug-io* dribble-stream)))
(unwind-protect
(restart-case
- (dolist (testsuite (if (consp suite)
- suite (list suite)))
- (let ((*current-testsuite-name* testsuite))
- (apply #'run-tests-internal testsuite
- :result result
- testsuite-initargs))
- (setf *current-testsuite-name* testsuite))
+ (run-tests-internal suite result)
(cancel-testing (&optional (result *test-result*))
:report (lambda (stream)
(format stream "Cancel testing of ~a"
@@ -230,7 +187,18 @@ but not both."))
nor configuration file options were specified.")))))
(setf *test-result* result)))
-(defmethod testsuite-run ((testsuite test-mixin) (result test-result))
+(defun run-tests-internal (suite-name result)
+ (dolist (suite-name (if *test-run-subsuites?*
+ (collect-testsuites suite-name)
+ (list suite-name)))
+ (do-testing-in-environment
+ suite-name result
+ (lambda ()
+ (testsuite-run *current-test* result)))
+ (setf *test-result* result)))
+
+(defun testsuite-run (testsuite result)
+ "Run the cases in `testsuite`"
(let* ((methods (testsuite-methods testsuite))
(suite-name (class-name (class-of testsuite)))
(*current-testsuite-name* suite-name))
@@ -241,41 +209,18 @@ nor configuration file options were specified.")))))
(setf (start-time result) (get-internal-real-time)
(start-time-universal result) (get-universal-time)))
(unwind-protect
- (progn
- (loop for method in methods do
- (let ((data nil))
- (cond ((skip-test-case-p result suite-name method)
- (setf data
- `(:problem ,(skip-test-case
- result suite-name method))))
- (t
- (setf data (run-test-internal
- testsuite method result))))
- (when *lift-report-pathname*
- (write-log-test
- :save suite-name method data
- :stream *lift-report-pathname*))))
- (when *test-run-subsuites?*
- (if (skip-test-suite-children-p result suite-name)
- (skip-testsuite result suite-name)
- (loop for subclass in (direct-subclasses (class-of testsuite))
- when (and (testsuite-p subclass)
- (not (member (class-name subclass)
- (suites-run result)))) do
- (run-tests-internal (class-name subclass)
- :result result)))))
- (setf (end-time result) (get-universal-time)))))))
-
-(defmethod run-test-internal ((suite symbol) (name symbol) result
- &rest args &key &allow-other-keys)
- (let ((*current-test* (make-testsuite suite args))
- (passthrough-arguments nil))
- (loop for arg in '(:result :do-children?)
- when (getf args arg) do
- (push (getf args arg) passthrough-arguments)
- (push arg passthrough-arguments))
- (apply #'run-test-internal
- *current-test* name result passthrough-arguments)))
+ (loop for method in methods do
+ (let ((data
+ (if (skip-test-case-p result suite-name method)
+ `(:problem ,(skip-test-case
+ result suite-name method))
+ (run-test-internal testsuite method result))))
+ (when *lift-report-pathname*
+ (write-log-test
+ :save suite-name method data
+ :stream *lift-report-pathname*))))
+ (setf (end-time result) (get-universal-time)))))
+ (setf *last-testsuite-name* suite-name)))
(defmethod do-test ((suite test-mixin) name result)
(declare (ignore result))
@@ -285,22 +230,25 @@ nor configuration file options were specified.")))))
(funcall fn suite)
(error "expected to find ~a test for ~a but didn't" name suite-name))))
-(defmethod run-test-internal ((suite test-mixin) (name symbol) result
- &rest _)
- (declare (ignore _))
- (let ((result-pushed? nil)
- (*current-test-case-name* name)
- (error nil))
+(defun run-test-internal (suite test-case-name result)
+ (let* ((result-pushed? nil)
+ (suite-name (class-name (class-of suite)))
+ (*current-test-case-name* test-case-name)
+ (*current-testsuite-name* suite-name)
+ (error nil))
+ (loop for case in (ensure-list
+ (test-case-option suite-name test-case-name :depends-on))
+ unless (test-case-tested-p suite-name case) do
+ (run-test-internal suite case result))
(flet ((maybe-push-result ()
- (let ((datum (list (type-of suite)
- *current-test-case-name* (test-data suite))))
+ (let ((datum (list suite-name test-case-name (test-data suite))))
(cond ((null result-pushed?)
(setf result-pushed? t)
(push datum (tests-run result)))
(t
;; replace
(setf (first (tests-run result)) datum))))))
- (%start-test-case name result)
+ (%start-test-case test-case-name result)
(tagbody
:test-start
(restart-case
@@ -314,30 +262,31 @@ nor configuration file options were specified.")))))
(error
(lambda (condition)
(handle-error-while-testing
- condition 'test-error suite result)
+ condition 'test-error suite-name result)
(go :test-end)))
(serious-condition
(lambda (condition)
(handle-error-while-testing
- condition 'test-serious-condition suite result)
+ condition 'test-serious-condition
+ suite-name result)
(go :test-end))))
- (setf (current-method suite) name)
- (record-start-times suite)
+ (setf (current-method suite) test-case-name)
+ (record-start-times result suite)
(unwind-protect
(progn
(setup-test suite)
- (setf (current-step suite) :testing)
+ (setf (current-step result) :testing)
(multiple-value-bind (result measures error-condition)
(while-measuring (t measure-space measure-seconds)
- (do-test suite name result))
+ (do-test suite test-case-name result))
(declare (ignore result))
(setf error error-condition)
(destructuring-bind (space seconds) measures
(setf (getf (test-data suite) :seconds) seconds
(getf (test-data suite) :conses) space)))
(when error
(error error))
- (check-for-surprises suite))
+ (check-for-surprises suite-name test-case-name))
;; cleanup
(maybe-push-result)
(test-case-teardown suite result)
@@ -346,10 +295,11 @@ nor configuration file options were specified.")))))
:test (lambda (c) (declare (ignore c))
*in-middle-of-failure?*)
(report-test-problem
- 'test-failure result suite
+ 'test-failure result suite-name
*current-test-case-name* condition)
(if (and *test-break-on-failures?*
- (not (testcase-expects-failure-p)))
+ (not (test-case-expects-failure-p
+ suite-name test-case-name)))
(let ((*in-middle-of-failure?* nil))
(invoke-debugger condition))
(go :test-end)))
@@ -359,18 +309,18 @@ nor configuration file options were specified.")))))
(go :test-start)))
:test-end)
(maybe-push-result)))
- (setf *current-test-case-name* name
- *test-result* result)
+ (setf *current-test-case-name* test-case-name *test-result* result)
(third (first (tests-run result))))
-(defun handle-error-while-testing (condition error-class suite result)
+(defun handle-error-while-testing (condition error-class suite-name result)
(let ((*in-middle-of-failure?* nil))
(report-test-problem
- error-class result suite
+ error-class result suite-name
*current-test-case-name* condition
:backtrace (get-backtrace condition))
(when (and *test-break-on-errors?*
- (not (testcase-expects-error-p)))
+ (not (test-case-expects-error-p
+ *current-testsuite-name* *current-test-case-name*)))
(invoke-debugger condition))))
(defun maybe-add-dribble (stream dribble-stream)
View
22 dev/utilities.lisp
@@ -201,8 +201,9 @@ the class itself is not included in the mapping. Proper? defaults to nil."
slot)))))
(unless (null (cddr slot-spec))
(error "Slot-spec must be a symbol or a list of length one or two. `~s` has too many elements." slot))
- `(,(first slot-spec) ,@(when (second slot-spec)
- `(:initform ,(second slot-spec))))))
+ `(,(first slot-spec)
+ :initarg ,(form-keyword (first slot-spec))
+ :initform ,(when (second slot-spec) `,(second slot-spec)))))
(defun convert-clauses-into-lists (clauses-and-options clauses-to-convert)
;; This is useful (for me at least!) for writing macros
@@ -240,6 +241,9 @@ the class itself is not included in the mapping. Proper? defaults to nil."
(function thing)
(symbol (symbol-function thing))))
+(defun ensure-list (thing)
+ (if (listp thing) thing (list thing)))
+
;;;;
(defun version-numbers (version &optional padded)
@@ -408,3 +412,17 @@ and nil otherwise."
(function (and symbol (symbol-function symbol))))
(when function
(apply function args))))
+
+(defun form-groups (list size)
+ (let ((result nil)
+ (count 0)
+ (sub-result nil))
+ (flet ((add-one ()
+ (push (nreverse sub-result) result)
+ (setf sub-result nil count 0)))
+ (loop for a in list do
+ (when (= count size) (add-one))
+ (push a sub-result)
+ (incf count))
+ (when (= count size) (add-one))
+ (values (nreverse result) (nreverse sub-result)))))
View
2 lift-test.asd
@@ -10,6 +10,8 @@
"setup"
:pathname "test/"
:components ((:file "packages")
+ (:file "utilities"
+ :depends-on ("packages"))
(:file "lift-test"
:depends-on ("packages"))))
(:module
View
15 lift.asd
@@ -23,7 +23,11 @@
(:file "utilities"
:depends-on ("packages" "macros"))
(:file "macros"
- :depends-on ("packages"))))
+ :depends-on ("packages"))
+ (:file "definitions"
+ :depends-on ("packages"))
+ (:file "class-defs"
+ :depends-on ("definitions"))))
(:module
"api"
:pathname "dev/"
@@ -72,12 +76,3 @@
(defmethod operation-done-p
((o test-op) (c (eql (find-system 'lift))))
(values nil))
-
-(when (find-system 'asdf-system-connections nil)
- (asdf:operate 'asdf:load-op 'asdf-system-connections))
-
-#+asdf-system-connections
-(asdf:defsystem-connection lift-report-locations
- :requires (:lift :asdf-binary-locations)
- :components ((:module "dev"
- :components ((:file "report-locations")))))
View
254 test/lift-test.lisp
@@ -8,7 +8,11 @@ See file COPYING for license
(in-package #:lift-test)
-(deftestsuite lift-test () ())
+(deftestsuite lift-test ()
+ ()
+ (:dynamic-variables
+ (*test-break-on-errors?* nil)
+ (*test-break-on-failures?* nil)))
;;; ---------------------------------------------------------------------------
;;; lift-test-ensure
@@ -327,27 +331,6 @@ See file COPYING for license
(run-test :suite 'test-ignore-warnings-helper-no-warning :name 'do-it)
(ensure-same *test-scratchpad* '(:b :a)))
-;;; ---------------------------------------------------------------------------
-;;; test-environment stays clean
-;;; ---------------------------------------------------------------------------
-
-(deftestsuite lift-test-environment-pristine (lift-test) ()
- (:setup (setf *test-environment* nil)))
-
-(deftestsuite lift-test-environment-pristine-helper ()
- ((a 2)
- (b (* a a))))
-
-(addtest (lift-test-environment-pristine-helper)
- do-it
- (ensure-same (* a a) b))
-
-(addtest (lift-test-environment-pristine
- :expected-failure "This is no longer guarenteed; I'm not sure yet whether or not this is a good thing.")
- test-1
- (run-test :suite 'lift-test-environment-pristine-helper :name 'do-it)
- (ensure (null *test-environment*)))
-
;;; ---------------------------------------------------------------------------
;;; test-creating-multiple-tests
@@ -368,29 +351,29 @@ See file COPYING for license
;;;;;
-(defvar *dynamics-before-setup* :dbs)
+(defvar *dynamics-after-setup* :das)
-(deftestsuite dynamics-before-setup (lift-test)
+(deftestsuite dynamics-after-setup (lift-test)
()
:setup (setf *test-notepad* nil))
-(deftestsuite dynamics-before-setup-helper ()
+(deftestsuite dynamics-after-setup-helper ()
((slot (progn (push :slot *test-notepad*) :slot)))
- :dynamic-variables (*dynamics-before-setup*
+ :dynamic-variables (*dynamics-after-setup*
(progn (push :dynamics *test-notepad*) :dynamics))
(:setup (push :setup *test-notepad*) (print (list :tn *test-notepad*))))
-(addtest (dynamics-before-setup-helper)
+(addtest (dynamics-after-setup-helper)
test-1
(push :test *test-notepad*)
- (ensure-same *dynamics-before-setup* :dynamics))
+ (ensure-same *dynamics-after-setup* :dynamics))
-(addtest (dynamics-before-setup)
+(addtest (dynamics-after-setup)
test-1
- (run-test :suite 'dynamics-before-setup-helper
+ (run-test :suite 'dynamics-after-setup-helper
:name 'test-1)
(ensure-same (reverse *test-notepad*)
- '(:dynamics :slot :setup :test)))
+ '(:slot :dynamics :setup :test)))
;;;;;
@@ -425,7 +408,7 @@ See file COPYING for license
;;;;;
-;;; slot initialization takes place with every setup
+;;; slot initialization takes place ONCE
(deftestsuite test-initialize-slots-helper ()
((slot (incf *test-notepad*))))
@@ -447,7 +430,7 @@ See file COPYING for license
(let ((tr (run-tests :suite 'test-initialize-slots-helper
:report-pathname nil)))
(ensure-same (length (tests-run tr)) 2)
- (ensure-same *test-notepad* 2 :test '=)))
+ (ensure-same *test-notepad* 1 :test '=)))
;;;;;
;;; errors during tests are reported in the test result
@@ -469,7 +452,8 @@ See file COPYING for license
helper-slot-init
(let ((result (run-test :suite 'test-error-catching-helper-slot-init
:name 'slot-init)))
- (ensure-same 1 (length (lift::suites-run result)) :report "tests run")
+ ;;?? test not run because error occurred during setup
+ (ensure-same 0 (length (lift::suites-run result)) :report "tests run")
(ensure-same 1 (length (errors result)) :report "errors counted")))
;;;
@@ -572,37 +556,40 @@ See file COPYING for license
run-test-sets-values
(run-test :suite 'lift-test-ensure-helper :name 'simple-ensure-test-3)
(ensure-same
- (symbol-name lift::*current-test-case-name*)
+ (symbol-name lift::*last-test-case-name*)
(symbol-name 'simple-ensure-test-3))
(ensure-same
- (symbol-name lift::*current-testsuite-name*)
+ (symbol-name lift::*last-testsuite-name*)
(symbol-name 'lift-test-ensure-helper)))
(addtest (test-interaction)
run-tests-sets-values
(run-tests :suite 'lift-test-ensure-helper
:report-pathname nil)
(ensure-same
- (symbol-name lift::*current-testsuite-name*)
+ (symbol-name lift::*last-testsuite-name*)
(symbol-name 'lift-test-ensure-helper))
(ensure-same
- (symbol-name lift::*current-test-case-name*)
+ (symbol-name lift::*last-test-case-name*)
(symbol-name 'simple-ensure-test-3)))
(addtest (test-interaction)
run-test-sets-values-nested
- (run-test :suite 'test-interaction :test-case 'run-tests-sets-values)
+ (run-test :suite 'test-interaction :name 'run-tests-sets-values)
(ensure-same
- (symbol-name lift::*current-testsuite-name*)
+ (symbol-name lift::*last-testsuite-name*)
(symbol-name 'test-interaction))
(ensure-same
- (symbol-name lift::*current-test-case-name*)
+ (symbol-name lift::*last-test-case-name*)
(symbol-name 'run-tests-sets-values)))
;;;;
(deftestsuite test-expected-errors (lift-test)
- ())
+ ()
+ (:dynamic-variables
+ (*test-break-on-errors?* nil)
+ (*test-break-on-failures?* nil)))
(deftestsuite test-expected-errors-helper ()
())
@@ -688,13 +675,13 @@ See file COPYING for license
(addtest (test-scratchpad-resets)
run-once-have-one
- (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
+ (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
(ensure-same '(:test) *test-scratchpad*))
(addtest (test-scratchpad-resets)
run-twice-have-one
- (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
- (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
+ (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
+ (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
(ensure-same '(:test) *test-scratchpad*))
(addtest (test-scratchpad-resets)
@@ -790,7 +777,10 @@ See file COPYING for license
(:documentation
"LIFT should keep running tests even when a testcase gets a
serious condition. (though maybe there should be an option that
-these cancel testing instead.)"))
+these cancel testing instead.)")
+ (:dynamic-variables
+ (*test-break-on-errors?* nil)
+ (*test-break-on-failures?* nil)))
(deftestsuite handle-serious-condition-helper ()
())
@@ -879,4 +869,176 @@ these cancel testing instead.)"))
(ensure-null (lift::test-result-properties result))
)
+|#
+
+(deftestsuite test-default-initargs-abstract (lift-test)
+ ())
+
+(deftestsuite test-default-initargs-parent (test-default-initargs-abstract)
+ (a (b 1))
+ (:default-initargs
+ :a :parent
+ :c :inherit))
+
+(addtest (test-default-initargs-parent)
+ no-initform
+ (ensure-same a :parent))
+
+(addtest (test-default-initargs-parent)
+ with-initform
+ (ensure-same b 1))
+
+(deftestsuite test-default-initargs-child (test-default-initargs-parent)
+ (c)
+ (:default-initargs
+ :a :child))
+