external/lift.darcs/_darcs/pristine/test/lift-test.lisp

   1 ;;;-*- Mode: Lisp; Package: LIFT -*-
   2
   3 #|
   4
   5 See file COPYING for license
   6
   7 |#
   8
   9 (in-package #:lift-test)
  10
  11 (deftestsuite lift-test () ())
  12
  13 ;;; ---------------------------------------------------------------------------
  14 ;;; lift-test-ensure
  15 ;;; make sure that ensure and its friends work as expected
  16 ;;;
  17 ;;; The strategy here is to pair "regular" tests with meta-tests. The
  18 ;;; regular tests are normal tests written using LIFT. The meta-tests
  19 ;;; use run-tests or run-tests to run the regular test and then grovel
  20 ;;; over the returned test-result to make sure it contains what it is
  21 ;;; supposed to.
  22 ;;;
  23 ;;; Note that if we don't pass in :report-pathname nil, then we'll get a lot
  24 ;;; of spurious extra report files...
  25 ;;; ---------------------------------------------------------------------------
  26
  27 (deftestsuite lift-test-ensure (lift-test) ())
  28
  29 (deftestsuite lift-test-ensure-helper () ())
  30
  31 (addtest (lift-test-ensure-helper)
  32   simple-ensure-test-1
  33   (ensure t))
  34
  35 (addtest (lift-test-ensure)
  36   simple-ensure-test-1
  37   (let ((tr (run-test :suite 'lift-test-ensure-helper
  38                       :name 'simple-ensure-test-1)))
  39     (ensure-same (length (tests-run tr)) 1)
  40     (ensure-null (failures tr))
  41     (ensure-null (errors tr))
  42     (ensure-same (test-mode tr) :single)
  43     (ensure-same (mapcar #'second (tests-run tr))
  44                  '(lift-test::simple-ensure-test-1))))
  45
  46 ;;; ---------------------------------------------------------------------------
  47
  48 (addtest (lift-test-ensure-helper)
  49   simple-ensure-test-2
  50   (ensure nil))
  51
  52 (addtest (lift-test-ensure)
  53   simple-ensure-test-2
  54   (let ((tr (run-test :suite 'lift-test-ensure-helper
  55                       :name 'simple-ensure-test-2)))
  56     (ensure-same (length (tests-run tr)) 1 :report "Number of tests-run")
  57     (ensure-same (length (failures tr)) 1 :report "Number of failures")
  58     (ensure-null (errors tr) :report "Number of errors")
  59     (ensure-same (mapcar #'second (tests-run tr))
  60                  '(lift-test::simple-ensure-test-2))))
  61
  62 ;;; ---------------------------------------------------------------------------
  63
  64 (addtest (lift-test-ensure-helper)
  65   simple-ensure-test-3
  66   (ensure (let ((x 0)) (/ x))))
  67
  68 (addtest (lift-test-ensure)
  69   simple-ensure-test-3
  70   (let ((tr (run-test :suite 'lift-test-ensure-helper
  71                       :name 'simple-ensure-test-3)))
  72     (ensure-same (length (tests-run tr)) 1)
  73     (ensure-same (length (failures tr)) 0)
  74     (ensure-same (length (errors tr)) 1)
  75     (ensure-same (mapcar #'second (tests-run tr))
  76                  '(lift-test::simple-ensure-test-3))))
  77
  78
  79 ;;; ---------------------------------------------------------------------------
  80 ;;; lift-test-setup-teardown
  81 ;;; make sure that setup and teardown happen in the right order
  82 ;;; ---------------------------------------------------------------------------
  83
  84 (deftestsuite lift-test-setup-teardown (lift-test) ())
  85
  86 (deftestsuite lift-test-setup-teardown-1 (lift-test-setup-teardown) ()
  87   (:setup (push 1 *test-notepad*))
  88   (:teardown (push :a *test-notepad*))
  89   (:tests (setup-teardown-1 (push 'test-1 *test-notepad*))))
  90
  91 (addtest (lift-test-setup-teardown)
  92   setup-teardown-1
  93   (setf *test-notepad* nil)
  94   (run-test
  95    :name 'setup-teardown-1
  96    :suite 'lift-test-setup-teardown-1
  97    :result (make-test-result 'lift-test-setup-teardown-1 :single))
  98   (ensure-same (reverse *test-notepad*)
  99                '(1 test-1 :a)))
 100
 101 (addtest (lift-test-setup-teardown)
 102   setup-teardown-1-all
 103   (setf *test-notepad* nil)
 104   (run-tests
 105    :suite 'lift-test-setup-teardown-1
 106    :result (make-test-result 'lift-test-setup-teardown-1 :multiple)
 107    :report-pathname nil)
 108   (ensure-same (reverse *test-notepad*)
 109                '(1 test-1 :a 1 2 test-2 :b :a 1 2 3 test-3 :c :b :a)))
 110
 111 (deftestsuite lift-test-setup-teardown-2 (lift-test-setup-teardown-1) ()
 112   (:setup (push 2 *test-notepad*))
 113   (:teardown (push :b *test-notepad*))
 114   (:tests (setup-teardown-2 (push 'test-2 *test-notepad*))))
 115
 116 (deftestsuite lift-test-setup-teardown-3 (lift-test-setup-teardown-2) ()
 117   (:setup (push 3 *test-notepad*))
 118   (:teardown (push :c *test-notepad*))
 119   (:tests (setup-teardown-3 (push 'test-3 *test-notepad*))))
 120
 121 (addtest (lift-test-setup-teardown)
 122   setup-teardown-3
 123   (setf *test-notepad* nil)
 124   (run-test
 125    :name 'setup-teardown-3
 126    :suite 'lift-test-setup-teardown-3
 127    :result (make-test-result 'lift-test-setup-teardown-3 :single))
 128   (ensure-same (reverse *test-notepad*)
 129                '(1 2 3 test-3 :c :b :a)))
 130
 131 (addtest (lift-test-setup-teardown)
 132   setup-teardown-3-all
 133   (setf *test-notepad* nil)
 134   (run-tests
 135    :suite 'lift-test-setup-teardown-3
 136    :result (make-test-result 'lift-test-setup-teardown-3 :multiple)
 137    :report-pathname nil)
 138   (ensure-same (reverse *test-notepad*)
 139                '(1 2 3 test-3 :c :b :a)))
 140
 141 ;;; ---------------------------------------------------------------------------
 142 ;;; test ensure same
 143 ;;; ---------------------------------------------------------------------------
 144
 145 (deftestsuite lift-test-ensure-same (lift-test)
 146   ())
 147
 148 ;;?? Gary King 2004-06-21: not really a test yet, more of a syntax works check
 149 (addtest (lift-test-ensure-same)
 150   (ensure-same 2 2 :test =)
 151   (ensure-same 2 2 :test '=)
 152   (ensure-same 2 2 :test #'=))
 153
 154 ;;; ---------------------------------------------------------------------------
 155 ;;; test single setup
 156 ;;; ---------------------------------------------------------------------------
 157
 158 (deftestsuite test-single-setup (lift-test) ())
 159
 160 ;; helpers
 161 (deftestsuite test-single-setup-helper () ())
 162
 163 (deftestsuite test-single-setup-child-a (test-single-setup-helper) ()
 164   (:setup (push :a *test-notepad*))
 165   (:test (test-1 (ensure t))))
 166
 167 (deftestsuite test-single-setup-child-a-1 (test-single-setup-child-a) ()
 168   (:setup (push :a-1 *test-notepad*))
 169   (:test (test-1 (ensure t)))
 170   (:test (test-2 (ensure t))))
 171
 172 (deftestsuite test-single-setup-child-b (test-single-setup-helper) ()
 173   (:setup (push :b *test-notepad*))
 174   (:test (test-1 (ensure t))))
 175
 176 (deftestsuite test-single-setup-child-b-1-ss (test-single-setup-child-b) ()
 177   (:run-setup :once-per-suite)
 178   (:setup (push :b-1 *test-notepad*))
 179   (:test (test-1 (ensure t)))
 180   (:test (test-2 (ensure t))))
 181
 182 (deftestsuite test-single-setup-child-b-1-a (test-single-setup-child-b-1-ss) ()
 183   (:setup (push :b-1-a *test-notepad*))
 184   (:test (test-1 (ensure t)))
 185   (:test (test-2 (ensure t))))
 186
 187 (deftestsuite test-single-setup-child-b-1-b (test-single-setup-child-b-1-ss) ()
 188   (:setup (push :b-1-b *test-notepad*))
 189   (:test (test-1 (ensure t)))
 190   (:test (test-2 (ensure t))))
 191
 192 (deftestsuite test-single-setup-child-c (test-single-setup-helper) ()
 193   (:setup (push :c *test-notepad*))
 194   (:test (test-1 (ensure t))))
 195
 196 (deftestsuite test-single-setup-child-c-1 (test-single-setup-child-c) ()
 197   (:setup (push :c-1 *test-notepad*))
 198   (:test (test-1 (ensure t))))
 199
 200 ;;; ---------------------------------------------------------------------------
 201
 202 (addtest (test-single-setup)
 203   test-a-multiple-setup
 204   (setf *test-notepad* nil)
 205   (run-test :suite 'test-single-setup-child-a-1 :name 'test-1)
 206   (run-test :suite 'test-single-setup-child-a-1 :name 'test-2)
 207   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 208
 209 (addtest (test-single-setup)
 210   test-b-single-setup-1
 211   (setf *test-notepad* nil)
 212   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-1)
 213   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-2)
 214   ;; single tests do all the setup so this should be exactly the same
 215   (ensure-same *test-notepad* '(:b-1 :b :b-1 :b)))
 216
 217 (addtest (test-single-setup)
 218   test-a-single-setup-2
 219   (setf *test-notepad* nil)
 220   (run-tests :suite 'test-single-setup-child-a-1 :do-children? nil
 221              :report-pathname nil)
 222   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 223
 224 (addtest (test-single-setup)
 225   test-a-single-setup-3
 226   (setf *test-notepad* nil)
 227   (run-tests :suite 'test-single-setup-child-a-1
 228              :run-setup :once-per-suite
 229              :do-children? nil
 230              :report-pathname nil)
 231   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 232
 233 (addtest (test-single-setup)
 234   test-b-single-setup-2
 235   (setf *test-notepad* nil)
 236   (run-tests :suite 'test-single-setup-child-b-1-ss :do-children? nil
 237              :report-pathname nil)
 238   (ensure-same *test-notepad* '(:b-1 :b)))
 239
 240 ;;; ---------------------------------------------------------------------------
 241 ;;; warning behavior
 242 ;;; ---------------------------------------------------------------------------
 243
 244 (deftestsuite test-ignore-warnings (lift-test) ())
 245
 246 (deftestsuite test-ignore-warnings-helper () ())
 247
 248 (deftestsuite test-ignore-warnings-helper-warning (test-ignore-warnings-helper) ()
 249   (:test (do-it
 250           (push :a *test-scratchpad*)
 251           (warn "Ouch")
 252           (push :b *test-scratchpad*))))
 253
 254 (deftestsuite test-ignore-warnings-helper-no-warning (test-ignore-warnings-helper) ()
 255   (:test (do-it
 256           (push :a *test-scratchpad*)
 257           (+ 2 2)
 258           (push :b *test-scratchpad*))))
 259
 260 (addtest (test-ignore-warnings)
 261   test-has-warning
 262   (run-test :suite 'test-ignore-warnings-helper-warning :name 'do-it)
 263   (ensure-same *test-scratchpad* '(:b :a)))
 264
 265 (addtest (test-ignore-warnings)
 266   test-has-no-warning
 267   (run-test :suite 'test-ignore-warnings-helper-no-warning :name 'do-it)
 268   (ensure-same *test-scratchpad* '(:b :a)))
 269
 270 ;;; ---------------------------------------------------------------------------
 271 ;;; test-environment stays clean
 272 ;;; ---------------------------------------------------------------------------
 273
 274 (deftestsuite lift-test-environment-pristine (lift-test) ()
 275   (:setup (setf *test-environment* nil)))
 276
 277 (deftestsuite lift-test-environment-pristine-helper ()
 278   ((a 2)
 279    (b (* a a))))
 280
 281 (addtest (lift-test-environment-pristine-helper)
 282   do-it
 283   (ensure-same (* a a) b))
 284
 285 (addtest (lift-test-environment-pristine
 286           :expected-failure "This is no longer guarenteed; I'm not sure yet whether or not this is a good thing.")
 287   test-1
 288   (run-test :suite 'lift-test-environment-pristine-helper :name 'do-it)
 289   (ensure (null *test-environment*)))
 290
 291
 292 ;;; ---------------------------------------------------------------------------
 293 ;;; test-creating-multiple-tests
 294 ;;; ---------------------------------------------------------------------------
 295
 296 (deftestsuite test-creating-multiple-tests (lift-test)
 297   ())
 298
 299 (deftestsuite test-creating-multiple-tests-helper ()
 300  ()
 301  (:tests ((ensure-same 1 1)
 302           (ensure-same 2 2))
 303          ((ensure-same 3 3))))
 304
 305 (addtest (test-creating-multiple-tests)
 306   test-1
 307   (ensure-same (testsuite-test-count 'test-creating-multiple-tests-helper) 2))
 308
 309 ;;;;;
 310
 311 (defvar *dynamics-before-setup* :dbs)
 312
 313 (deftestsuite dynamics-before-setup (lift-test)
 314   ()
 315   :setup (setf *test-notepad* nil))
 316
 317 (deftestsuite dynamics-before-setup-helper ()
 318   ((slot (progn (push :slot *test-notepad*) :slot)))
 319   :dynamic-variables (*dynamics-before-setup*
 320                       (progn (push :dynamics *test-notepad*) :dynamics))
 321   :setup (push :setup *test-notepad*))
 322
 323 (addtest (dynamics-before-setup-helper)
 324   test-1
 325   (push :test *test-notepad*)
 326   (ensure-same *dynamics-before-setup* :dynamics))
 327
 328 (addtest (dynamics-before-setup)
 329   test-1
 330   (run-test :suite 'dynamics-before-setup-helper
 331             :name 'test-1)
 332   (ensure-same (reverse *test-notepad*)
 333                '(:slot :dynamics :setup :test)))
 334
 335
 336 ;;;;;
 337 ;;; inherited functions
 338
 339 (deftestsuite test-inherited-functions-helper ()
 340   ()
 341   (:function
 342    (really? (a b c)
 343             (ensure-same (+ a b) c :test '=))))
 344
 345 (deftestsuite test-inherited-functions-pos (test-inherited-functions-helper)
 346   ()
 347   (:tests ((really? 1 2 3))
 348           ((really? 4 5 9))))
 349
 350 (deftestsuite test-inherited-functions-neg (test-inherited-functions-helper)
 351   ()
 352   (:tests ((really? -4 -2 -6))
 353           ((really? -1 -1 -2))))
 354
 355 (deftestsuite test-inherited-functions (lift-test)
 356   ())
 357
 358 (addtest (test-inherited-functions)
 359   one
 360   (let ((tr (run-tests :suite 'test-inherited-functions-helper
 361                        :report-pathname nil)))
 362     (ensure-same (length (tests-run tr)) 4)
 363     (ensure-null (failures tr))
 364     (ensure-null (errors tr))))
 365
 366
 367 ;;;;;
 368 ;;; slot initialization takes place with every setup
 369
 370 (deftestsuite test-initialize-slots-helper ()
 371   ((slot (incf *test-notepad*))))
 372
 373 (addtest (test-initialize-slots-helper)
 374   one
 375   (ensure t))
 376
 377 (addtest (test-initialize-slots-helper)
 378   two
 379   (ensure-null nil))
 380
 381 (deftestsuite test-initialize-slots (lift-test)
 382   ()
 383   (:setup (setf *test-notepad* 0)))
 384
 385 (addtest (test-initialize-slots)
 386   slot-initform-evaluated-every-time
 387   (let ((tr (run-tests :suite 'test-initialize-slots-helper
 388                        :report-pathname nil)))
 389     (ensure-same (length (tests-run tr)) 2)
 390     (ensure-same *test-notepad* 2 :test '=)))
 391
 392 ;;;;;
 393 ;;; errors during tests are reported in the test result
 394
 395 (defun cause-an-error ()
 396   (error "this is an error"))
 397
 398 (deftestsuite test-error-catching (lift-test)
 399   ())
 400
 401 (deftestsuite test-error-catching-helper-slot-init ()
 402   ((x (cause-an-error))))
 403
 404 (addtest (test-error-catching-helper-slot-init)
 405   slot-init
 406   (ensure t))
 407
 408 (addtest (test-error-catching)
 409   helper-slot-init
 410   (let ((result (run-test :suite 'test-error-catching-helper-slot-init
 411                           :name 'slot-init)))
 412     (ensure-same 1 (length (lift::suites-run result)))
 413     (ensure-same 1 (length (errors result)))))
 414
 415 ;;;
 416
 417 (deftestsuite test-error-catching-helper-body ()
 418   ())
 419
 420 (addtest (test-error-catching-helper-body)
 421   body
 422   (cause-an-error))
 423
 424 (addtest (test-error-catching)
 425   helper-body
 426   (let ((result (run-test :suite 'test-error-catching-helper-body
 427                           :name 'body)))
 428     (ensure-same 1 (length (tests-run result)))
 429     (ensure-same 1 (length (errors result)))))
 430
 431 ;;;
 432
 433 (deftestsuite test-error-catching-helper-setup ()
 434   ()
 435   (:setup
 436    (cause-an-error)))
 437
 438 (addtest (test-error-catching-helper-setup)
 439   setup
 440   (ensure t))
 441
 442 (addtest (test-error-catching)
 443   helper-setup
 444   (let ((result (run-test :suite 'test-error-catching-helper-setup
 445                           :name 'setup)))
 446     (ensure-same 1 (length (tests-run result)))
 447     (ensure-same 1 (length (errors result)))))
 448
 449 ;;;
 450
 451 (deftestsuite test-error-catching-helper-teardown ()
 452   ()
 453   (:teardown
 454    (cause-an-error)))
 455
 456 (addtest (test-error-catching-helper-teardown)
 457   teardown
 458   (ensure t))
 459
 460 (addtest (test-error-catching)
 461   helper-teardown
 462   (let ((result (run-test :suite 'test-error-catching-helper-teardown
 463                           :name 'teardown)))
 464     (ensure-same 1 (length (tests-run result)))
 465     (ensure-same 1 (length (errors result)))))
 466
 467 ;;;
 468
 469 (defvar *test-error-catching-helper*)
 470
 471 (deftestsuite test-error-catching-helper-dynamic-variables ()
 472   ()
 473   (:dynamic-variables
 474    (*test-error-catching-helper* (cause-an-error))))
 475
 476 (addtest (test-error-catching-helper-dynamic-variables)
 477   dynamic-variables
 478   (ensure t))
 479
 480 (addtest (test-error-catching)
 481   helper-dynamic-variables
 482   (let ((result (run-test :suite 'test-error-catching-helper-dynamic-variables
 483                           :name 'dynamic-variables)))
 484     (ensure-same 1 (length (lift::suites-run result)))
 485     (ensure-same 1 (length (errors result)))))
 486
 487 ;;;
 488
 489 (deftestsuite test-error-catching-helper-equality-test ()
 490   ()
 491   (:equality-test
 492    (cause-an-error)))
 493
 494 (addtest (test-error-catching-helper-equality-test)
 495   equality-test
 496   (ensure t))
 497
 498 (addtest (test-error-catching)
 499   helper-equality-test
 500   (let ((result (run-test :suite 'test-error-catching-helper-equality-test
 501                           :name 'equality-test)))
 502     (ensure-same 0 (length (lift::suites-run result))) ;hmmm
 503     (ensure-same 1 (length (errors result)))))
 504
 505 ;;;;
 506
 507 (deftestsuite test-interaction (lift-test)
 508   ()
 509   (:equality-test #'string=))
 510
 511 (addtest (test-interaction)
 512   run-test-sets-values
 513   (run-test :suite 'lift-test-ensure-helper :name 'simple-ensure-test-3)
 514   (ensure-same
 515    (symbol-name lift::*current-test-case-name*)
 516    (symbol-name 'simple-ensure-test-3))
 517   (ensure-same
 518    (symbol-name lift::*current-testsuite-name*)
 519    (symbol-name 'lift-test-ensure-helper)))
 520
 521 (addtest (test-interaction)
 522   run-tests-sets-values
 523   (run-tests :suite 'lift-test-ensure-helper
 524              :report-pathname nil)
 525   (ensure-same
 526    (symbol-name lift::*current-testsuite-name*)
 527    (symbol-name 'lift-test-ensure-helper))
 528   (ensure-same
 529    (symbol-name lift::*current-test-case-name*)
 530    (symbol-name 'simple-ensure-test-3)))
 531
 532 (addtest (test-interaction)
 533   run-test-sets-values-nested
 534   (run-test :suite 'test-interaction :test-case 'run-tests-sets-values)
 535   (ensure-same
 536    (symbol-name lift::*current-testsuite-name*)
 537    (symbol-name 'test-interaction))
 538   (ensure-same
 539    (symbol-name lift::*current-test-case-name*)
 540    (symbol-name 'run-tests-sets-values)))
 541
 542 ;;;;
 543
 544 (deftestsuite test-expected-errors (lift-test)
 545   ())
 546
 547 (deftestsuite test-expected-errors-helper ()
 548   ())
 549
 550 (addtest (test-expected-errors-helper
 551           :expected-error t)
 552   test-1
 553   (error "this is an error"))
 554
 555 (addtest (test-expected-errors)
 556   test-passes
 557   (let ((result (run-tests :suite 'test-expected-errors-helper
 558                            :report-pathname nil)))
 559     (ensure-same 1 (length (tests-run result)))
 560     (ensure-same 0 (length (errors result)))
 561     (ensure-same 1 (length (expected-errors result)))
 562     ))
 563
 564 (eval-when (:compile-toplevel :load-toplevel :execute)
 565   (defparameter *test-expected-errors-helper-2* nil))
 566
 567 (deftestsuite test-expected-errors-helper-2 ()
 568   ())
 569
 570 (addtest (test-expected-errors-helper-2
 571           :expected-error *test-expected-errors-helper-2*)
 572   test-1
 573   (error "this is an error"))
 574
 575 (addtest (test-expected-errors)
 576   test-expected-error-helper-true
 577   (let* ((*test-expected-errors-helper-2* t)
 578          (result (run-tests :suite 'test-expected-errors-helper-2
 579                            :report-pathname nil)))
 580     (ensure-same 1 (length (tests-run result)))
 581     (ensure-same 0 (length (errors result)))
 582     (ensure-same 1 (length (expected-errors result)))
 583     ))
 584
 585 (addtest (test-expected-errors)
 586   test-expected-error-helper-false
 587   (let* ((*test-expected-errors-helper-2* nil)
 588          (result (run-tests :suite 'test-expected-errors-helper-2
 589                            :report-pathname nil)))
 590     (ensure-same 1 (length (tests-run result)))
 591     (ensure-same 1 (length (errors result)))
 592     (ensure-same 0 (length (expected-errors result)))
 593     ))
 594
 595 (addtest (test-expected-errors)
 596   donot-break-on-errors
 597   ;; this is weird
 598   ;; I wonder if it's worth trying to abstract "up"
 599   (let ((*debugger-hook* (lambda (condition hook)
 600                            (declare (ignore hook))
 601                            (when (find-restart 'entered-debugger)
 602                              (invoke-restart 'entered-debugger condition))
 603                            (invoke-debugger condition))))
 604     (restart-case
 605       (let ((result (run-tests :suite 'test-expected-errors-helper
 606                                :report-pathname nil
 607                                :break-on-errors? t)))
 608         (ensure-same 1 (length (tests-run result)))
 609         (ensure-same 0 (length (errors result)))
 610         (ensure-same 1 (length (expected-errors result)))
 611         )
 612     (entered-debugger (c)
 613       (declare (ignore c))
 614       (ensure-null "We should not be here")))))
 615
 616 ;;;;
 617
 618 ;;?? these pass but the cliquep test did not seem to be working. Why?
 619 (deftestsuite test-scratchpad-resets (lift-test)
 620   ())
 621
 622 (deftestsuite test-scratchpad-resets-helper ()
 623   ()
 624   (:test
 625    (test-3 (push :test *test-scratchpad*)))
 626   (:test
 627    (test-4 (push :burt *test-scratchpad*))))
 628
 629 (addtest (test-scratchpad-resets)
 630   run-once-have-one
 631   (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
 632   (ensure-same '(:test) *test-scratchpad*))
 633
 634 (addtest (test-scratchpad-resets)
 635   run-twice-have-one
 636   (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
 637   (run-test :suite 'test-scratchpad-resets-helper :test-case 'test-3)
 638   (ensure-same '(:test) *test-scratchpad*))
 639
 640 (addtest (test-scratchpad-resets)
 641   run-twice-have-one-run-tests
 642   (run-tests :suite 'test-scratchpad-resets-helper :report-pathname nil)
 643   (run-tests :suite 'test-scratchpad-resets-helper :report-pathname nil)
 644   (ensure-same '(:burt) *test-scratchpad*))
 645
 646 ;;;;
 647
 648 (deftestsuite test-break-on-failure (lift-test)
 649   ())
 650
 651 (deftestsuite test-break-on-failure-helper ()
 652   ()
 653   ;; :categories (foo bar)
 654   )
 655
 656 (addtest (test-break-on-failure-helper)
 657   failing-test
 658   (ensure-null "this fails"))
 659
 660 (addtest (test-break-on-failure)
 661   donot-break-on-failures
 662   (let* ((*test-break-on-failures?* nil)
 663          (result (run-tests :suite 'test-break-on-failure-helper
 664                             :report-pathname nil)))
 665     (ensure-same 1 (length (tests-run result)))
 666     (ensure-same 1 (length (failures result)))))
 667
 668 (addtest (test-break-on-failure)
 669   do-break-on-failures
 670   (let* ((*test-break-on-failures?* t)
 671          (*debugger-hook* (lambda (condition hook)
 672                             (declare (ignore hook))
 673                             (when (find-restart 'entered-debugger)
 674                               (invoke-restart 'entered-debugger condition))
 675                             (invoke-debugger condition)))
 676          (result nil))
 677     (restart-case
 678         (setf result (run-tests :suite 'test-break-on-failure-helper
 679                                 :report-pathname nil))
 680       (entered-debugger (c)
 681         (declare (ignore c))
 682         (setf *test-scratchpad* t)))
 683     (ensure-null result)
 684     (ensure-same *test-scratchpad* t :test 'eq)))
 685
 686 ;;;;
 687
 688 (deftestsuite ensure-no-warning (lift-test)
 689   ())
 690
 691 (deftestsuite ensure-no-warning-helper ()
 692   ())
 693
 694 (addtest (ensure-no-warning-helper)
 695   test-1
 696   (ensure-no-warning (ensure-same (+ 2 2) 4)))
 697
 698 (addtest (ensure-no-warning-helper)
 699   test-2
 700   (ensure-no-warning (ensure-same (+ 2 2) 4)
 701                      (warn "I like math")))
 702
 703 (addtest (ensure-no-warning)
 704   run-tests
 705   (let ((result (run-tests :suite 'ensure-no-warning-helper
 706                            :report-pathname nil)))
 707     (ensure-same (length (tests-run result)) 2)
 708     (ensure-same (length (failures result)) 1)
 709     (ensure-same (length (errors result)) 0)))
 710
 711