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                         #+allegro
 728                         (setf (gethash
 729                                ',(def :test-case-name)
 730                                (test-case-source-position ',(def :testsuite-name)))
 731                               ,(current-source-position))))
 732               (setf *last-testsuite-name* ',(def :testsuite-name))
 733               (if *test-evaluate-when-defined?*
 734                   (unless (or *test-is-being-compiled?*
 735                               *test-is-being-loaded?*)
 736                     (let ((*test-break-on-errors?* (testing-interactively-p)))
 737                       (run-test)))
 738                   (values)))
 739            ;; cleanup
 740            (setf *test-is-being-compiled?*
 741                  (remove ',return *test-is-being-compiled?*)
 742                  *test-is-being-loaded?*
 743                  (remove ',return *test-is-being-loaded?*)
 744                  *test-is-being-executed?*
 745                  (remove ',return *test-is-being-executed?*))))))
 746
 747 (defmacro addbenchmark ((suite-name &rest options) test-case-name &body body)
 748   "Adds a single new test-benchmark to testsuite suite-name."
 749   #+no-lift-tests
 750   `nil
 751   #-no-lift-tests
 752   (let ((documentation nil))
 753     (unless (property-list-p options)
 754       (signal-lift-error
 755        'addbenchmark
 756        "benchmark options must be a property list and \"~s`\" is not" options))
 757     (when (getf options :documentation)
 758       (setf documentation (getf options :documentation))
 759       (remf options :documentation))
 760     (unless suite-name
 761       (signal-lift-error 'addbenchmark +lift-no-current-test-class+))
 762     (unless (find-testsuite suite-name)
 763       (signal-lift-error
 764        'addbenchmark +lift-test-class-not-found+ suite-name))
 765     (setf (def :testsuite-name) suite-name
 766           (def :test-case-name) test-case-name)
 767     `(eval-when (:compile-toplevel :load-toplevel :execute)
 768        (let ((*test-is-being-defined?* t))
 769          (muffle-redefinition-warnings
 770            ,(build-benchmark-function
 771              suite-name test-case-name body options))
 772          ,@(when documentation
 773                  `((setf (gethash
 774                           ',(def :test-case-name)
 775                           (test-case-documentation ',(def :testsuite-name)))
 776                          ,documentation)))
 777          (setf *last-testsuite-name* ',(def :testsuite-name))
 778          ',(def :test-case-name)))))
 779
 780 (defun looks-like-suite-name-p (form)
 781   (and (consp form)
 782        (atom (first form))
 783        (find-testsuite (first form))))
 784
 785 (defun property-list-p (form)
 786   (and (listp form)
 787        (block check-it
 788          (let ((even? t))
 789            (loop for x in form
 790               for want-keyword? = t then (not want-keyword?) do
 791                 (when (and want-keyword? (not (keywordp x)))
 792                   (return-from check-it nil))
 793                 (setf even? (not even?)))
 794            (return-from check-it even?)))))
 795
 796 #|
 797 (property-list-p '(:a :b))
 798 (property-list-p '(:a 2 :b 3 :c 5 :d 8))
 799 (property-list-p nil)
 800
 801 (property-list-p 3)
 802 (property-list-p '(3))
 803 (property-list-p '(3 :a))
 804 (property-list-p '(:a 3 :b))
 805 |#
 806
 807 (defun remove-test (&key (test-case *last-test-case-name*)
 808                          (suite *last-testsuite-name*))
 809   (assert suite nil "Test suite could not be determined.")
 810   (assert test-case nil "Test-case could not be determined.")
 811   (setf (testsuite-tests suite)
 812         (remove test-case (testsuite-tests suite))))
 813
 814 (defun make-testsuite (suite-name args)
 815   (let ((testsuite (find-testsuite suite-name :errorp t))
 816         result)
 817     (if testsuite
 818         (setf result (apply #'make-instance testsuite args))
 819         (error "Testsuite ~a not found." suite-name))
 820     result))
 821
 822 (defun skip-test-case-p (result suite-name test-case-name)
 823   (declare (ignore result))
 824   (find-if (lambda (skip-datum)
 825              (if (cdr skip-datum)
 826                  (and (eq suite-name (car skip-datum))
 827                       (eq test-case-name (cdr skip-datum)))
 828                  (subtypep suite-name (car skip-datum))))
 829            *skip-tests*))
 830
 831 (defun skip-test-suite-children-p (result suite-name)
 832   (declare (ignore result))
 833   (find-if (lambda (skip-datum)
 834              (and (subtypep suite-name (car skip-datum))
 835                   (null (cdr skip-datum))))
 836            *skip-tests*))
 837
 838 (defmethod skip-test-case (result suite-name test-case-name)
 839   (report-test-problem 'testcase-skipped result suite-name test-case-name nil))
 840
 841 (defmethod skip-testsuite (result suite-name)
 842   (report-test-problem 'testsuite-skipped result suite-name nil nil))
 843
 844 (defun test-case-expects-error-p (suite-name test-case-name)
 845   (or (testsuite-expects-error *current-test*)
 846       (test-case-option suite-name test-case-name :expected-error)))
 847
 848 (defun test-case-expects-failure-p (suite-name test-case-name)
 849   (or (testsuite-expects-failure *current-test*)
 850       (test-case-option suite-name test-case-name :expected-failure)))
 851
 852 (defun test-case-expects-problem-p (suite-name test-case-name)
 853   (test-case-option suite-name test-case-name :expected-problem))
 854
 855 (defun check-for-surprises (suite-name test-case-name)
 856   (let* ((expected-failure-p (test-case-expects-failure-p
 857                               suite-name test-case-name))
 858          (expected-error-p (test-case-expects-error-p
 859                             suite-name test-case-name))
 860          (expected-problem-p (test-case-expects-problem-p
 861                               suite-name test-case-name))
 862          (condition nil))
 863     (cond
 864       (expected-failure-p
 865        (setf condition
 866              (make-condition 'unexpected-success-failure
 867                              :expected :failure
 868                              :expected-more expected-failure-p)))
 869       (expected-error-p
 870        (setf condition
 871              (make-condition 'unexpected-success-failure
 872                              :expected :error
 873                              :expected-more expected-error-p)))
 874       (expected-problem-p
 875        (setf condition
 876              (make-condition 'unexpected-success-failure
 877                              :expected :problem
 878                              :expected-more expected-problem-p))))
 879     (when condition
 880       (if (find-restart 'ensure-failed)
 881           (invoke-restart 'ensure-failed condition)
 882           (warn condition)))))
 883
 884 (defun error-okay-p (suite-name test-case-name)
 885   (or (test-case-expects-error-p suite-name test-case-name)
 886       (test-case-expects-problem-p suite-name test-case-name)))
 887
 888 (defun failure-okay-p (suite-name test-case-name)
 889   (or (test-case-expects-failure-p suite-name test-case-name)
 890       (test-case-expects-problem-p suite-name test-case-name)))
 891
 892 (defun report-test-problem (problem-type result suite-name method condition
 893                             &rest args)
 894   ;; ick
 895   (let ((docs nil)
 896         (option nil))
 897     (declare (ignorable docs option))
 898     (cond ((and (eq problem-type 'test-failure)
 899                 (not (typep condition 'unexpected-success-failure))
 900                 (test-case-expects-failure-p suite-name method))
 901            (setf problem-type 'test-expected-failure
 902                  option :expected-failure))
 903           ((and (eq problem-type 'test-error)
 904                 (test-case-expects-error-p suite-name method))
 905            (setf problem-type 'test-expected-error
 906                  option :expected-error))
 907           ((and (or (eq problem-type 'test-failure)
 908                     (eq problem-type 'test-error))
 909                 (test-case-expects-problem-p suite-name method))
 910            (setf problem-type (or (and (eq problem-type 'test-failure)
 911                                        'test-expected-failure)
 912                                   (and (eq problem-type 'test-error)
 913                                        'test-expected-error))
 914                  option :expected-problem)))
 915     (let ((problem (apply #'make-instance problem-type
 916                           :testsuite suite-name
 917                           :test-method method
 918                           :test-condition condition
 919                           :test-step (current-step result)
 920                           :testsuite-initargs (testsuite-initargs result)
 921                           args)))
 922       (when *current-test*
 923         (setf (getf (test-data *current-test*) :problem) problem))
 924       (accumulate-problem problem result)
 925       (when (and *test-maximum-failure-count*
 926                  (numberp *test-maximum-failure-count*)
 927                  (>= (length (failures result)) *test-maximum-failure-count*))
 928         (cancel-testing :failures))
 929       (when (and *test-maximum-error-count*
 930                  (numberp *test-maximum-error-count*)
 931                  (>= (length (errors result)) *test-maximum-error-count*))
 932         (cancel-testing :errors))
 933       problem)))
 934
 935 (defun cancel-testing (why)
 936   (declare (ignore why))
 937   (flet ((do-it (name)
 938            (let ((restart (find-restart name)))
 939              (when restart (invoke-restart restart *test-result*)))))
 940     (do-it 'cancel-testing-from-configuration)
 941     (do-it 'cancel-testing)))
 942
 943 ;;; ---------------------------------------------------------------------------
 944 ;;; test-result and printing
 945 ;;; ---------------------------------------------------------------------------
 946
 947 (defun get-test-print-length ()
 948   (let ((foo *test-print-length*))
 949     (if (eq foo :follow-print) *print-length* foo)))
 950
 951 (defun get-test-print-level ()
 952   (let ((foo *test-print-level*))
 953     (if (eq foo :follow-print) *print-level* foo)))
 954
 955 (defun record-start-times (result suite)
 956   (setf (current-step result) :start-test
 957         (test-data suite)
 958         `(:start-time ,(get-test-real-time)
 959           :start-time-universal ,(get-universal-time))))
 960
 961 (defun record-end-times (result suite)
 962   (setf (current-step result) :end-test
 963         (getf (test-data suite) :end-time) (get-test-real-time)
 964         (end-time result) (get-test-real-time)
 965         (getf (test-data suite) :end-time-universal) (get-universal-time)
 966         (end-time-universal result) (get-universal-time)))
 967
 968 (defmethod make-test-result (for test-mode &rest args)
 969   (apply #'make-instance 'test-result
 970          :results-for for
 971          :test-mode test-mode
 972          args))
 973
 974 (defun testing-interactively-p ()
 975   (values nil))
 976
 977 (defmethod print-object ((tr test-result) stream)
 978   (let ((complete-success? (and (null (errors tr))
 979                                 (null (failures tr))
 980                                 (null (expected-failures tr))
 981                                 (null (expected-errors tr)))))
 982     (let* ((*print-level* (get-test-print-level))
 983            (*print-length* (get-test-print-length))
 984            (non-failure-failures
 985             (count-if
 986              (lambda (failure)
 987                (member (class-of (test-condition failure))
 988                        (subclasses 'unexpected-success-failure :proper? nil)))
 989              (expected-failures tr)))
 990            (expected-failures (- (length (expected-failures tr))
 991                                  non-failure-failures)))
 992       (print-unreadable-object (tr stream)
 993         (cond ((and (null (tests-run tr)) complete-success?)
 994                (format stream "~A: no tests run" (results-for tr)))
 995               ((eq (test-mode tr) :single)
 996                (cond ((test-interactive? tr)
 997                       ;; interactive
 998                       (cond (complete-success?
 999                              (format stream "Test passed"))
1000                             ((errors tr)
1001                              (format stream "Error during testing"))
1002                             ((expected-errors tr)
1003                              (format stream "Expected error during testing"))
1004                             ((failures tr)
1005                              (format stream "Test failed"))
1006                             ((plusp non-failure-failures)
1007                              (format stream "Test succeeded unexpectedly"))
1008                             (t
1009                              (format stream "Test failed expectedly"))))
1010                      (t
1011                       ;; from run-test
1012                       (format stream "~A.~A ~A"
1013                               (results-for tr)
1014                               (second (first (tests-run tr)))
1015                               (cond (complete-success?
1016                                      "passed")
1017                                     ((errors tr)
1018                                      "Error")
1019                                     (t
1020                                      "failed")))
1021                       (when (or (expected-errors tr) (expected-failures tr))
1022                         (format stream "(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A succeeded unexpectedly~]~[~:;, ~:*~A expected error~:P~])"
1023                                 expected-failures non-failure-failures
1024                                 (expected-errors tr))))))
1025               (t
1026                ;; multiple tests run
1027                (format stream "Results for ~A " (results-for tr))
1028                (if complete-success?
1029                  (format stream "[~A Successful test~:P]"
1030                          (length (tests-run tr)))
1031                  (format stream "~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1032                          (length (tests-run tr))
1033                          (length (failures tr))
1034                          (length (errors tr))
1035                          (length (expected-failures tr))
1036                          (length (expected-errors tr))))))
1037         ;; note that suites with no tests think that they are completely
1038         ;; successful. Optimistic little buggers, huh?
1039         (when (and (not complete-success?) *test-describe-if-not-successful?*)
1040           (format stream "~%")
1041           (print-test-result-details stream tr t t))))))
1042
1043 (defmethod describe-object ((result test-result) stream)
1044   (describe-test-result result stream))
1045
1046 (defmethod describe-test-result (result stream
1047                                  &key
1048                                  (show-details-p *test-show-details-p*)
1049                                  (show-expected-p *test-show-expected-p*)
1050                                  (show-code-p *test-show-code-p*))
1051   (let* ((number-of-failures (length (failures result)))
1052          (number-of-errors (length (errors result)))
1053          (number-of-expected-errors (length (expected-errors result)))
1054          (non-failure-failures
1055           (count-if
1056            (lambda (failure)
1057              (member (class-of (test-condition failure))
1058                      (subclasses 'unexpected-success-failure :proper? nil)))
1059            (expected-failures result)))
1060          (number-of-expected-failures (- (length (expected-failures result))
1061                                          non-failure-failures))
1062          (*print-level* (get-test-print-level))
1063          (*print-length* (get-test-print-length)))
1064     (unless *test-is-being-defined?*
1065       (print-test-summary result stream)
1066       (when (and show-details-p
1067                  (or (plusp number-of-failures)
1068                      (plusp number-of-expected-failures)
1069                      (plusp number-of-errors)
1070                      (plusp number-of-expected-errors)))
1071         (format stream "~%~%")
1072         (print-test-result-details
1073          stream result show-expected-p show-code-p)
1074         (print-test-summary result stream)))))
1075
1076 (defun print-test-summary (result stream)
1077   (let* ((number-of-failures (length (failures result)))
1078          (number-of-errors (length (errors result)))
1079          (number-of-expected-errors (length (expected-errors result)))
1080          (non-failure-failures
1081           (count-if
1082            (lambda (failure)
1083              (member (class-of (test-condition failure))
1084                      (subclasses 'unexpected-success-failure :proper? nil)))
1085            (expected-failures result)))
1086          (number-of-expected-failures (- (length (expected-failures result))
1087                                          non-failure-failures)))
1088     (format stream "~&Test Report for ~A: ~D test~:P run"
1089             (results-for result) (length (tests-run result)))
1090     (cond ((or (failures result) (errors result)
1091                (expected-failures result) (expected-errors result))
1092            (format stream "~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Successful Surprise~:P~]."
1093                    number-of-errors
1094                    number-of-failures
1095                    number-of-expected-errors
1096                    number-of-expected-failures
1097                    non-failure-failures))
1098           ((or (expected-failures result) (expected-errors result))
1099            (format stream ", all passed *~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~])."
1100                    number-of-expected-errors
1101                    number-of-expected-failures))
1102           (t
1103            (format stream ", all passed!")))))
1104
1105 (defun print-test-result-details (stream result show-expected-p show-code-p)
1106   (loop for report in (errors result) do
1107        (print-test-problem "ERROR  :" report stream
1108                            show-code-p))
1109   (loop for report in (failures result) do
1110        (print-test-problem "Failure:" report stream
1111                            show-code-p))
1112   (when show-expected-p
1113     (loop for report in (expected-failures result) do
1114          (print-test-problem "Expected failure:" report stream
1115                              show-code-p))
1116     (loop for report in (expected-errors result) do
1117          (print-test-problem "Expected Error :" report stream
1118                              show-code-p))))
1119
1120 (defmethod print-test-problem (prefix (report testsuite-problem-mixin) stream show-code-p)
1121   (handler-case
1122       (let* ((suite-name (testsuite report))
1123              (method (test-method report))
1124              (condition (test-condition report))
1125              (code (test-report-code suite-name method))
1126              (step (test-step report))
1127              (testsuite-name method)
1128              (*print-level* (get-test-print-level))
1129              (*print-length* (get-test-print-length)))
1130         (let ((*package* (symbol-package method))
1131               (doc-string (gethash testsuite-name
1132                                    (test-case-documentation suite-name)))
1133               (source-file (gethash testsuite-name
1134                                     (test-case-source-file suite-name))))
1135           (format stream "~&~A ~(~A : ~A~)" prefix suite-name testsuite-name)
1136           (if show-code-p
1137               (setf code (with-output-to-string (out)
1138                            (pprint code out)))
1139               (setf code nil))
1140           (format stream "~&~<  ~@;~
1141                     ~@[Documentation: ~<~@;~a~:>~]~
1142                     ~@[~&Source       : ~<~@;~a~:>~]~
1143                     ~@[~&Condition    : ~<~@;~a~:>~]~
1144                     ~@[~&During       : ~a~]~
1145                     ~@[~&Code         : ~a~]~
1146                     ~&~:>" `((,doc-string) (,source-file) (,condition) (,step) (,code)))))
1147     (error (c)
1148       (format stream "~&Error printing problem report: ~a" c))))
1149
1150 (defmethod print-test-problem (prefix (report test-configuration-problem-mixin) stream show-code-p)
1151   (declare (ignore show-code-p))
1152   (format stream "~&~A ~a~%~%" prefix (test-problem-message report)))
1153
1154
1155 ;;; ---------------------------------------------------------------------------
1156 ;;; test-reports
1157 ;;; ---------------------------------------------------------------------------
1158
1159 (defun test-report-code (suite-name test-case-name)
1160   (gethash test-case-name (test-name->code-table suite-name)))
1161
1162 ;;; ---------------------------------------------------------------------------
1163 ;;; utilities
1164 ;;; ---------------------------------------------------------------------------
1165
1166 (defun remove-test-methods (test-name)
1167   (prog1
1168       (length (testsuite-tests test-name))
1169     (setf (testsuite-tests test-name) nil)))
1170
1171 (defun remove-previous-definitions (classname)
1172   "Remove the methods of this class and all its subclasses."
1173   (let ((classes-removed nil)
1174         (class (find-class classname nil))
1175         (removed-count 0))
1176     (when class
1177       (loop for subclass in (subclasses class :proper? nil) do
1178             (push subclass classes-removed)
1179             (incf removed-count
1180                   (remove-test-methods (class-name subclass)))
1181             #+Ignore
1182             ;;?? causing more trouble than it solves...??
1183             (setf (find-class (class-name subclass)) nil))
1184
1185       (unless (length-1-list-p classes-removed)
1186         (format *debug-io*
1187                 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1188                 classname (sort
1189                            (delete classname
1190                                    (mapcar #'class-name classes-removed))
1191                            #'string-lessp)))
1192       (unless (zerop removed-count)
1193         (format *debug-io*
1194                 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1195                 removed-count classname
1196                 (not (length-1-list-p classes-removed)))))))
1197
1198 (defun (setf test-environment-value) (value name)
1199   (setf (slot-value *current-test* name) value))
1200
1201 (defun test-environment-value (name)
1202   (slot-value *current-test* name))
1203
1204 (defun build-test-local-functions ()
1205   `(progn
1206      ,@(mapcar
1207         (lambda (function-spec)
1208           (destructuring-bind (name arglist &body body) (first function-spec)
1209             `(defmethod flet-test-function ((testsuite ,(def :testsuite-name))
1210                                             (function-name (eql ',name))
1211                                             &rest args)
1212                (with-test-slots
1213                  ,(if arglist
1214                       `(destructuring-bind ,arglist args
1215                          ,@body)
1216                       `(progn ,@body))))))
1217         (def :functions))))
1218
1219 (defun build-test-equality-test ()
1220   (let ((test-name (def :testsuite-name))
1221         (equality-test (def :equality-test)))
1222     `(progn
1223        (defmethod equality-test ((testsuite ,test-name))
1224          ,equality-test))))
1225
1226 (defun build-testsuite-expected-error ()
1227   (let ((test-name (def :testsuite-name))
1228         (expected-error (def :expected-error)))
1229     `(progn
1230        (defmethod testsuite-expects-error ((testsuite ,test-name))
1231          (with-test-slots
1232            ,expected-error)))))
1233
1234 (defun build-testsuite-expected-failure ()
1235   (let ((test-name (def :testsuite-name))
1236         (expected-failure (def :expected-failure)))
1237     `(progn
1238        (defmethod testsuite-expects-failure ((testsuite ,test-name))
1239          (with-test-slots
1240            ,expected-failure)))))
1241
1242 (defun build-test-teardown-method ()
1243   (let ((test-name (def :testsuite-name))
1244         (teardown (def :teardown)))
1245     (when teardown
1246       (unless (consp teardown)
1247         (setf teardown (list teardown)))
1248       (when (length-1-list-p teardown)
1249         (setf teardown (list teardown)))
1250       (when (symbolp (first teardown))
1251         (setf teardown (list teardown))))
1252     (let* ((teardown-code `(,@(when teardown
1253                                 `((with-test-slots ,@teardown)))))
1254            (test-code `(,@teardown-code)))
1255       `(progn
1256          ,@(when teardown-code
1257              `((defmethod test-case-teardown progn ((testsuite ,test-name)
1258                                                     (result test-result))
1259                  (when (run-teardown-p testsuite :test-case)
1260                    ,@test-code))))
1261          ,@(when teardown-code
1262              `((defmethod testsuite-teardown ((testsuite ,test-name)
1263                                               (result test-result))
1264                  (when (run-teardown-p testsuite :testsuite)
1265                    ,@test-code))))))))
1266
1267 (defun build-setup-test-method ()
1268   (let ((test-name (def :testsuite-name))
1269         (setup (def :setup)))
1270     ;;?? ewww, this smells bad
1271     (when setup
1272       (unless (consp setup)
1273         (setf setup (list setup)))
1274       (when (length-1-list-p setup)
1275         (setf setup (list setup)))
1276       (when (symbolp (first setup))
1277         (setf setup (list setup))))
1278     (if setup
1279       `(defmethod setup-test :after ((testsuite ,test-name))
1280          (with-test-slots
1281            ,@setup))
1282       ;; rather use remove-method
1283       `(defmethod setup-test :after ((testsuite ,test-name))
1284          ))))
1285
1286 (defmethod setup-test :around ((test test-mixin))
1287   (when (run-setup-p test)
1288     (call-next-method)
1289     (setf (slot-value test 'done-setup?) t)))
1290
1291 (defun run-setup-p (testsuite)
1292   (case (run-setup testsuite)
1293     (:once-per-session (error "not implemented"))
1294     (:once-per-suite (not (done-setup? testsuite)))
1295     ((:once-per-test-case t) t)
1296     ((:never nil) nil)
1297     (t (error "Don't know about ~s for run-setup" (run-setup testsuite)))))
1298
1299 (defun run-teardown-p (testsuite when)
1300   (ecase when
1301     (:test-case
1302      (ecase (run-setup testsuite)
1303        (:once-per-session nil)
1304        (:once-per-suite nil)
1305        ((:once-per-test-case t) t)
1306        ((:never nil) nil)))
1307     (:testsuite
1308      (ecase (run-setup testsuite)
1309        (:once-per-session nil)
1310        (:once-per-suite t)
1311        ((:once-per-test-case t) nil)
1312        ((:never nil) nil)))))
1313
1314 (defun current-source-position ()
1315   #+allegro
1316   (or (second comp::*compile-file-last-form-location*)
1317       (file-position comp::*compile-file-stream*))
1318   #-allegro
1319   0)
1320
1321 #+allegro
1322 (defun test-is-being-redefined-p (test-suite-name test-case-name)
1323   (let* ((old-source (gethash test-case-name (test-case-source-file test-suite-name)))
1324          (old-position (gethash test-case-name (test-case-source-position test-suite-name)))
1325          (new-source (namestring *compile-file-pathname*))
1326          (new-position (current-source-position)))
1327     (and old-source
1328          old-position
1329          (or (not (string= old-source new-source))
1330              (not (= old-position new-position))))))
1331
1332 (defun build-test-test-method (suite-name test-body options)
1333   (multiple-value-bind (test-case-name body name-supplied?)
1334                        (parse-test-body test-body)
1335     (declare (ignorable name-supplied?))
1336     (unless (consp (first body))
1337       (setf body (list body)))
1338     (setf (def :test-case-name) test-case-name)
1339     `(progn
1340        #+allegro
1341        (when *test-is-being-compiled?*
1342          (when (test-is-being-redefined-p ',suite-name ',test-case-name)
1343            (let ((original-source
1344                   (gethash ',test-case-name (test-case-source-file ',suite-name)))
1345                  (new-source (namestring *compile-file-pathname*))
1346                  (original-pos
1347                   (gethash ',test-case-name (test-case-source-position ',suite-name)))
1348                  (new-pos (current-source-position)))
1349              (if (string= original-source new-source)
1350                  ;; we assume that the environment has already printed the file name
1351                  (warn "Test ~a/~a is being redefined from position ~d to ~d"
1352                  ',suite-name ',test-case-name original-pos new-pos)
1353                  (warn "Test ~a/~a is being redefined from file ~a at position ~d to ~d"
1354                  original-source original-pos new-pos))
1355              (when *break-on-redefinition*
1356                (break)))))
1357        (setf (gethash ',test-case-name (test-name->code-table ',suite-name)) ',body
1358              (gethash ',body (test-code->name-table ',suite-name)) ',test-case-name)
1359        #+(or mcl ccl)
1360        ,@(when name-supplied?
1361            `((ccl:record-source-file ',test-case-name 'test-case)))
1362        (unless (find ',test-case-name (testsuite-tests ',suite-name))
1363          (setf (testsuite-tests ',suite-name)
1364                (append (testsuite-tests ',suite-name) (list ',test-case-name))))
1365        (setf (gethash ',suite-name *test-case-options*) nil)
1366        (defmethod set-test-case-options
1367            ((suite-name (eql ',suite-name)) (test-case-name (eql ',test-case-name)))
1368          ,@(when options
1369                  (build-test-case-options
1370                   suite-name test-case-name options)))
1371        (setf (gethash ',test-case-name (test-name->methods ',suite-name))
1372              (lambda (testsuite)
1373                (declare (ignorable testsuite))
1374                ,@(when options
1375                        `((set-test-case-options ',suite-name ',test-case-name)))
1376                (with-test-slots ,@body)))
1377        (setf *last-test-case-name* ',test-case-name)
1378        (when (and *test-print-when-defined?*
1379                   (not (or *test-is-being-compiled?*
1380                            )))
1381          (format *debug-io* "~&;Test Created: ~(~S.~S~)."
1382                  ',suite-name ',test-case-name))
1383        *last-test-case-name*)))
1384
1385 (defun parse-test-body (test-body)
1386   (let ((test-name nil)
1387         (body nil)
1388         (test-number (1+ (testsuite-test-count *last-testsuite-name*)))
1389         (name-supplied? nil))
1390     (setf test-name (first test-body))
1391     (cond ((symbolp test-name)
1392            (setf test-name
1393                  (intern (format nil "~A" test-name))
1394                  body (rest test-body)
1395                  name-supplied? t))
1396           ((and (test-code->name-table *last-testsuite-name*)
1397                 (setf test-name
1398                  (gethash test-body
1399                           (test-code->name-table *last-testsuite-name*))))
1400            (setf body test-body))
1401           (t
1402            (setf test-name
1403                  (intern (format nil "TEST-~A"
1404                                  test-number))
1405                  body test-body)))
1406     (values test-name body name-supplied?)))
1407
1408 (defun build-benchmark-function (suite-name test-case-name body options)
1409   (let ((duration 2) style)
1410     (when (getf options :style)
1411       (setf style (getf options :style))
1412       (remf options :style))
1413     (when (getf options :duration 2)
1414       (setf duration (getf options :duration 2))
1415       (remf options :duration))
1416     `(progn
1417        #+(or mcl ccl)
1418        ,@(when name-supplied?
1419                `((ccl:record-source-file ',test-case-name 'test-case)))
1420        (unless (find ',test-case-name (testsuite-tests ',suite-name))
1421          (setf (testsuite-tests ',suite-name)
1422                (append (testsuite-tests ',suite-name) (list ',test-case-name))))
1423        ;;?? to defer until after compile...?
1424        ,@(when options
1425                `((defmethod set-test-case-options
1426                      ((suite-name (eql ',suite-name))
1427                       (test-case-name (eql ',test-case-name)))
1428                    ,@(build-test-case-options
1429                       suite-name test-case-name options))))
1430        (setf (gethash ',test-case-name (test-name->methods ',suite-name))
1431              (lambda (testsuite)
1432                (declare (ignorable testsuite))
1433                (with-test-slots
1434                  (symbol-macrolet
1435                      ((benchmark-count
1436                        (getf (test-data *current-test*) :benchmark-count)))
1437                    (declare (ignorable benchmark-count))
1438                    ,@(when options
1439                            `((set-test-case-options ',suite-name ',test-case-name)))
1440                    ,@(ecase style
1441                             (:repetition
1442                              `((setf benchmark-count
1443                                      (while-counting-repetitions (,duration)
1444                                        ,@body))))
1445                             (:events
1446                              `((setf benchmark-count
1447                                      (while-counting-events (,duration)
1448                                        ,@body))))
1449                             ((nil)
1450                              `,body))))))
1451        (setf *last-test-case-name* ',test-case-name))))
1452
1453 (defun build-test-class ()
1454   ;; for now, we don't generate code from :class-def code-blocks
1455   ;; they are executed only for effect.
1456   (loop for (nil . block) in *code-blocks*
1457      when (and block
1458                (code block)
1459                (eq (operate-when block) :class-def)
1460                (or (not (filter block))
1461                    (funcall (filter block)))) collect
1462      (funcall (code block)))
1463   (unless (some (lambda (superclass)
1464                   (testsuite-p superclass))
1465                 (def :superclasses))
1466     (pushnew 'test-mixin (def :superclasses)))
1467   ;; build basic class and standard class
1468   `(defclass ,(def :testsuite-name) (,@(def :superclasses))
1469      ,(loop for name in (def :direct-slot-names) collect
1470             (let ((it (find name (def :slot-specs) :key #'car)))
1471               (assert it)
1472               it))
1473      ,@(when (def :documentation)
1474              `((:documentation ,(def :documentation))))
1475      (:default-initargs
1476        ,@(def :default-initargs)
1477          ,@(when *load-pathname*
1478                  `(:test-source-file ,(namestring *compile-file-pathname*))))))
1479
1480 (defun parse-test-slots (slot-specs)
1481   (loop for spec in slot-specs collect
1482         (let ((parsed-spec spec))
1483           (if (member :initform parsed-spec)
1484             (let ((pos (position :initform parsed-spec)))
1485               (append (subseq parsed-spec 0 pos)
1486                       (subseq parsed-spec (+ pos 2))))
1487             parsed-spec))))
1488
1489 ;; some handy properties
1490 (defclass-property test-slots)
1491 (defclass-property test-code->name-table)
1492 (defclass-property test-name->code-table)
1493 (defclass-property test-case-documentation)
1494 (defclass-property testsuite-tests)
1495 (defclass-property testsuite-dynamic-variables)
1496 (defclass-property test-name->methods)
1497 (defclass-property test-case-source-file)
1498 (defclass-property test-case-source-position)
1499
1500 ;;?? issue 27: break encapsulation of code blocks
1501 (defclass-property testsuite-function-specs)
1502
1503 (defun empty-test-tables (test-name)
1504   (when (find-class test-name nil)
1505     (setf (test-code->name-table test-name)
1506           (make-hash-table :test #'equal)
1507           (test-name->code-table test-name)
1508           (make-hash-table :test #'equal)
1509           (test-name->methods test-name)
1510           (make-hash-table :test #'eq)
1511           (test-case-documentation test-name)
1512           (make-hash-table :test #'equal)
1513           (test-case-source-file test-name)
1514           (make-hash-table :test #'equal)
1515           (test-case-source-position test-name)
1516           (make-hash-table :test #'equal))))
1517
1518 (pushnew :timeout *deftest-clauses*)
1519
1520 (add-code-block
1521  :timeout 1 :class-def
1522  (lambda () (def :timeout))
1523  '((setf (def :timeout) (cleanup-parsed-parameter value)))
1524  (lambda ()
1525    (unless (some (lambda (super)
1526                    (member (find-class 'process-test-mixin)
1527                            (superclasses super)))
1528                  (def :superclasses))
1529      (pushnew 'process-test-mixin (def :superclasses)))
1530    (push (def :timeout) (def :default-initargs))
1531    (push :maximum-time (def :default-initargs))
1532    nil))
1533
1534 (defmethod do-test :around ((suite test-mixin) name result)
1535   (declare (ignore result))
1536   (if (profile suite)
1537       (with-profile-report ((format nil "~a-~a"
1538                                     (testsuite-name suite) name)
1539                             (profile suite))
1540         (call-next-method))
1541       (call-next-method)))
1542
1543 (defmethod do-test :around ((suite process-test-mixin) name result)
1544   (declare (ignore name))
1545   (handler-bind ((timeout-error
1546                   (lambda (c)
1547                     (let ((suite-name (class-name (class-of suite))))
1548                       (report-test-problem
1549                        'test-timeout-failure result suite-name (current-method suite)
1550                        (make-instance 'test-timeout-condition
1551                                       :maximum-time (maximum-time suite))))
1552                     (if (find-restart 'test-failed)
1553                         (invoke-restart 'test-failed c)
1554                         (error c)))))
1555     (with-timeout ((maximum-time suite))
1556       (call-next-method))
1557     ))
1558
1559 (defmethod testsuite-log-data ((suite t))
1560   nil)
1561
1562 (defmethod testsuite-log-data :around ((suite t))
1563   (multiple-value-bind (additional error?)
1564       (ignore-errors (call-next-method))
1565     (if error?
1566         `(:error "error occured gathering additional data")
1567         additional)))
1568
1569 (defmethod test-case-teardown :around ((suite log-results-mixin) result)
1570   (declare (ignore result))
1571   (let ((problem (getf (test-data suite) :problem)))
1572     (unless (and problem (typep problem 'test-error-mixin))
1573       (generate-log-entry
1574        nil
1575        (getf (test-data suite) :seconds)
1576        (getf (test-data suite) :conses)
1577        :additional-data
1578        `(,@(testsuite-log-data suite))))))
1579
1580 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
1581 (defun lift-property (name)
1582   (when *current-test*
1583     (getf (getf (test-data *current-test*) :properties) name)))
1584
1585 #+(or)
1586 (setf (getf (getf (third (first (tests-run *test-result*))) :properties) :foo)
1587       3)
1588
1589 (defun (setf lift-property) (value name)
1590   (when *current-test*
1591     (setf (getf (getf (test-data *current-test*) :properties) name) value)))
1592
1593
1594 #+Later
1595 (defmacro with-test (&body forms)
1596   "Execute forms in the context of the current test class."
1597   (let* ((testsuite-name *last-testsuite-name*)
1598          (test-case (make-instance test-class)))
1599     `(eval-when (:execute)
1600        (prog2
1601         (setup-test ,test-case)
1602         (progn
1603           (with-test-slots ,@forms))
1604         (test-case-teardown ,test-case result)))))
1605
1606 (defvar *test-case-options* (make-hash-table))
1607
1608 (defun remove-test-case-options (suite-name)
1609   (remhash suite-name *test-case-options*))
1610
1611 (defun test-case-option (suite-name case-name option-name)
1612   (let* ((suite-options (gethash suite-name *test-case-options*))
1613          (case-options (and suite-options
1614                             (gethash case-name suite-options))))
1615     (getf (car case-options) option-name)))
1616
1617 (defun (setf test-case-option) (value suite-name case-name option-name)
1618   (let ((suite-options (gethash suite-name *test-case-options*)))
1619     (unless suite-options
1620       (setf suite-options (setf (gethash suite-name *test-case-options*)
1621                                 (make-hash-table))))
1622     (multiple-value-bind (case-options found?)
1623         (gethash case-name suite-options)
1624       (unless found?
1625         (setf case-options
1626               (setf (gethash case-name suite-options) (cons nil nil))))
1627       (setf (getf (car case-options) option-name) value))))
1628
1629 (defun build-test-case-options (suite-name case-name options)
1630   (loop for (k v) on options by #'cddr collect
1631        `(setf (test-case-option ',suite-name ',case-name ,k) ,v)))
1632
1633 #|
1634 (test-case-option 'test-dependencies-helper 'test-c :depends-on)
1635 (setf (test-case-option 'test-dependencies-helper 'test-c :depends-on) :test-c)
1636 (remove-test-case-options 'test-dependencies-helper)
1637 |#