dev/lift.lisp

   1 ;;;-*- Mode: Lisp; Package: lift -*-
   2
   3 (in-package #:lift)
   4
   5 (defmethod accumulate-problem ((problem test-failure-mixin) result)
   6   (setf (failures result) (append (failures result) (list problem))))
   7
   8 (defmethod accumulate-problem ((problem testsuite-failure) result)
   9   (setf (failures result) (append (failures result) (list problem))))
  10
  11 (defmethod accumulate-problem ((problem test-expected-failure) result)
  12   (setf (expected-failures result)
  13         (append (expected-failures result) (list problem))))
  14
  15 (defmethod accumulate-problem ((problem test-error-mixin) result)
  16   (setf (errors result) (append (errors result) (list problem))))
  17
  18 (defmethod accumulate-problem ((problem testsuite-error) result)
  19   (setf (errors result) (append (errors result) (list problem))))
  20
  21 (defmethod accumulate-problem ((problem test-serious-condition) result)
  22   (setf (errors result) (append (errors result) (list problem))))
  23
  24 (defmethod accumulate-problem ((problem testsuite-serious-condition) result)
  25   (setf (errors result) (append (errors result) (list problem))))
  26
  27 (defmethod accumulate-problem ((problem test-expected-error) result)
  28   (setf (expected-errors result)
  29         (append (expected-errors result) (list problem))))
  30
  31 (defmethod accumulate-problem ((problem testcase-skipped) result)
  32   (setf (skipped-test-cases result)
  33         (append (skipped-test-cases result) (list problem))))
  34
  35 (defmethod accumulate-problem ((problem testsuite-skipped) result)
  36   (setf (skipped-testsuites result)
  37         (append (skipped-testsuites result) (list problem))))
  38
  39
  40 ;;; ---------------------------------------------------------------------------
  41 ;;; test conditions
  42 ;;; ---------------------------------------------------------------------------
  43
  44 (defcondition (lift-compile-error :exportp nil) (error)
  45   (msg)
  46   "Compile error: '~S'" msg)
  47
  48 (defcondition testsuite-not-defined (lift-compile-error)
  49   (testsuite-name)
  50   "Test class ~A not defined before it was used."
  51   testsuite-name)
  52
  53 (defcondition testsuite-ambiguous (lift-compile-error)
  54   (testsuite-name possible-matches)
  55   "There are several test suites named ~s: they are ~{~s~^, ~}"
  56   testsuite-name possible-matches)
  57
  58 (defcondition test-case-not-defined (lift-compile-error)
  59   (testsuite-name test-case-name)
  60   "Testsuite ~s has no test-case named ~s."
  61   testsuite-name test-case-name)
  62
  63 (defcondition test-case-ambiguous (lift-compile-error)
  64   (testsuite-name test-case-name possible-matches)
  65   "There are several test cases named ~s.~s: they are ~{~s~^, ~}"
  66   testsuite-name test-case-name possible-matches)
  67
  68 (defcondition test-condition (warning)
  69   ((message :initform ""))
  70   "~%~A" message)
  71
  72 (defcondition (test-timeout-condition :slot-names (message)) (test-condition)
  73   ((maximum-time :initform *test-maximum-time*))
  74   "Test ran out of time (longer than ~S-second~:P)"
  75   maximum-time)
  76
  77 (defcondition (ensure-failed-error  :slot-names (message)) (test-condition)
  78   ((assertion :initform ""))
  79    "Ensure failed: ~S ~@[(~a)~]" assertion message)
  80
  81 (defcondition (ensure-null-failed-error :slot-names (message)) (ensure-failed-error)
  82   ((value :initform "")
  83    (assertion :initform ""))
  84   "Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
  85   assertion value message)
  86
  87 (defcondition ensure-expected-condition (test-condition)
  88   ((expected-condition-type
  89     :initform nil)
  90    (the-condition
  91     :initform nil))
  92   "Expected ~S but got ~S~@[:~_   ~A~]"
  93   expected-condition-type
  94   (type-of the-condition)
  95   (and (typep the-condition 'condition)
  96        the-condition))
  97
  98 (defcondition ensure-expected-no-warning-condition (test-condition)
  99   ((the-condition
 100     :initform nil))
 101   "Expected no warnings but got ~S"
 102   the-condition)
 103
 104 (defcondition failed-comparison-condition (test-condition)
 105   (first-value second-value test))
 106
 107 (defcondition (ensure-not-same :slot-names (first-value second-value test message))
 108     (failed-comparison-condition)
 109   ()
 110   "Ensure-same: ~S is not ~a to ~S~@[ (~a)~]"
 111   first-value (test-function-name test)
 112   second-value message)
 113
 114 (defcondition (ensure-same :slot-names (first-value second-value test message))
 115     (failed-comparison-condition)
 116   ()
 117   "Ensure-different: ~S is ~a to ~S~@[ (~a)~]"
 118   first-value (test-function-name test) second-value message)
 119
 120 (defcondition ensure-cases-failure (test-condition)
 121   ((total :initform 0)
 122    (problems :initform nil)
 123    (errors :initform nil))
 124   (format
 125    stream
 126    "Ensure-cases: ~d case~:p with ~[~:;~:*~d error~:p; ~]~[~:;~:*~d failure~:p; ~]"
 127    total (length errors) (length problems))
 128   (when errors
 129     (format stream "~&Errors: ~@<  ~@;~{~%  ~{~20s ~3,8@t~a~}~^, ~}~:>"
 130             errors))
 131   (when problems
 132     (format stream "~&Failures: ~@<  ~@;~{~%  ~{~20s ~3,8@t~a~}~^, ~}~:>"
 133             problems)))
 134
 135 (defcondition unexpected-success-failure (test-condition)
 136   (expected expected-more)
 137   "Test succeeded but we expected ~s (~s)"
 138   expected expected-more)
 139
 140 (defun build-lift-error-message (context message &rest arguments)
 141   (format nil "~A: ~A"
 142           context
 143           (apply #'format nil message arguments)))
 144
 145 (defun signal-lift-error (context message &rest arguments)
 146   (let ((c (make-condition
 147             'lift-compile-error
 148             :msg (apply #'build-lift-error-message
 149                                  context message arguments))))
 150     (unless (signal c)
 151       (error c))))
 152
 153 (defun report-lift-error (context message &rest arguments)
 154   (format *debug-io* "~&~A."
 155           (apply #'build-lift-error-message context message arguments))
 156   (values))
 157
 158 (defun lift-report-condition (c)
 159   (format *debug-io* "~&~A." c))
 160
 161 (defun %build-ensure-comparison
 162     (form values guard-fn test test-specified-p report arguments
 163      ignore-multiple-values?)
 164   (setf test (remove-leading-quote test))
 165   (when (and (consp test)
 166              (eq (first test) 'function))
 167     (setf test (second test)))
 168   (let ((gblock (gensym "block-"))
 169         (ga (gensym "a-"))
 170         (gb (gensym "b-"))
 171         (gtest (gensym "test-")))
 172     `(block ,gblock
 173        (flet ((,gtest (,ga ,gb)
 174                 (,@(cond (test-specified-p
 175                           (if (atom test)
 176                               (list test)
 177                               `(funcall ,test)))
 178                          (t
 179                           `(funcall *lift-equality-test*)))
 180                    ,ga ,gb)))
 181          (loop for value in (,(if ignore-multiple-values?
 182                                   'list 'multiple-value-list) ,form)
 183             for other-value in (,(if ignore-multiple-values?
 184                                      'list 'multiple-value-list) ,values) do
 185             (,guard-fn (,gtest value other-value)
 186                        (,(ecase guard-fn
 187                                 (unless 'maybe-raise-not-same-condition)
 188                                 (when 'maybe-raise-ensure-same-condition))
 189                          value other-value
 190                          ,(if test-specified-p (list 'quote test) '*lift-equality-test*)
 191                          ,report ,@arguments)
 192                        (return-from ,gblock nil))))
 193        (values t))))
 194
 195 (defun maybe-raise-not-same-condition (value-1 value-2 test
 196                                        report &rest arguments)
 197   (let ((condition (make-condition 'ensure-not-same
 198                                    :first-value value-1
 199                                    :second-value value-2
 200                                    :test test
 201                                    :message (when report
 202                                               (apply #'format nil
 203                                                      report arguments)))))
 204     (if (find-restart 'ensure-failed)
 205       (invoke-restart 'ensure-failed condition)
 206       (warn condition))))
 207
 208 (defun maybe-raise-ensure-same-condition (value-1 value-2 test
 209                                        report &rest arguments)
 210   (let ((condition (make-condition 'ensure-same
 211                                    :first-value value-1
 212                                    :second-value value-2
 213                                    :test test
 214                                    :message (when report
 215                                               (apply #'format nil
 216                                                      report arguments)))))
 217     (if (find-restart 'ensure-failed)
 218       (invoke-restart 'ensure-failed condition)
 219       (warn condition))))
 220
 221
 222 ;;; ---------------------------------------------------------------------------
 223 ;;; test-mixin
 224 ;;; ---------------------------------------------------------------------------
 225
 226 (defmethod testsuite-setup ((testsuite test-mixin) (result test-result))
 227   (values))
 228
 229 (defmethod testsuite-setup :before ((testsuite test-mixin) (result test-result))
 230   (push (type-of testsuite) (suites-run result))
 231   (setf (current-step result) :testsuite-setup))
 232
 233 (defmethod testsuite-expects-error ((testsuite test-mixin))
 234   nil)
 235
 236 (defmethod testsuite-expects-failure ((testsuite test-mixin))
 237   nil)
 238
 239 (defmethod testsuite-teardown ((testsuite test-mixin) (result test-result))
 240   ;; no-op
 241   )
 242
 243 (defmethod testsuite-teardown :after
 244     ((testsuite test-mixin) (result test-result))
 245   (setf (current-step result) :testsuite-teardown
 246         (real-end-time result) (get-test-real-time)
 247         (real-end-time-universal result) (get-universal-time)))
 248
 249 ;;;;
 250
 251 (defun canonize-skip-tests (skip-tests)
 252   (mapcar
 253    (lambda (datum)
 254      (cond ((or (atom datum)
 255                 (and (= (length datum) 1)
 256                      (setf datum (first datum)))
 257                 (and (= (length datum) 2) (null (second datum))
 258                      (setf datum (first datum))))
 259             (cons (find-testsuite datum :errorp t) nil))
 260            ((= (length datum) 2)
 261             (cons (find-testsuite (first datum) :errorp t)
 262                   (or (and (keywordp (second datum)) (second datum))
 263                       (find-test-case (find-testsuite (first datum))
 264                                       (second datum) :errorp t))))
 265            (t
 266             (warn "Unable to interpret skip datum ~a. Ignoring."
 267                   datum))))
 268    skip-tests))
 269
 270 (defun test-result-property (result property &optional default)
 271   (getf (test-result-properties result) property default))
 272
 273 (defun (setf test-result-property) (value result property)
 274   (setf (getf (test-result-properties result) property) value))
 275
 276 (defmethod write-profile-information ((suite t))
 277   )
 278
 279 (defmethod equality-test ((suite test-mixin))
 280   #'equal)
 281
 282 (defmethod setup-test :before ((test test-mixin))
 283   (setf *test-scratchpad* nil))
 284
 285 (defmethod setup-test ((test test-mixin))
 286   (values))
 287
 288 (defmethod setup-test ((test symbol))
 289   (let ((*current-test* (make-testsuite test nil)))
 290     (setup-test *current-test*)
 291     *current-test*))
 292
 293 (defmethod test-case-teardown progn ((test test-mixin) (result test-result))
 294   (values))
 295
 296 (defmethod test-case-teardown :around ((test test-mixin) (result test-result))
 297   (setf (current-step result) :test-teardown)
 298   (call-next-method))
 299
 300 (defmethod initialize-instance :after ((testsuite test-mixin) &rest initargs
 301                                        &key &allow-other-keys)
 302   (when (null (testsuite-name testsuite))
 303     (setf (slot-value testsuite 'name)
 304           (symbol-name (type-of testsuite)))))
 305
 306 (defmethod print-object ((tc test-mixin) stream)
 307   (print-unreadable-object (tc stream :identity t :type t)
 308     (format stream "~a" (testsuite-name tc))))
 309
 310 ;;; ---------------------------------------------------------------------------
 311 ;;; macros
 312 ;;; ---------------------------------------------------------------------------
 313
 314 (defun initialize-current-definition ()
 315   (setf *current-definition* nil))
 316
 317 (defun set-definition (name value)
 318   (let ((current (assoc name *current-definition*)))
 319     (if current
 320       (setf (cdr current) value)
 321       (push (cons name value) *current-definition*)))
 322
 323   (values value))
 324
 325 (defun def (name &optional (definition *current-definition*))
 326   (when definition (cdr (assoc name definition))))
 327
 328 (defun (setf def) (value name)
 329   (set-definition name value))
 330
 331 (defstruct (code-block (:type list) (:conc-name nil))
 332   block-name (priority 0) filter code operate-when)
 333
 334 (defun add-code-block (name priority operate-when filter handler code)
 335   (let ((current (assoc name *code-blocks*))
 336         (value (make-code-block
 337                 :operate-when operate-when
 338                 :block-name name
 339                 :priority priority
 340                 :filter filter
 341                 :code code)))
 342     (if current
 343       (setf (cdr current) value)
 344       (push (cons name value) *code-blocks*))
 345     (eval
 346      `(defmethod block-handler ((name (eql ',name)) value)
 347         (declare (ignorable value))
 348         ,@handler)))
 349     (setf *code-blocks* (sort *code-blocks* #'<
 350                               :key (lambda (name.cb)
 351                                      (priority (cdr name.cb))))))
 352
 353 (defmacro deftest (testsuite-name superclasses slots &rest
 354                                   clauses-and-options)
 355   "The `deftest` form is obsolete, see [deftestsuite][]."
 356
 357   (warn "Deftest is obsolete, use deftestsuite instead.")
 358   `(deftestsuite ,testsuite-name ,superclasses ,slots ,@clauses-and-options))
 359
 360 (setf *code-blocks* nil)
 361
 362 (add-code-block
 363  :setup 1 :methods
 364  (lambda () t)
 365  '((setf (def :setup) (cleanup-parsed-parameter value)))
 366  'build-setup-test-method)
 367
 368 (add-code-block
 369  :teardown 100 :methods
 370  (lambda () (or (def :teardown) (def :direct-slot-names)))
 371  '((setf (def :teardown) (cleanup-parsed-parameter value)))
 372  'build-test-teardown-method)
 373
 374 (add-code-block
 375  :function 0 :methods
 376  (lambda () (def :functions))
 377  '((push value (def :functions)))
 378  'build-test-local-functions)
 379
 380 (add-code-block
 381  :documentation 0 :class-def
 382  nil
 383  '((setf (def :documentation) (first value)))
 384  nil)
 385
 386 (add-code-block
 387  :export-p 0 :class-def
 388  nil
 389  '((setf (def :export-p) (first value)))
 390  nil)
 391
 392 (add-code-block
 393  :export-slots 0 :class-def
 394  nil
 395  '((setf (def :export-slots) (first value)))
 396  nil)
 397
 398 (add-code-block
 399  :run-setup 0 :class-def
 400  nil
 401  '((push (first value) (def :default-initargs))
 402    (push :run-setup (def :default-initargs))
 403    (setf (def :run-setup) (first value)))
 404  'check-run-setup-value)
 405
 406 (defun %valid-run-setup-values ()
 407   '(:once-per-session :once-per-suite
 408     :once-per-test-case :never))
 409
 410 (defun check-run-setup-value ()
 411   (when (def :run-setup)
 412     (unless (member (def :run-setup) (%valid-run-setup-values))
 413       (error "The :run-setup option must be one of ~{~a~^, ~}."
 414              (%valid-run-setup-values)))))
 415
 416 (add-code-block
 417  :equality-test 0 :methods
 418  (lambda () (def :equality-test))
 419  '((setf (def :equality-test) (cleanup-parsed-parameter value)))
 420  'build-test-equality-test)
 421
 422 (add-code-block
 423  :expected-error 0 :methods
 424  (lambda () (def :expected-error))
 425  '((setf (def :expected-error) (cleanup-parsed-parameter value)))
 426  'build-testsuite-expected-error)
 427
 428 (add-code-block
 429  :expected-failure 0 :methods
 430  (lambda () (def :expected-failure))
 431  '((setf (def :expected-failure) (cleanup-parsed-parameter value)))
 432  'build-testsuite-expected-failure)
 433
 434 (add-code-block
 435  :log-file 0 :class-def
 436  nil
 437  '((push (first value) (def :default-initargs))
 438    (push :log-file (def :default-initargs)))
 439  nil)
 440
 441 (add-code-block
 442  :dynamic-variables 0 :class-def
 443  nil
 444  '((setf (def :direct-dynamic-variables) value))
 445  nil)
 446
 447 (add-code-block
 448  :categories 0 :class-def
 449  nil
 450  '((push value (def :categories)))
 451  nil)
 452
 453 (add-code-block
 454  :default-initargs 1 :class-def
 455  (lambda () (def :default-initargs))
 456  '((dolist (x (reverse (cleanup-parsed-parameter value)))
 457    (push x (def :default-initargs))))
 458  nil)
 459
 460 (defmacro deftestsuite (testsuite-name superclasses slots &rest
 461                         clauses-and-options)
 462   "
 463 Creates a testsuite named `testsuite-name` and, optionally, the code required for test setup, test tear-down and the actual test-cases. A testsuite is a collection of test-cases and other testsuites.
 464
 465 Test suites can have multiple superclasses (just like the classes that they are). Usually, these will be other test classes and the class hierarchy becomes the test case hierarchy. If necessary, however, non-testsuite classes can also be used as superclasses.
 466
 467 Slots are specified as in defclass with the following additions:
 468
 469 * Initargs and accessors are automatically defined. If a slot is named`my-slot`, then the initarg will be `:my-slot` and the accessors will be `my-slot` and `(setf my-slot)`.
 470 * If the second argument is not a CLOS slot option keyword, then it will be used as the `:initform` for the slot. I.e., if you have
 471
 472         (deftestsuite my-test ()
 473           ((my-slot 23)))
 474
 475     then `my-slot` will be initialized to 23 during test setup.
 476
 477 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
 478
 479 * :categories - a list of symbols. Categories allow you to groups tests into clusters outside of the basic hierarchy. This provides finer grained control on selecting which tests to run. May be specified multiple times.
 480
 481 * :documentation - a string specifying any documentation for the test. Should only be specified once.
 482
 483 * :dynamic-variables - a list of atoms or pairs of the form (name value). These specify any special variables that should be bound in a let around the body of the test. The name should be symbol designating a special variable. The value (if supplied) will be bound to the variable. If the value is not supplied, the variable will be bound to nil. Should only be specified once.
 484
 485 * :equality-test - the name of the function to be used by default in calls to ensure-same and ensure-different. Should only be supplied once.
 486
 487 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
 488
 489 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
 490
 491 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
 492
 493 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
 494
 495     * :once-per-test-case or t (the default)
 496     * :once-per-session
 497     * :once-per-suite
 498     * :never or nil
 499
 500     :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
 501
 502 * :setup - a list of forms to be evaluated before each test case is run.  Should only be specified once.
 503
 504 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
 505
 506 * :test - Define a single test case. Can be specified multiple times.
 507
 508 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
 509 "
 510   #+no-lift-tests
 511   `(values)
 512   #-no-lift-tests
 513   (let ((test-list nil)
 514         (options nil)
 515         (return (gensym)))
 516     ;; convert any clause like :setup foo into (:setup foo)
 517     (setf clauses-and-options
 518           (convert-clauses-into-lists clauses-and-options *deftest-clauses*))
 519     (initialize-current-definition)
 520     (setf (def :testsuite-name) testsuite-name)
 521     (setf (def :superclasses) (mapcar (lambda (class) (find-testsuite class :errorp t))
 522                                       superclasses))
 523     (setf (def :deftestsuite) t)
 524     ;; parse clauses into defs
 525     (loop for clause in clauses-and-options do
 526          (typecase clause
 527            (symbol (pushnew clause options))
 528            (cons (destructuring-bind (kind &rest spec) clause
 529                    (case kind
 530                      (:test (push (first spec) test-list))
 531                      (:tests
 532                       (loop for test in spec do
 533                            (push test test-list)))
 534                      (t (block-handler kind spec)))))
 535            (t (error "When parsing ~S" clause))))
 536     (let ((slot-names nil) (slot-specs nil))
 537       (loop for slot in (if (listp slots) slots (list slots)) do
 538            (push (if (consp slot) (first slot) slot) slot-names)
 539            (push (parse-brief-slot slot) slot-specs))
 540       (setf (def :slot-specs) (nreverse slot-specs)
 541             (def :direct-slot-names) (nreverse slot-names)
 542             (def :slots-parsed) t))
 543     ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
 544     (setf (def :function-specs)
 545           (loop for spec in (def :functions) collect
 546                (destructuring-bind (name arglist &body body) (first spec)
 547                  (declare (ignore body))
 548                  `(,name ,arglist))))
 549     ;;?? needed
 550     (empty-test-tables testsuite-name)
 551     (compute-superclass-inheritence)
 552     (prog2
 553         (setf *testsuite-test-count* 0)
 554         `(eval-when (:compile-toplevel :load-toplevel :execute)
 555            (eval-when (:compile-toplevel)
 556              (push ',return *test-is-being-compiled?*))
 557            (eval-when (:load-toplevel)
 558              (push ',return *test-is-being-loaded?*))
 559            (eval-when (:execute)
 560              (push ',return *test-is-being-executed?*))
 561            ;; remove previous methods (do this _before_ we define the class)
 562            (unless (or *test-is-being-compiled?*
 563                        *test-is-being-loaded?*)
 564              (remove-previous-definitions ',(def :testsuite-name)))
 565            ,(build-test-class)
 566            (unwind-protect
 567                 (let ((*test-is-being-defined?* t))
 568                   (setf *last-test-case-name* nil)
 569                   (setf *last-testsuite-name* ',(def :testsuite-name)
 570                         (test-slots ',(def :testsuite-name))
 571                         ',(def :slot-names)
 572                         (testsuite-dynamic-variables ',(def :testsuite-name))
 573                         ',(def :dynamic-variables)
 574                         ;;?? issue 27: breaks 'encapsulation' of code-block
 575                         ;; mechanism
 576                         (testsuite-function-specs ',(def :testsuite-name))
 577                         ',(def :function-specs))
 578                   ,@(when (def :export-p)
 579                           `((export '(,(def :testsuite-name)))))
 580                   ,@(when (def :export-slots?)
 581                           `((export ',(def :direct-slot-names))))
 582                   ;; make a place to save test-case information
 583                   (empty-test-tables ',(def :testsuite-name))
 584                   ;; create methods
 585                   ;; setup :before
 586                   ,@(loop for (nil . block) in *code-blocks*
 587                        when (and block
 588                                  (code block)
 589                                  (eq (operate-when block) :methods)
 590                                  (or (not (filter block))
 591                                      (funcall (filter block)))) collect
 592                        (funcall (code block)))
 593                   ,@(when (def :dynamic-variables)
 594                           `((defmethod do-testing :around
 595                                 ((suite ,(def :testsuite-name)) result fn)
 596                               (declare (ignore result fn)
 597                                        (special
 598                                         ,@(mapcar
 599                                            #'car (def :dynamic-variables))))
 600                               (with-test-slots
 601                                 (cond ((done-dynamics? suite)
 602                                        (call-next-method))
 603                                       (t
 604                                        (setf (slot-value suite 'done-dynamics?) t)
 605                                        (let* (,@(def :dynamic-variables))
 606                                          (declare (special
 607                                                    ,@(mapcar
 608                                                       #'car (def :dynamic-variables))))
 609                                          (call-next-method))))))))
 610                   ;; tests
 611                   ,@(when test-list
 612                           `((let ((*test-evaluate-when-defined?* nil))
 613                               ,@(loop for test in (nreverse test-list) collect
 614                                      `(addtest (,(def :testsuite-name))
 615                                         ,@test))
 616                               (setf *testsuite-test-count* nil))))
 617                   ,(if (and test-list *test-evaluate-when-defined?*)
 618                        `(unless (or *test-is-being-compiled?*
 619                                     *test-is-being-loaded?*)
 620                           (let ((*test-break-on-errors?* *test-break-on-errors?*))
 621                             (run-tests :suite ',testsuite-name)))
 622                        `(find-class ',testsuite-name)))
 623              ;; cleanup
 624              (setf *test-is-being-compiled?*
 625                    (remove ',return *test-is-being-compiled?*))
 626              (setf *test-is-being-loaded?*
 627                    (remove ',return *test-is-being-loaded?*))
 628              (setf *test-is-being-executed?*
 629                    (remove ',return *test-is-being-executed?*)))))))
 630
 631 (defun compute-superclass-inheritence ()
 632   ;;?? issue 27: break encapsulation of code blocks
 633   ;;?? we assume that we won't have too deep a hierarchy or too many
 634   ;; dv's or functions so that having lots of duplicate names is OK
 635   (let ((slots nil)
 636         (inherited-dynamic-variables nil)
 637         (dynamic-variables (%build-pairs (def :direct-dynamic-variables)))
 638         (function-specs nil))
 639     (dolist (super (def :superclasses))
 640       (cond ((find-testsuite super)
 641              (setf slots (append slots (test-slots super))
 642                    inherited-dynamic-variables
 643                    (append inherited-dynamic-variables
 644                            (testsuite-dynamic-variables super))
 645                    function-specs
 646                    (append function-specs
 647                            (testsuite-function-specs super))))
 648             (t
 649              (error 'testsuite-not-defined :testsuite-name super))))
 650     (loop for pair in inherited-dynamic-variables
 651          unless (find (first pair) dynamic-variables :key #'first) collect
 652          (progn (push pair dynamic-variables) pair))
 653     (setf (def :slot-names)
 654           (remove-duplicates (append (def :direct-slot-names) slots))
 655           (def :dynamic-variables) (nreverse dynamic-variables)
 656           (def :function-specs)
 657           (remove-duplicates
 658            (append (def :function-specs) function-specs)))
 659     (setf (def :superclasses)
 660           (loop for class in (def :superclasses)
 661              unless (some (lambda (oter)
 662                             (and (not (eq class oter))
 663                                  (member class (superclasses oter))))
 664                           (def :superclasses)) collect
 665              class))))
 666
 667 (defun %build-pairs (putative-pairs)
 668   (let ((result nil))
 669     (dolist (putative-pair putative-pairs)
 670       (if (atom putative-pair)
 671         (push (list putative-pair nil) result)
 672         (push putative-pair result)))
 673     (nreverse result)))
 674
 675 (defmacro addtest (name &body test)
 676   "Adds a single new test-case to the most recently defined testsuite."
 677   #+no-lift-tests
 678   `nil
 679   #-no-lift-tests
 680   (let ((body nil)
 681         (return (gensym))
 682         (options nil) (documentation nil)
 683         (looks-like-suite-name (looks-like-suite-name-p name)))
 684     (cond (looks-like-suite-name
 685            ;; testsuite given
 686            (setf (def :testsuite-name) (first name)
 687                  options (rest name)
 688                  name nil body test))
 689           (t
 690            ;; the 'name' is really part of the test...
 691            (setf body (cons name test))))
 692     (unless (property-list-p options)
 693       (signal-lift-error 'add-test "test-case options must be a property list and \"~s`\" is not" options))
 694     (when (getf options :documentation)
 695       (setf documentation (getf options :documentation))
 696       (remf options :documentation))
 697     (unless (def :testsuite-name)
 698       (when *last-testsuite-name*
 699         (setf (def :testsuite-name) *last-testsuite-name*)))
 700     (unless (def :testsuite-name)
 701       (signal-lift-error 'add-test +lift-no-current-test-class+))
 702     (unless (or (def :deftestsuite)
 703                 (find-testsuite (def :testsuite-name)))
 704       (signal-lift-error 'add-test +lift-test-class-not-found+
 705                          (def :testsuite-name)))
 706     `(eval-when (:compile-toplevel :load-toplevel :execute)
 707        (eval-when (:compile-toplevel)
 708          (push ',return *test-is-being-compiled?*))
 709        (eval-when (:load-toplevel)
 710          (push ',return *test-is-being-loaded?*))
 711        (eval-when (:execute)
 712          (push ',return *test-is-being-executed?*))
 713        (unwind-protect
 714             (let ((*test-is-being-defined?* t))
 715               (muffle-redefinition-warnings
 716                 ,(build-test-test-method (def :testsuite-name) body options))
 717               ,@(when documentation
 718                      `((setf (gethash
 719                               ',(def :test-case-name)
 720                               (test-case-documentation ',(def :testsuite-name)))
 721                             ,documentation)))
 722               ,@(when *compile-file-pathname*
 723                       `((setf (gethash
 724                                ',(def :test-case-name)
 725                                (test-case-source-file ',(def :testsuite-name)))
 726                               ,(namestring *compile-file-pathname*))))
 727               (setf *last-testsuite-name* ',(def :testsuite-name))
 728               (if *test-evaluate-when-defined?*
 729                   (unless (or *test-is-being-compiled?*
 730                               *test-is-being-loaded?*)
 731                     (let ((*test-break-on-errors?* (testing-interactively-p)))
 732                       (run-test)))
 733                   (values)))
 734            ;; cleanup
 735            (setf *test-is-being-compiled?*
 736                  (remove ',return *test-is-being-compiled?*)
 737                  *test-is-being-loaded?*
 738                  (remove ',return *test-is-being-loaded?*)
 739                  *test-is-being-executed?*
 740                  (remove ',return *test-is-being-executed?*))))))
 741
 742 (defmacro addbenchmark ((suite-name &rest options) test-case-name &body body)
 743   "Adds a single new test-benchmark to testsuite suite-name."
 744   #+no-lift-tests
 745   `nil
 746   #-no-lift-tests
 747   (let ((documentation nil))
 748     (unless (property-list-p options)
 749       (signal-lift-error
 750        'addbenchmark
 751        "benchmark options must be a property list and \"~s`\" is not" options))
 752     (when (getf options :documentation)
 753       (setf documentation (getf options :documentation))
 754       (remf options :documentation))
 755     (unless suite-name
 756       (signal-lift-error 'addbenchmark +lift-no-current-test-class+))
 757     (unless (find-testsuite suite-name)
 758       (signal-lift-error
 759        'addbenchmark +lift-test-class-not-found+ suite-name))
 760     (setf (def :testsuite-name) suite-name
 761           (def :test-case-name) test-case-name)
 762     `(eval-when (:compile-toplevel :load-toplevel :execute)
 763        (let ((*test-is-being-defined?* t))
 764          (muffle-redefinition-warnings
 765            ,(build-benchmark-function
 766              suite-name test-case-name body options))
 767          ,@(when documentation
 768                  `((setf (gethash
 769                           ',(def :test-case-name)
 770                           (test-case-documentation ',(def :testsuite-name)))
 771                          ,documentation)))
 772          (setf *last-testsuite-name* ',(def :testsuite-name))
 773          ',(def :test-case-name)))))
 774
 775 (defun looks-like-suite-name-p (form)
 776   (and (consp form)
 777        (atom (first form))
 778        (find-testsuite (first form))))
 779
 780 (defun property-list-p (form)
 781   (and (listp form)
 782        (block check-it
 783          (let ((even? t))
 784            (loop for x in form
 785               for want-keyword? = t then (not want-keyword?) do
 786                 (when (and want-keyword? (not (keywordp x)))
 787                   (return-from check-it nil))
 788                 (setf even? (not even?)))
 789            (return-from check-it even?)))))
 790
 791 #|
 792 (property-list-p '(:a :b))
 793 (property-list-p '(:a 2 :b 3 :c 5 :d 8))
 794 (property-list-p nil)
 795
 796 (property-list-p 3)
 797 (property-list-p '(3))
 798 (property-list-p '(3 :a))
 799 (property-list-p '(:a 3 :b))
 800 |#
 801
 802 (defun remove-test (&key (test-case *last-test-case-name*)
 803                          (suite *last-testsuite-name*))
 804   (assert suite nil "Test suite could not be determined.")
 805   (assert test-case nil "Test-case could not be determined.")
 806   (setf (testsuite-tests suite)
 807         (remove test-case (testsuite-tests suite))))
 808
 809 (defun make-testsuite (suite-name args)
 810   (let ((testsuite (find-testsuite suite-name :errorp t))
 811         result)
 812     (if testsuite
 813         (setf result (apply #'make-instance testsuite args))
 814         (error "Testsuite ~a not found." suite-name))
 815     result))
 816
 817 (defun skip-test-case-p (result suite-name test-case-name)
 818   (declare (ignore result))
 819   (find-if (lambda (skip-datum)
 820              (if (cdr skip-datum)
 821                  (and (eq suite-name (car skip-datum))
 822                       (eq test-case-name (cdr skip-datum)))
 823                  (subtypep suite-name (car skip-datum))))
 824            *skip-tests*))
 825
 826 (defun skip-test-suite-children-p (result suite-name)
 827   (declare (ignore result))
 828   (find-if (lambda (skip-datum)
 829              (and (subtypep suite-name (car skip-datum))
 830                   (null (cdr skip-datum))))
 831            *skip-tests*))
 832
 833 (defmethod skip-test-case (result suite-name test-case-name)
 834   (report-test-problem 'testcase-skipped result suite-name test-case-name nil))
 835
 836 (defmethod skip-testsuite (result suite-name)
 837   (report-test-problem 'testsuite-skipped result suite-name nil nil))
 838
 839 (defun test-case-expects-error-p (suite-name test-case-name)
 840   (or (testsuite-expects-error *current-test*)
 841       (test-case-option suite-name test-case-name :expected-error)))
 842
 843 (defun test-case-expects-failure-p (suite-name test-case-name)
 844   (or (testsuite-expects-failure *current-test*)
 845       (test-case-option suite-name test-case-name :expected-failure)))
 846
 847 (defun test-case-expects-problem-p (suite-name test-case-name)
 848   (test-case-option suite-name test-case-name :expected-problem))
 849
 850 (defun check-for-surprises (suite-name test-case-name)
 851   (let* ((expected-failure-p (test-case-expects-failure-p
 852                               suite-name test-case-name))
 853          (expected-error-p (test-case-expects-error-p
 854                             suite-name test-case-name))
 855          (expected-problem-p (test-case-expects-problem-p
 856                               suite-name test-case-name))
 857          (condition nil))
 858     (cond
 859       (expected-failure-p
 860        (setf condition
 861              (make-condition 'unexpected-success-failure
 862                              :expected :failure
 863                              :expected-more expected-failure-p)))
 864       (expected-error-p
 865        (setf condition
 866              (make-condition 'unexpected-success-failure
 867                              :expected :error
 868                              :expected-more expected-error-p)))
 869       (expected-problem-p
 870        (setf condition
 871              (make-condition 'unexpected-success-failure
 872                              :expected :problem
 873                              :expected-more expected-problem-p))))
 874     (when condition
 875       (if (find-restart 'ensure-failed)
 876           (invoke-restart 'ensure-failed condition)
 877           (warn condition)))))
 878
 879 (defun error-okay-p (suite-name test-case-name)
 880   (or (test-case-expects-error-p suite-name test-case-name)
 881       (test-case-expects-problem-p suite-name test-case-name)))
 882
 883 (defun failure-okay-p (suite-name test-case-name)
 884   (or (test-case-expects-failure-p suite-name test-case-name)
 885       (test-case-expects-problem-p suite-name test-case-name)))
 886
 887 (defun report-test-problem (problem-type result suite-name method condition
 888                             &rest args)
 889   ;; ick
 890   (let ((docs nil)
 891         (option nil))
 892     (declare (ignorable docs option))
 893     (cond ((and (eq problem-type 'test-failure)
 894                 (not (typep condition 'unexpected-success-failure))
 895                 (test-case-expects-failure-p suite-name method))
 896            (setf problem-type 'test-expected-failure
 897                  option :expected-failure))
 898           ((and (eq problem-type 'test-error)
 899                 (test-case-expects-error-p suite-name method))
 900            (setf problem-type 'test-expected-error
 901                  option :expected-error))
 902           ((and (or (eq problem-type 'test-failure)
 903                     (eq problem-type 'test-error))
 904                 (test-case-expects-problem-p suite-name method))
 905            (setf problem-type (or (and (eq problem-type 'test-failure)
 906                                        'test-expected-failure)
 907                                   (and (eq problem-type 'test-error)
 908                                        'test-expected-error))
 909                  option :expected-problem)))
 910     (let ((problem (apply #'make-instance problem-type
 911                           :testsuite suite-name
 912                           :test-method method
 913                           :test-condition condition
 914                           :test-step (current-step result)
 915                           :testsuite-initargs (testsuite-initargs result)
 916                           args)))
 917       (when *current-test*
 918         (setf (getf (test-data *current-test*) :problem) problem))
 919       (accumulate-problem problem result)
 920       (when (and *test-maximum-failure-count*
 921                  (numberp *test-maximum-failure-count*)
 922                  (>= (length (failures result)) *test-maximum-failure-count*))
 923         (cancel-testing :failures))
 924       (when (and *test-maximum-error-count*
 925                  (numberp *test-maximum-error-count*)
 926                  (>= (length (errors result)) *test-maximum-error-count*))
 927         (cancel-testing :errors))
 928       problem)))
 929
 930 (defun cancel-testing (why)
 931   (declare (ignore why))
 932   (flet ((do-it (name)
 933            (let ((restart (find-restart name)))
 934              (when restart (invoke-restart restart *test-result*)))))
 935     (do-it 'cancel-testing-from-configuration)
 936     (do-it 'cancel-testing)))
 937
 938 ;;; ---------------------------------------------------------------------------
 939 ;;; test-result and printing
 940 ;;; ---------------------------------------------------------------------------
 941
 942 (defun get-test-print-length ()
 943   (let ((foo *test-print-length*))
 944     (if (eq foo :follow-print) *print-length* foo)))
 945
 946 (defun get-test-print-level ()
 947   (let ((foo *test-print-level*))
 948     (if (eq foo :follow-print) *print-level* foo)))
 949
 950 (defun record-start-times (result suite)
 951   (setf (current-step result) :start-test
 952         (test-data suite)
 953         `(:start-time ,(get-test-real-time)
 954           :start-time-universal ,(get-universal-time))))
 955
 956 (defun record-end-times (result suite)
 957   (setf (current-step result) :end-test
 958         (getf (test-data suite) :end-time) (get-test-real-time)
 959         (end-time result) (get-test-real-time)
 960         (getf (test-data suite) :end-time-universal) (get-universal-time)
 961         (end-time-universal result) (get-universal-time)))
 962
 963 (defmethod make-test-result (for test-mode &rest args)
 964   (apply #'make-instance 'test-result
 965          :results-for for
 966          :test-mode test-mode
 967          args))
 968
 969 (defun testing-interactively-p ()
 970   (values nil))
 971
 972 (defmethod print-object ((tr test-result) stream)
 973   (let ((complete-success? (and (null (errors tr))
 974                                 (null (failures tr))
 975                                 (null (expected-failures tr))
 976                                 (null (expected-errors tr)))))
 977     (let* ((*print-level* (get-test-print-level))
 978            (*print-length* (get-test-print-length))
 979            (non-failure-failures
 980             (count-if
 981              (lambda (failure)
 982                (member (class-of (test-condition failure))
 983                        (subclasses 'unexpected-success-failure :proper? nil)))
 984              (expected-failures tr)))
 985            (expected-failures (- (length (expected-failures tr))
 986                                  non-failure-failures)))
 987       (print-unreadable-object (tr stream)
 988         (cond ((and (null (tests-run tr)) complete-success?)
 989                (format stream "~A: no tests run" (results-for tr)))
 990               ((eq (test-mode tr) :single)
 991                (cond ((test-interactive? tr)
 992                       ;; interactive
 993                       (cond (complete-success?
 994                              (format stream "Test passed"))
 995                             ((errors tr)
 996                              (format stream "Error during testing"))
 997                             ((expected-errors tr)
 998                              (format stream "Expected error during testing"))
 999                             ((failures tr)
1000                              (format stream "Test failed"))
1001                             ((plusp non-failure-failures)
1002                              (format stream "Test succeeded unexpectedly"))
1003                             (t
1004                              (format stream "Test failed expectedly"))))
1005                      (t
1006                       ;; from run-test
1007                       (format stream "~A.~A ~A"
1008                               (results-for tr)
1009                               (second (first (tests-run tr)))
1010                               (cond (complete-success?
1011                                      "passed")
1012                                     ((errors tr)
1013                                      "Error")
1014                                     (t
1015                                      "failed")))
1016                       (when (or (expected-errors tr) (expected-failures tr))
1017                         (format stream "(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A succeeded unexpectedly~]~[~:;, ~:*~A expected error~:P~])"
1018                                 expected-failures non-failure-failures
1019                                 (expected-errors tr))))))
1020               (t
1021                ;; multiple tests run
1022                (format stream "Results for ~A " (results-for tr))
1023                (if complete-success?
1024                  (format stream "[~A Successful test~:P]"
1025                          (length (tests-run tr)))
1026                  (format stream "~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1027                          (length (tests-run tr))
1028                          (length (failures tr))
1029                          (length (errors tr))
1030                          (length (expected-failures tr))
1031                          (length (expected-errors tr))))))
1032         ;; note that suites with no tests think that they are completely
1033         ;; successful. Optimistic little buggers, huh?
1034         (when (and (not complete-success?) *test-describe-if-not-successful?*)
1035           (format stream "~%")
1036           (print-test-result-details stream tr t t))))))
1037
1038 (defmethod describe-object ((result test-result) stream)
1039   (describe-test-result result stream))
1040
1041 (defmethod describe-test-result (result stream
1042                                  &key
1043                                  (show-details-p *test-show-details-p*)
1044                                  (show-expected-p *test-show-expected-p*)
1045                                  (show-code-p *test-show-code-p*))
1046   (let* ((number-of-failures (length (failures result)))
1047          (number-of-errors (length (errors result)))
1048          (number-of-expected-errors (length (expected-errors result)))
1049          (non-failure-failures
1050           (count-if
1051            (lambda (failure)
1052              (member (class-of (test-condition failure))
1053                      (subclasses 'unexpected-success-failure :proper? nil)))
1054            (expected-failures result)))
1055          (number-of-expected-failures (- (length (expected-failures result))
1056                                          non-failure-failures))
1057          (*print-level* (get-test-print-level))
1058          (*print-length* (get-test-print-length)))
1059     (unless *test-is-being-defined?*
1060       (print-test-summary result stream)
1061       (when (and show-details-p
1062                  (or (plusp number-of-failures)
1063                      (plusp number-of-expected-failures)
1064                      (plusp number-of-errors)
1065                      (plusp number-of-expected-errors)))
1066         (format stream "~%~%")
1067         (print-test-result-details
1068          stream result show-expected-p show-code-p)
1069         (print-test-summary result stream)))))
1070
1071 (defun print-test-summary (result stream)
1072   (let* ((number-of-failures (length (failures result)))
1073          (number-of-errors (length (errors result)))
1074          (number-of-expected-errors (length (expected-errors result)))
1075          (non-failure-failures
1076           (count-if
1077            (lambda (failure)
1078              (member (class-of (test-condition failure))
1079                      (subclasses 'unexpected-success-failure :proper? nil)))
1080            (expected-failures result)))
1081          (number-of-expected-failures (- (length (expected-failures result))
1082                                          non-failure-failures)))
1083     (format stream "~&Test Report for ~A: ~D test~:P run"
1084             (results-for result) (length (tests-run result)))
1085     (cond ((or (failures result) (errors result)
1086                (expected-failures result) (expected-errors result))
1087            (format stream "~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Successful Surprise~:P~]."
1088                    number-of-errors
1089                    number-of-failures
1090                    number-of-expected-errors
1091                    number-of-expected-failures
1092                    non-failure-failures))
1093           ((or (expected-failures result) (expected-errors result))
1094            (format stream ", all passed *~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~])."
1095                    number-of-expected-errors
1096                    number-of-expected-failures))
1097           (t
1098            (format stream ", all passed!")))))
1099
1100 (defun print-test-result-details (stream result show-expected-p show-code-p)
1101   (loop for report in (errors result) do
1102        (print-test-problem "ERROR  :" report stream
1103                            show-code-p))
1104   (loop for report in (failures result) do
1105        (print-test-problem "Failure:" report stream
1106                            show-code-p))
1107   (when show-expected-p
1108     (loop for report in (expected-failures result) do
1109          (print-test-problem "Expected failure:" report stream
1110                              show-code-p))
1111     (loop for report in (expected-errors result) do
1112          (print-test-problem "Expected Error :" report stream
1113                              show-code-p))))
1114
1115 (defmethod print-test-problem (prefix (report testsuite-problem-mixin) stream show-code-p)
1116   (let* ((suite-name (testsuite report))
1117          (method (test-method report))
1118          (condition (test-condition report))
1119          (code (test-report-code suite-name method))
1120          (step (test-step report))
1121          (testsuite-name method)
1122          (*print-level* (get-test-print-level))
1123          (*print-length* (get-test-print-length)))
1124     (let ((*package* (symbol-package method))
1125           (doc-string (gethash testsuite-name
1126                                (test-case-documentation suite-name)))
1127           (source-file (gethash testsuite-name
1128                                (test-case-source-file suite-name))))
1129       (format stream "~&~A ~(~A : ~A~)" prefix suite-name testsuite-name)
1130       (if show-code-p
1131           (setf code (with-output-to-string (out)
1132                        (pprint code out)))
1133           (setf code nil))
1134       (format stream "~&~<  ~@;~
1135                     ~@[Documentation: ~<~@;~a~:>~]~
1136                     ~@[~&Source       : ~<~@;~a~:>~]~
1137                     ~@[~&Condition    : ~<~@;~a~:>~]~
1138                     ~@[~&During       : ~a~]~
1139                     ~@[~&Code         : ~a~]~
1140                     ~&~:>" (list doc-string source-file (list condition) step code)))))
1141
1142 (defmethod print-test-problem (prefix (report test-configuration-problem-mixin) stream show-code-p)
1143   (declare (ignore show-code-p))
1144   (format stream "~&~A ~a~%~%" prefix (test-problem-message report)))
1145
1146
1147 ;;; ---------------------------------------------------------------------------
1148 ;;; test-reports
1149 ;;; ---------------------------------------------------------------------------
1150
1151 (defun test-report-code (suite-name test-case-name)
1152   (gethash test-case-name (test-name->code-table suite-name)))
1153
1154 ;;; ---------------------------------------------------------------------------
1155 ;;; utilities
1156 ;;; ---------------------------------------------------------------------------
1157
1158 (defun remove-test-methods (test-name)
1159   (prog1
1160       (length (testsuite-tests test-name))
1161     (setf (testsuite-tests test-name) nil)))
1162
1163 (defun remove-previous-definitions (classname)
1164   "Remove the methods of this class and all its subclasses."
1165   (let ((classes-removed nil)
1166         (class (find-class classname nil))
1167         (removed-count 0))
1168     (when class
1169       (loop for subclass in (subclasses class :proper? nil) do
1170             (push subclass classes-removed)
1171             (incf removed-count
1172                   (remove-test-methods (class-name subclass)))
1173             #+Ignore
1174             ;;?? causing more trouble than it solves...??
1175             (setf (find-class (class-name subclass)) nil))
1176
1177       (unless (length-1-list-p classes-removed)
1178         (format *debug-io*
1179                 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1180                 classname (sort
1181                            (delete classname
1182                                    (mapcar #'class-name classes-removed))
1183                            #'string-lessp)))
1184       (unless (zerop removed-count)
1185         (format *debug-io*
1186                 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1187                 removed-count classname
1188                 (not (length-1-list-p classes-removed)))))))
1189
1190 (defun (setf test-environment-value) (value name)
1191   (setf (slot-value *current-test* name) value))
1192
1193 (defun test-environment-value (name)
1194   (slot-value *current-test* name))
1195
1196 (defun build-test-local-functions ()
1197   `(progn
1198      ,@(mapcar
1199         (lambda (function-spec)
1200           (destructuring-bind (name arglist &body body) (first function-spec)
1201             `(defmethod flet-test-function ((testsuite ,(def :testsuite-name))
1202                                             (function-name (eql ',name))
1203                                             &rest args)
1204                (with-test-slots
1205                  ,(if arglist
1206                       `(destructuring-bind ,arglist args
1207                          ,@body)
1208                       `(progn ,@body))))))
1209         (def :functions))))
1210
1211 (defun build-test-equality-test ()
1212   (let ((test-name (def :testsuite-name))
1213         (equality-test (def :equality-test)))
1214     `(progn
1215        (defmethod equality-test ((testsuite ,test-name))
1216          ,equality-test))))
1217
1218 (defun build-testsuite-expected-error ()
1219   (let ((test-name (def :testsuite-name))
1220         (expected-error (def :expected-error)))
1221     `(progn
1222        (defmethod testsuite-expects-error ((testsuite ,test-name))
1223          (with-test-slots
1224            ,expected-error)))))
1225
1226 (defun build-testsuite-expected-failure ()
1227   (let ((test-name (def :testsuite-name))
1228         (expected-failure (def :expected-failure)))
1229     `(progn
1230        (defmethod testsuite-expects-failure ((testsuite ,test-name))
1231          (with-test-slots
1232            ,expected-failure)))))
1233
1234 (defun build-test-teardown-method ()
1235   (let ((test-name (def :testsuite-name))
1236         (teardown (def :teardown)))
1237     (when teardown
1238       (unless (consp teardown)
1239         (setf teardown (list teardown)))
1240       (when (length-1-list-p teardown)
1241         (setf teardown (list teardown)))
1242       (when (symbolp (first teardown))
1243         (setf teardown (list teardown))))
1244     (let* ((teardown-code `(,@(when teardown
1245                                 `((with-test-slots ,@teardown)))))
1246            (test-code `(,@teardown-code)))
1247       `(progn
1248          ,@(when teardown-code
1249              `((defmethod test-case-teardown progn ((testsuite ,test-name)
1250                                                     (result test-result))
1251                  (when (run-teardown-p testsuite :test-case)
1252                    ,@test-code))))
1253          ,@(when teardown-code
1254              `((defmethod testsuite-teardown ((testsuite ,test-name)
1255                                               (result test-result))
1256                  (when (run-teardown-p testsuite :testsuite)
1257                    ,@test-code))))))))
1258
1259 (defun build-setup-test-method ()
1260   (let ((test-name (def :testsuite-name))
1261         (setup (def :setup)))
1262     ;;?? ewww, this smells bad
1263     (when setup
1264       (unless (consp setup)
1265         (setf setup (list setup)))
1266       (when (length-1-list-p setup)
1267         (setf setup (list setup)))
1268       (when (symbolp (first setup))
1269         (setf setup (list setup))))
1270     (if setup
1271       `(defmethod setup-test :after ((testsuite ,test-name))
1272          (with-test-slots
1273            ,@setup))
1274       ;; rather use remove-method
1275       `(defmethod setup-test :after ((testsuite ,test-name))
1276          ))))
1277
1278 (defmethod setup-test :around ((test test-mixin))
1279   (when (run-setup-p test)
1280     (call-next-method)
1281     (setf (slot-value test 'done-setup?) t)))
1282
1283 (defun run-setup-p (testsuite)
1284   (case (run-setup testsuite)
1285     (:once-per-session (error "not implemented"))
1286     (:once-per-suite (not (done-setup? testsuite)))
1287     ((:once-per-test-case t) t)
1288     ((:never nil) nil)
1289     (t (error "Don't know about ~s for run-setup" (run-setup testsuite)))))
1290
1291 (defun run-teardown-p (testsuite when)
1292   (ecase when
1293     (:test-case
1294      (ecase (run-setup testsuite)
1295        (:once-per-session nil)
1296        (:once-per-suite nil)
1297        ((:once-per-test-case t) t)
1298        ((:never nil) nil)))
1299     (:testsuite
1300      (ecase (run-setup testsuite)
1301        (:once-per-session nil)
1302        (:once-per-suite t)
1303        ((:once-per-test-case t) nil)
1304        ((:never nil) nil)))))
1305
1306 (defun build-test-test-method (suite-name test-body options)
1307   (multiple-value-bind (test-case-name body name-supplied?)
1308                        (parse-test-body test-body)
1309     (declare (ignorable name-supplied?))
1310     (unless (consp (first body))
1311       (setf body (list body)))
1312     (setf (def :test-case-name) test-case-name)
1313     `(progn
1314        (setf (gethash ',test-case-name (test-name->code-table ',suite-name)) ',body
1315              (gethash ',body (test-code->name-table ',suite-name)) ',test-case-name)
1316        #+(or mcl ccl)
1317        ,@(when name-supplied?
1318            `((ccl:record-source-file ',test-case-name 'test-case)))
1319        (unless (find ',test-case-name (testsuite-tests ',suite-name))
1320          (setf (testsuite-tests ',suite-name)
1321                (append (testsuite-tests ',suite-name) (list ',test-case-name))))
1322        (setf (gethash ',suite-name *test-case-options*) nil)
1323        (defmethod set-test-case-options
1324            ((suite-name (eql ',suite-name)) (test-case-name (eql ',test-case-name)))
1325          ,@(when options
1326                  (build-test-case-options
1327                   suite-name test-case-name options)))
1328        (setf (gethash ',test-case-name (test-name->methods ',suite-name))
1329              (lambda (testsuite)
1330                (declare (ignorable testsuite))
1331                ,@(when options
1332                        `((set-test-case-options ',suite-name ',test-case-name)))
1333                (with-test-slots ,@body)))
1334        (setf *last-test-case-name* ',test-case-name)
1335        (when (and *test-print-when-defined?*
1336                   (not (or *test-is-being-compiled?*
1337                            )))
1338          (format *debug-io* "~&;Test Created: ~(~S.~S~)."
1339                  ',suite-name ',test-case-name))
1340        *last-test-case-name*)))
1341
1342 (defun parse-test-body (test-body)
1343   (let ((test-name nil)
1344         (body nil)
1345         (test-number (1+ (testsuite-test-count *last-testsuite-name*)))
1346         (name-supplied? nil))
1347     (setf test-name (first test-body))
1348     (cond ((symbolp test-name)
1349            (setf test-name
1350                  (intern (format nil "~A" test-name))
1351                  body (rest test-body)
1352                  name-supplied? t))
1353           ((and (test-code->name-table *last-testsuite-name*)
1354                 (setf test-name
1355                  (gethash test-body
1356                           (test-code->name-table *last-testsuite-name*))))
1357            (setf body test-body))
1358           (t
1359            (setf test-name
1360                  (intern (format nil "TEST-~A"
1361                                  test-number))
1362                  body test-body)))
1363     (values test-name body name-supplied?)))
1364
1365 (defun build-benchmark-function (suite-name test-case-name body options)
1366   (let ((duration 2) style)
1367     (when (getf options :style)
1368       (setf style (getf options :style))
1369       (remf options :style))
1370     (when (getf options :duration 2)
1371       (setf duration (getf options :duration 2))
1372       (remf options :duration))
1373     `(progn
1374        #+(or mcl ccl)
1375        ,@(when name-supplied?
1376                `((ccl:record-source-file ',test-case-name 'test-case)))
1377        (unless (find ',test-case-name (testsuite-tests ',suite-name))
1378          (setf (testsuite-tests ',suite-name)
1379                (append (testsuite-tests ',suite-name) (list ',test-case-name))))
1380        ;;?? to defer until after compile...?
1381        ,@(when options
1382                `((defmethod set-test-case-options
1383                      ((suite-name (eql ',suite-name))
1384                       (test-case-name (eql ',test-case-name)))
1385                    ,@(build-test-case-options
1386                       suite-name test-case-name options))))
1387        (setf (gethash ',test-case-name (test-name->methods ',suite-name))
1388              (lambda (testsuite)
1389                (declare (ignorable testsuite))
1390                (with-test-slots
1391                  (symbol-macrolet
1392                      ((benchmark-count
1393                        (getf (test-data *current-test*) :benchmark-count)))
1394                    (declare (ignorable benchmark-count))
1395                    ,@(when options
1396                            `((set-test-case-options ',suite-name ',test-case-name)))
1397                    ,@(ecase style
1398                             (:repetition
1399                              `((setf benchmark-count
1400                                      (while-counting-repetitions (,duration)
1401                                        ,@body))))
1402                             (:events
1403                              `((setf benchmark-count
1404                                      (while-counting-events (,duration)
1405                                        ,@body))))
1406                             ((nil)
1407                              `,body))))))
1408        (setf *last-test-case-name* ',test-case-name))))
1409
1410 (defun build-test-class ()
1411   ;; for now, we don't generate code from :class-def code-blocks
1412   ;; they are executed only for effect.
1413   (loop for (nil . block) in *code-blocks*
1414      when (and block
1415                (code block)
1416                (eq (operate-when block) :class-def)
1417                (or (not (filter block))
1418                    (funcall (filter block)))) collect
1419      (funcall (code block)))
1420   (unless (some (lambda (superclass)
1421                   (testsuite-p superclass))
1422                 (def :superclasses))
1423     (pushnew 'test-mixin (def :superclasses)))
1424   ;; build basic class and standard class
1425   `(defclass ,(def :testsuite-name) (,@(def :superclasses))
1426      ,(loop for name in (def :direct-slot-names) collect
1427             (let ((it (find name (def :slot-specs) :key #'car)))
1428               (assert it)
1429               it))
1430      ,@(when (def :documentation)
1431              `((:documentation ,(def :documentation))))
1432      (:default-initargs
1433        ,@(def :default-initargs)
1434          ,@(when *load-pathname*
1435                  `(:test-source-file ,(namestring *compile-file-pathname*))))))
1436
1437 (defun parse-test-slots (slot-specs)
1438   (loop for spec in slot-specs collect
1439         (let ((parsed-spec spec))
1440           (if (member :initform parsed-spec)
1441             (let ((pos (position :initform parsed-spec)))
1442               (append (subseq parsed-spec 0 pos)
1443                       (subseq parsed-spec (+ pos 2))))
1444             parsed-spec))))
1445
1446 ;; some handy properties
1447 (defclass-property test-slots)
1448 (defclass-property test-code->name-table)
1449 (defclass-property test-name->code-table)
1450 (defclass-property test-case-documentation)
1451 (defclass-property testsuite-tests)
1452 (defclass-property testsuite-dynamic-variables)
1453 (defclass-property test-name->methods)
1454 (defclass-property test-case-source-file)
1455
1456 ;;?? issue 27: break encapsulation of code blocks
1457 (defclass-property testsuite-function-specs)
1458
1459 (defun empty-test-tables (test-name)
1460   (when (find-class test-name nil)
1461     (setf (test-code->name-table test-name)
1462           (make-hash-table :test #'equal)
1463           (test-name->code-table test-name)
1464           (make-hash-table :test #'equal)
1465           (test-name->methods test-name)
1466           (make-hash-table :test #'eq)
1467           (test-case-documentation test-name)
1468           (make-hash-table :test #'equal)
1469           (test-case-source-file test-name)
1470           (make-hash-table :test #'equal))))
1471
1472 (pushnew :timeout *deftest-clauses*)
1473
1474 (add-code-block
1475  :timeout 1 :class-def
1476  (lambda () (def :timeout))
1477  '((setf (def :timeout) (cleanup-parsed-parameter value)))
1478  (lambda ()
1479    (unless (some (lambda (super)
1480                    (member (find-class 'process-test-mixin)
1481                            (superclasses super)))
1482                  (def :superclasses))
1483      (pushnew 'process-test-mixin (def :superclasses)))
1484    (push (def :timeout) (def :default-initargs))
1485    (push :maximum-time (def :default-initargs))
1486    nil))
1487
1488 (defmethod do-test :around ((suite test-mixin) name result)
1489   (declare (ignore result))
1490   (if (profile suite)
1491       (with-profile-report ((format nil "~a-~a"
1492                                     (testsuite-name suite) name)
1493                             (profile suite))
1494         (call-next-method))
1495       (call-next-method)))
1496
1497 (defmethod do-test :around ((suite process-test-mixin) name result)
1498   (declare (ignore name))
1499   (handler-bind ((timeout-error
1500                   (lambda (c)
1501                     (let ((suite-name (class-name (class-of suite))))
1502                       (report-test-problem
1503                        'test-timeout-failure result suite-name (current-method suite)
1504                        (make-instance 'test-timeout-condition
1505                                       :maximum-time (maximum-time suite))))
1506                     (if (find-restart 'test-failed)
1507                         (invoke-restart 'test-failed c)
1508                         (error c)))))
1509     (with-timeout ((maximum-time suite))
1510       (call-next-method))
1511     ))
1512
1513 (defmethod testsuite-log-data ((suite t))
1514   nil)
1515
1516 (defmethod testsuite-log-data :around ((suite t))
1517   (multiple-value-bind (additional error?)
1518       (ignore-errors (call-next-method))
1519     (if error?
1520         `(:error "error occured gathering additional data")
1521         additional)))
1522
1523 (defmethod test-case-teardown :around ((suite log-results-mixin) result)
1524   (declare (ignore result))
1525   (let ((problem (getf (test-data suite) :problem)))
1526     (unless (and problem (typep problem 'test-error-mixin))
1527       (generate-log-entry
1528        nil
1529        (getf (test-data suite) :seconds)
1530        (getf (test-data suite) :conses)
1531        :additional-data
1532        `(,@(testsuite-log-data suite))))))
1533
1534 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
1535 (defun lift-property (name)
1536   (when *current-test*
1537     (getf (getf (test-data *current-test*) :properties) name)))
1538
1539 #+(or)
1540 (setf (getf (getf (third (first (tests-run *test-result*))) :properties) :foo)
1541       3)
1542
1543 (defun (setf lift-property) (value name)
1544   (when *current-test*
1545     (setf (getf (getf (test-data *current-test*) :properties) name) value)))
1546
1547
1548 #+Later
1549 (defmacro with-test (&body forms)
1550   "Execute forms in the context of the current test class."
1551   (let* ((testsuite-name *last-testsuite-name*)
1552          (test-case (make-instance test-class)))
1553     `(eval-when (:execute)
1554        (prog2
1555         (setup-test ,test-case)
1556         (progn
1557           (with-test-slots ,@forms))
1558         (test-case-teardown ,test-case result)))))
1559
1560 (defvar *test-case-options* (make-hash-table))
1561
1562 (defun remove-test-case-options (suite-name)
1563   (remhash suite-name *test-case-options*))
1564
1565 (defun test-case-option (suite-name case-name option-name)
1566   (let* ((suite-options (gethash suite-name *test-case-options*))
1567          (case-options (and suite-options
1568                             (gethash case-name suite-options))))
1569     (getf (car case-options) option-name)))
1570
1571 (defun (setf test-case-option) (value suite-name case-name option-name)
1572   (let ((suite-options (gethash suite-name *test-case-options*)))
1573     (unless suite-options
1574       (setf suite-options (setf (gethash suite-name *test-case-options*)
1575                                 (make-hash-table))))
1576     (multiple-value-bind (case-options found?)
1577         (gethash case-name suite-options)
1578       (unless found?
1579         (setf case-options
1580               (setf (gethash case-name suite-options) (cons nil nil))))
1581       (setf (getf (car case-options) option-name) value))))
1582
1583 (defun build-test-case-options (suite-name case-name options)
1584   (loop for (k v) on options by #'cddr collect
1585        `(setf (test-case-option ',suite-name ',case-name ,k) ,v)))
1586
1587 #|
1588 (test-case-option 'test-dependencies-helper 'test-c :depends-on)
1589 (setf (test-case-option 'test-dependencies-helper 'test-c :depends-on) :test-c)
1590 (remove-test-case-options 'test-dependencies-helper)
1591 |#