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   (:dynamic-variables
  14    (*test-break-on-errors?* nil)
  15    (*test-break-on-failures?* nil)))
  16
  17 ;;; ---------------------------------------------------------------------------
  18 ;;; lift-test-ensure
  19 ;;; make sure that ensure and its friends work as expected
  20 ;;;
  21 ;;; The strategy here is to pair "regular" tests with meta-tests. The
  22 ;;; regular tests are normal tests written using LIFT. The meta-tests
  23 ;;; use run-tests or run-tests to run the regular test and then grovel
  24 ;;; over the returned test-result to make sure it contains what it is
  25 ;;; supposed to.
  26 ;;;
  27 ;;; Note that if we don't pass in :report-pathname nil, then we'll get a lot
  28 ;;; of spurious extra report files...
  29 ;;; ---------------------------------------------------------------------------
  30
  31 (deftestsuite lift-test-ensure (lift-test) ())
  32
  33 (deftestsuite lift-test-ensure-helper () ())
  34
  35 (addtest (lift-test-ensure-helper)
  36   simple-ensure-test-1
  37   (ensure t))
  38
  39 (addtest (lift-test-ensure)
  40   simple-ensure-test-1
  41   (let ((tr (run-test :suite 'lift-test-ensure-helper
  42                       :name 'simple-ensure-test-1)))
  43     (ensure-same (length (tests-run tr)) 1)
  44     (ensure-null (failures tr))
  45     (ensure-null (errors tr))
  46     (ensure-same (test-mode tr) :single)
  47     (ensure-same (mapcar #'second (tests-run tr))
  48                  '(lift-test::simple-ensure-test-1))))
  49
  50 ;;; ---------------------------------------------------------------------------
  51
  52 (addtest (lift-test-ensure-helper)
  53   simple-ensure-test-2
  54   (ensure nil))
  55
  56 (addtest (lift-test-ensure)
  57   simple-ensure-test-2
  58   (let ((tr (run-test :suite 'lift-test-ensure-helper
  59                       :name 'simple-ensure-test-2)))
  60     (ensure-same (length (tests-run tr)) 1 :report "Number of tests-run")
  61     (ensure-same (length (failures tr)) 1 :report "Number of failures")
  62     (ensure-null (errors tr) :report "Number of errors")
  63     (ensure-same (mapcar #'second (tests-run tr))
  64                  '(lift-test::simple-ensure-test-2))))
  65
  66 ;;; ---------------------------------------------------------------------------
  67
  68 (addtest (lift-test-ensure-helper)
  69   simple-ensure-test-3
  70   (handler-case
  71       (ensure (let ((x 0)) (/ x)))
  72     (error (c)
  73       (print c)
  74       (error c))))
  75
  76 (addtest (lift-test-ensure)
  77   simple-ensure-test-3
  78   (let ((tr (run-test :suite 'lift-test-ensure-helper
  79                       :name 'simple-ensure-test-3)))
  80     (ensure-same (length (tests-run tr)) 1)
  81     (ensure-same (length (failures tr)) 0)
  82     (ensure-same (length (errors tr)) 1)
  83     (ensure-same (mapcar #'second (tests-run tr))
  84                  '(lift-test::simple-ensure-test-3))))
  85
  86
  87 ;;; ---------------------------------------------------------------------------
  88 ;;; lift-test-setup-teardown
  89 ;;; make sure that setup and teardown happen in the right order
  90 ;;; ---------------------------------------------------------------------------
  91
  92 (deftestsuite lift-test-setup-teardown (lift-test) ())
  93
  94 (deftestsuite lift-test-setup-teardown-1 (lift-test-setup-teardown) ()
  95   (:setup (push 1 *test-notepad*))
  96   (:teardown (push :a *test-notepad*))
  97   (:tests (setup-teardown-1 (push 'test-1 *test-notepad*))))
  98
  99 (addtest (lift-test-setup-teardown)
 100   setup-teardown-1
 101   (setf *test-notepad* nil)
 102   (run-test
 103    :name 'setup-teardown-1
 104    :suite 'lift-test-setup-teardown-1
 105    :result (make-test-result 'lift-test-setup-teardown-1 :single))
 106   (ensure-same (reverse *test-notepad*)
 107                '(1 test-1 :a)))
 108
 109 (addtest (lift-test-setup-teardown)
 110   setup-teardown-1-all
 111   (setf *test-notepad* nil)
 112   (run-tests
 113    :suite 'lift-test-setup-teardown-1
 114    :result (make-test-result 'lift-test-setup-teardown-1 :multiple)
 115    :report-pathname nil)
 116   (ensure-same (reverse *test-notepad*)
 117                '(1 test-1 :a 1 2 test-2 :b :a 1 2 3 test-3 :c :b :a)))
 118
 119 (deftestsuite lift-test-setup-teardown-2 (lift-test-setup-teardown-1) ()
 120   (:setup (push 2 *test-notepad*))
 121   (:teardown (push :b *test-notepad*))
 122   (:tests (setup-teardown-2 (push 'test-2 *test-notepad*))))
 123
 124 (deftestsuite lift-test-setup-teardown-3 (lift-test-setup-teardown-2) ()
 125   (:setup (push 3 *test-notepad*))
 126   (:teardown (push :c *test-notepad*))
 127   (:tests (setup-teardown-3 (push 'test-3 *test-notepad*))))
 128
 129 (addtest (lift-test-setup-teardown)
 130   setup-teardown-3
 131   (setf *test-notepad* nil)
 132   (run-test
 133    :name 'setup-teardown-3
 134    :suite 'lift-test-setup-teardown-3
 135    :result (make-test-result 'lift-test-setup-teardown-3 :single))
 136   (ensure-same (reverse *test-notepad*)
 137                '(1 2 3 test-3 :c :b :a)))
 138
 139 (addtest (lift-test-setup-teardown)
 140   setup-teardown-3-all
 141   (setf *test-notepad* nil)
 142   (run-tests
 143    :suite 'lift-test-setup-teardown-3
 144    :result (make-test-result 'lift-test-setup-teardown-3 :multiple)
 145    :report-pathname nil)
 146   (ensure-same (reverse *test-notepad*)
 147                '(1 2 3 test-3 :c :b :a)))
 148
 149 ;;; ---------------------------------------------------------------------------
 150 ;;; test ensure same
 151 ;;; ---------------------------------------------------------------------------
 152
 153 (deftestsuite lift-test-ensure-comparisons (lift-test)
 154   ())
 155
 156 ;;?? Gary King 2004-06-21: not really a test yet, more of a syntax works check
 157 (addtest (lift-test-ensure-comparisons)
 158   same-basic
 159   (ensure-same 2 2)
 160   (ensure-same 2 2 :test =)
 161   (ensure-same 2 2 :test '=)
 162   (ensure-same 2 2 :test #'=))
 163
 164 (addtest (lift-test-ensure-comparisons)
 165   same-test-flet
 166   (flet ((check (a b)
 167            (= (abs a) (abs b))))
 168     (ensure-same 2 -2 :test #'check)
 169     (ensure-same 2 -2 :test 'check)
 170     (ensure-same 2 -2 :test check)))
 171
 172 (addtest (lift-test-ensure-comparisons)
 173   same-test-labels
 174   (labels ((check (a b)
 175              (= (abs a) (abs b))))
 176     (ensure-same 2 -2 :test #'check)
 177     (ensure-same 2 -2 :test 'check)
 178     (ensure-same 2 -2 :test check)))
 179
 180 (defun %make-test-ensure-same-test (fn)
 181   (lambda (a b)
 182     (funcall fn a b)))
 183
 184 (addtest (lift-test-ensure-comparisons)
 185   same-test-with-test-maker
 186   (ensure-same 2 2 :test (%make-test-ensure-same-test #'=)))
 187
 188 ;;?? Gary King 2004-06-21: not really a test yet, more of a syntax works check
 189 (addtest (lift-test-ensure-comparisons)
 190   different-basic
 191   (ensure-different 2 -12)
 192   (ensure-different -2 2 :test =)
 193   (ensure-different 20 2 :test '=)
 194   (ensure-different 2 2.1 :test #'=))
 195
 196 (addtest (lift-test-ensure-comparisons)
 197   different-test-flet
 198   (flet ((check (a b)
 199            (= (abs a) (abs b))))
 200     (ensure-different 2 -2.1 :test #'check)
 201     (ensure-different 1.9 -2 :test 'check)
 202     (ensure-different 20 -2 :test check)))
 203
 204 (addtest (lift-test-ensure-comparisons)
 205   different-test-labels
 206   (labels ((check (a b)
 207              (= (abs a) (abs b))))
 208     (ensure-different 2 -2.1 :test #'check)
 209     (ensure-different 1.9 -2 :test 'check)
 210     (ensure-different 20 -2 :test check)))
 211
 212 (addtest (lift-test-ensure-comparisons)
 213   different-test-with-test-maker
 214   (ensure-different 20 2 :test (%make-test-ensure-same-test #'=)))
 215
 216
 217
 218 ;;; ---------------------------------------------------------------------------
 219 ;;; test single setup
 220 ;;; ---------------------------------------------------------------------------
 221
 222 (deftestsuite test-single-setup (lift-test) ())
 223
 224 ;; helpers
 225 (deftestsuite test-single-setup-helper () ())
 226
 227 (deftestsuite test-single-setup-child-a (test-single-setup-helper) ()
 228   (:setup (push :a *test-notepad*))
 229   (:test (test-1 (ensure t))))
 230
 231 (deftestsuite test-single-setup-child-a-1 (test-single-setup-child-a) ()
 232   (:setup (push :a-1 *test-notepad*))
 233   (:test (test-1 (ensure t)))
 234   (:test (test-2 (ensure t))))
 235
 236 (deftestsuite test-single-setup-child-b (test-single-setup-helper) ()
 237   (:setup (push :b *test-notepad*))
 238   (:test (test-1 (ensure t))))
 239
 240 (deftestsuite test-single-setup-child-b-1-ss (test-single-setup-child-b) ()
 241   (:run-setup :once-per-suite)
 242   (:setup (push :b-1 *test-notepad*))
 243   (:test (test-1 (ensure t)))
 244   (:test (test-2 (ensure t))))
 245
 246 (deftestsuite test-single-setup-child-b-1-a (test-single-setup-child-b-1-ss) ()
 247   (:setup (push :b-1-a *test-notepad*))
 248   (:test (test-1 (ensure t)))
 249   (:test (test-2 (ensure t))))
 250
 251 (deftestsuite test-single-setup-child-b-1-b (test-single-setup-child-b-1-ss) ()
 252   (:setup (push :b-1-b *test-notepad*))
 253   (:test (test-1 (ensure t)))
 254   (:test (test-2 (ensure t))))
 255
 256 (deftestsuite test-single-setup-child-c (test-single-setup-helper) ()
 257   (:setup (push :c *test-notepad*))
 258   (:test (test-1 (ensure t))))
 259
 260 (deftestsuite test-single-setup-child-c-1 (test-single-setup-child-c) ()
 261   (:setup (push :c-1 *test-notepad*))
 262   (:test (test-1 (ensure t))))
 263
 264 ;;; ---------------------------------------------------------------------------
 265
 266 (addtest (test-single-setup)
 267   test-a-multiple-setup
 268   (setf *test-notepad* nil)
 269   (run-test :suite 'test-single-setup-child-a-1 :name 'test-1)
 270   (run-test :suite 'test-single-setup-child-a-1 :name 'test-2)
 271   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 272
 273 (addtest (test-single-setup)
 274   test-b-single-setup-1
 275   (setf *test-notepad* nil)
 276   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-1)
 277   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-2)
 278   ;; single tests do all the setup so this should be exactly the same
 279   (ensure-same *test-notepad* '(:b-1 :b :b-1 :b)))
 280
 281 (addtest (test-single-setup)
 282   test-a-single-setup-2
 283   (setf *test-notepad* nil)
 284   (run-tests :suite 'test-single-setup-child-a-1 :do-children? nil
 285              :report-pathname nil)
 286   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 287
 288 (addtest (test-single-setup)
 289   test-a-single-setup-3
 290   (setf *test-notepad* nil)
 291   (run-tests :suite 'test-single-setup-child-a-1
 292              :run-setup :once-per-suite
 293              :do-children? nil
 294              :report-pathname nil)
 295   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 296
 297 (addtest (test-single-setup)
 298   test-b-single-setup-2
 299   (setf *test-notepad* nil)
 300   (run-tests :suite 'test-single-setup-child-b-1-ss :do-children? nil
 301              :report-pathname nil)
 302   (ensure-same *test-notepad* '(:b-1 :b)))
 303
 304 ;;; ---------------------------------------------------------------------------
 305 ;;; warning behavior
 306 ;;; ---------------------------------------------------------------------------
 307
 308 (deftestsuite test-ignore-warnings (lift-test) ())
 309
 310 (deftestsuite test-ignore-warnings-helper () ())
 311
 312 (deftestsuite test-ignore-warnings-helper-warning (test-ignore-warnings-helper) ()
 313   (:test (do-it
 314           (push :a *test-scratchpad*)
 315           (warn "Ouch")
 316           (push :b *test-scratchpad*))))
 317
 318 (deftestsuite test-ignore-warnings-helper-no-warning (test-ignore-warnings-helper) ()
 319   (:test (do-it
 320           (push :a *test-scratchpad*)
 321           (+ 2 2)
 322           (push :b *test-scratchpad*))))
 323
 324 (addtest (test-ignore-warnings)
 325   test-has-warning
 326   (run-test :suite 'test-ignore-warnings-helper-warning :name 'do-it)
 327   (ensure-same *test-scratchpad* '(:b :a)))
 328
 329 (addtest (test-ignore-warnings)
 330   test-has-no-warning
 331   (run-test :suite 'test-ignore-warnings-helper-no-warning :name 'do-it)
 332   (ensure-same *test-scratchpad* '(:b :a)))
 333
 334
 335 ;;; ---------------------------------------------------------------------------
 336 ;;; test-creating-multiple-tests
 337 ;;; ---------------------------------------------------------------------------
 338
 339 (deftestsuite test-creating-multiple-tests (lift-test)
 340   ())
 341
 342 (deftestsuite test-creating-multiple-tests-helper ()
 343  ()
 344  (:tests ((ensure-same 1 1)
 345           (ensure-same 2 2))
 346          ((ensure-same 3 3))))
 347
 348 (addtest (test-creating-multiple-tests)
 349   test-1
 350   (ensure-same (testsuite-test-count 'test-creating-multiple-tests-helper) 2))
 351
 352 ;;;;;
 353
 354 (defvar *dynamics-after-setup* :das)
 355
 356 (deftestsuite dynamics-after-setup (lift-test)
 357   ()
 358   :setup (setf *test-notepad* nil))
 359
 360 (deftestsuite dynamics-after-setup-helper ()
 361   ((slot (progn (push :slot *test-notepad*) :slot)))
 362   :dynamic-variables (*dynamics-after-setup*
 363                       (progn (push :dynamics *test-notepad*) :dynamics))
 364   (:setup (push :setup *test-notepad*) (print (list :tn *test-notepad*))))
 365
 366 (addtest (dynamics-after-setup-helper)
 367   test-1
 368   (push :test *test-notepad*)
 369   (ensure-same *dynamics-after-setup* :dynamics))
 370
 371 (addtest (dynamics-after-setup)
 372   test-1
 373   (run-test :suite 'dynamics-after-setup-helper
 374             :name 'test-1)
 375   (ensure-same (reverse *test-notepad*)
 376                '(:slot :dynamics :setup :test)))
 377
 378
 379 ;;;;;
 380 ;;; inherited functions
 381
 382 (deftestsuite test-inherited-functions-helper ()
 383   ()
 384   (:function
 385    (really? (a b c)
 386             (ensure-same (+ a b) c :test '=))))
 387
 388 (deftestsuite test-inherited-functions-pos (test-inherited-functions-helper)
 389   ()
 390   (:tests ((really? 1 2 3))
 391           ((really? 4 5 9))))
 392
 393 (deftestsuite test-inherited-functions-neg (test-inherited-functions-helper)
 394   ()
 395   (:tests ((really? -4 -2 -6))
 396           ((really? -1 -1 -2))))
 397
 398 (deftestsuite test-inherited-functions (lift-test)
 399   ())
 400
 401 (addtest (test-inherited-functions)
 402   one
 403   (let ((tr (run-tests :suite 'test-inherited-functions-helper
 404                        :report-pathname nil)))
 405     (ensure-same (length (tests-run tr)) 4)
 406     (ensure-null (failures tr))
 407     (ensure-null (errors tr))))
 408
 409
 410 ;;;;;
 411 ;;; slot initialization takes place ONCE
 412
 413 (deftestsuite test-initialize-slots-helper ()
 414   ((slot (incf *test-notepad*))))
 415
 416 (addtest (test-initialize-slots-helper)
 417   one
 418   (ensure t))
 419
 420 (addtest (test-initialize-slots-helper)
 421   two
 422   (ensure-null nil))
 423
 424 (deftestsuite test-initialize-slots (lift-test)
 425   ()
 426   (:setup (setf *test-notepad* 0)))
 427
 428 (addtest (test-initialize-slots)
 429   slot-initform-evaluated-every-time
 430   (let ((tr (run-tests :suite 'test-initialize-slots-helper
 431                        :report-pathname nil)))
 432     (ensure-same (length (tests-run tr)) 2)
 433     (ensure-same *test-notepad* 1 :test '=)))
 434
 435 ;;;;;
 436 ;;; errors during tests are reported in the test result
 437
 438 (defun cause-an-error ()
 439   (error "this is an error"))
 440
 441 (deftestsuite test-error-catching (lift-test)
 442   ())
 443
 444 (deftestsuite test-error-catching-helper-slot-init ()
 445   ((x (cause-an-error))))
 446
 447 (addtest (test-error-catching-helper-slot-init)
 448   slot-init
 449   (ensure t))
 450
 451 (addtest (test-error-catching)
 452   helper-slot-init
 453   (let ((result (run-test :suite 'test-error-catching-helper-slot-init
 454                           :name 'slot-init)))
 455     ;;?? test not run because error occurred during setup
 456     (ensure-same 0 (length (lift::suites-run result)) :report "tests run")
 457     (ensure-same 1 (length (errors result)) :report "errors counted")))
 458
 459 ;;;
 460
 461 (deftestsuite test-error-catching-helper-body ()
 462   ())
 463
 464 (addtest (test-error-catching-helper-body)
 465   body
 466   (cause-an-error))
 467
 468 (addtest (test-error-catching)
 469   helper-body
 470   (let ((result (run-test :suite 'test-error-catching-helper-body
 471                           :name 'body)))
 472     (ensure-same 1 (length (tests-run result)))
 473     (ensure-same 1 (length (errors result)))))
 474
 475 ;;;
 476
 477 (deftestsuite test-error-catching-helper-setup ()
 478   ()
 479   (:setup
 480    (cause-an-error)))
 481
 482 (addtest (test-error-catching-helper-setup)
 483   setup
 484   (ensure t))
 485
 486 (addtest (test-error-catching)
 487   helper-setup
 488   (let ((result (run-test :suite 'test-error-catching-helper-setup
 489                           :name 'setup)))
 490     (ensure-same 1 (length (tests-run result)))
 491     (ensure-same 1 (length (errors result)))))
 492
 493 ;;;
 494
 495 (deftestsuite test-error-catching-helper-teardown ()
 496   ()
 497   (:teardown
 498    (cause-an-error)))
 499
 500 (addtest (test-error-catching-helper-teardown)
 501   teardown
 502   (ensure t))
 503
 504 (addtest (test-error-catching)
 505   helper-teardown
 506   (let ((result (run-test :suite 'test-error-catching-helper-teardown
 507                           :name 'teardown)))
 508     (ensure-same 1 (length (tests-run result)))
 509     (ensure-same 1 (length (errors result)))))
 510
 511 ;;;
 512
 513 (defvar *test-error-catching-helper*)
 514
 515 (deftestsuite test-error-catching-helper-dynamic-variables ()
 516   ()
 517   (:dynamic-variables
 518    (*test-error-catching-helper* (cause-an-error))))
 519
 520 (addtest (test-error-catching-helper-dynamic-variables)
 521   dynamic-variables
 522   (ensure t))
 523
 524 (addtest (test-error-catching)
 525   helper-dynamic-variables
 526   (let ((result (run-test :suite 'test-error-catching-helper-dynamic-variables
 527                           :name 'dynamic-variables)))
 528     (ensure-same 1 (length (lift::suites-run result)))
 529     (ensure-same 1 (length (errors result)))))
 530
 531 ;;;
 532
 533 (deftestsuite test-error-catching-helper-equality-test ()
 534   ()
 535   (:equality-test
 536    (cause-an-error)))
 537
 538 (addtest (test-error-catching-helper-equality-test)
 539   equality-test
 540   (ensure t))
 541
 542 (addtest (test-error-catching)
 543   helper-equality-test
 544   (let ((result (run-test :suite 'test-error-catching-helper-equality-test
 545                           :name 'equality-test)))
 546     (ensure-same 0 (length (lift::suites-run result))) ;hmmm
 547     (ensure-same 1 (length (errors result)))))
 548
 549 ;;;;
 550
 551 (deftestsuite test-interaction (lift-test)
 552   ()
 553   (:equality-test #'string=))
 554
 555 (addtest (test-interaction)
 556   run-test-sets-values
 557   (run-test :suite 'lift-test-ensure-helper :name 'simple-ensure-test-3)
 558   (ensure-same
 559    (symbol-name lift::*last-test-case-name*)
 560    (symbol-name 'simple-ensure-test-3))
 561   (ensure-same
 562    (symbol-name lift::*last-testsuite-name*)
 563    (symbol-name 'lift-test-ensure-helper)))
 564
 565 (addtest (test-interaction)
 566   run-tests-sets-values
 567   (run-tests :suite 'lift-test-ensure-helper
 568              :report-pathname nil)
 569   (ensure-same
 570    (symbol-name lift::*last-testsuite-name*)
 571    (symbol-name 'lift-test-ensure-helper))
 572   (ensure-same
 573    (symbol-name lift::*last-test-case-name*)
 574    (symbol-name 'simple-ensure-test-3)))
 575
 576 (addtest (test-interaction)
 577   run-test-sets-values-nested
 578   (run-test :suite 'test-interaction :name 'run-tests-sets-values)
 579   (ensure-same
 580    (symbol-name lift::*last-testsuite-name*)
 581    (symbol-name 'test-interaction))
 582   (ensure-same
 583    (symbol-name lift::*last-test-case-name*)
 584    (symbol-name 'run-tests-sets-values)))
 585
 586 ;;;;
 587
 588 (deftestsuite test-expected-errors (lift-test)
 589   ()
 590   (:dynamic-variables
 591    (*test-break-on-errors?* nil)
 592    (*test-break-on-failures?* nil)))
 593
 594 (deftestsuite test-expected-errors-helper ()
 595   ())
 596
 597 (addtest (test-expected-errors-helper
 598           :expected-error t)
 599   test-1
 600   (error "this is an error"))
 601
 602 (addtest (test-expected-errors)
 603   test-passes
 604   (let ((result (run-tests :suite 'test-expected-errors-helper
 605                            :report-pathname nil)))
 606     (ensure-same 1 (length (tests-run result)))
 607     (ensure-same 0 (length (errors result)))
 608     (ensure-same 1 (length (expected-errors result)))
 609     ))
 610
 611 (eval-when (:compile-toplevel :load-toplevel :execute)
 612   (defparameter *test-expected-errors-helper-2* nil))
 613
 614 (deftestsuite test-expected-errors-helper-2 ()
 615   ())
 616
 617 (addtest (test-expected-errors-helper-2
 618           :expected-error *test-expected-errors-helper-2*)
 619   test-1
 620   (error "this is an error"))
 621
 622 (addtest (test-expected-errors)
 623   test-expected-error-helper-true
 624   (let* ((*test-expected-errors-helper-2* t)
 625          (result (run-tests :suite 'test-expected-errors-helper-2
 626                            :report-pathname nil)))
 627     (ensure-same 1 (length (tests-run result)))
 628     (ensure-same 0 (length (errors result)))
 629     (ensure-same 1 (length (expected-errors result)))
 630     ))
 631
 632 (addtest (test-expected-errors)
 633   test-expected-error-helper-false
 634   (let* ((*test-expected-errors-helper-2* nil)
 635          (result (run-tests :suite 'test-expected-errors-helper-2
 636                            :report-pathname nil)))
 637     (ensure-same 1 (length (tests-run result)))
 638     (ensure-same 1 (length (errors result)))
 639     (ensure-same 0 (length (expected-errors result)))
 640     ))
 641
 642 (addtest (test-expected-errors)
 643   donot-break-on-errors
 644   ;; this is weird
 645   ;; I wonder if it's worth trying to abstract "up"
 646   (let ((*debugger-hook* (lambda (condition hook)
 647                            (declare (ignore hook))
 648                            (when (find-restart 'entered-debugger)
 649                              (invoke-restart 'entered-debugger condition))
 650                            (invoke-debugger condition))))
 651     (restart-case
 652       (let ((result (run-tests :suite 'test-expected-errors-helper
 653                                :report-pathname nil
 654                                :break-on-errors? t)))
 655         (ensure-same 1 (length (tests-run result)))
 656         (ensure-same 0 (length (errors result)))
 657         (ensure-same 1 (length (expected-errors result)))
 658         )
 659     (entered-debugger (c)
 660       (declare (ignore c))
 661       (ensure-null "We should not be here")))))
 662
 663 ;;;;
 664
 665 ;;?? these pass but the cliquep test did not seem to be working. Why?
 666 (deftestsuite test-scratchpad-resets (lift-test)
 667   ())
 668
 669 (deftestsuite test-scratchpad-resets-helper ()
 670   ()
 671   (:test
 672    (test-3 (push :test *test-scratchpad*)))
 673   (:test
 674    (test-4 (push :burt *test-scratchpad*))))
 675
 676 (addtest (test-scratchpad-resets)
 677   run-once-have-one
 678   (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
 679   (ensure-same '(:test) *test-scratchpad*))
 680
 681 (addtest (test-scratchpad-resets)
 682   run-twice-have-one
 683   (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
 684   (run-test :suite 'test-scratchpad-resets-helper :name 'test-3)
 685   (ensure-same '(:test) *test-scratchpad*))
 686
 687 (addtest (test-scratchpad-resets)
 688   run-twice-have-one-run-tests
 689   (run-tests :suite 'test-scratchpad-resets-helper :report-pathname nil)
 690   (run-tests :suite 'test-scratchpad-resets-helper :report-pathname nil)
 691   (ensure-same '(:burt) *test-scratchpad*))
 692
 693 ;;;;
 694
 695 (deftestsuite test-break-on-failure (lift-test)
 696   ())
 697
 698 (deftestsuite test-break-on-failure-helper ()
 699   ()
 700   ;; :categories (foo bar)
 701   )
 702
 703 (addtest (test-break-on-failure-helper)
 704   failing-test
 705   (ensure-null "this fails"))
 706
 707 (addtest (test-break-on-failure)
 708   donot-break-on-failures
 709   (let* ((*test-break-on-failures?* nil)
 710          (result (run-tests :suite 'test-break-on-failure-helper
 711                             :report-pathname nil)))
 712     (ensure-same 1 (length (tests-run result)))
 713     (ensure-same 1 (length (failures result)))))
 714
 715 (addtest (test-break-on-failure)
 716   do-break-on-failures
 717   (let* ((*test-break-on-failures?* t)
 718          (*debugger-hook* (lambda (condition hook)
 719                             (declare (ignore hook))
 720                             (when (find-restart 'entered-debugger)
 721                               (invoke-restart 'entered-debugger condition))
 722                             (invoke-debugger condition)))
 723          (result nil))
 724     (restart-case
 725         (setf result (run-tests :suite 'test-break-on-failure-helper
 726                                 :report-pathname nil))
 727       (entered-debugger (c)
 728         (declare (ignore c))
 729         (setf *test-scratchpad* t)))
 730     (ensure-null result)
 731     (ensure-same *test-scratchpad* t :test 'eq)))
 732
 733 ;;;;
 734
 735 (deftestsuite ensure-no-warning (lift-test)
 736   ())
 737
 738 (deftestsuite ensure-no-warning-helper ()
 739   ())
 740
 741 (addtest (ensure-no-warning-helper)
 742   test-1
 743   (ensure-no-warning (ensure-same (+ 2 2) 4)))
 744
 745 (addtest (ensure-no-warning-helper)
 746   test-2
 747   (ensure-no-warning (ensure-same (+ 2 2) 4)
 748                      (warn "I like math")))
 749
 750 (addtest (ensure-no-warning)
 751   run-tests
 752   (let ((result (run-tests :suite 'ensure-no-warning-helper
 753                            :report-pathname nil)))
 754     (ensure-same (length (tests-run result)) 2)
 755     (ensure-same (length (failures result)) 1)
 756     (ensure-same (length (errors result)) 0)))
 757
 758 ;;;;;
 759
 760 (deftestsuite test-suite-with-no-tests-helper ()
 761   ())
 762
 763 (deftestsuite test-test-suite-with-no-tests (lift-test)
 764   ()
 765   (:documentation "Case 168"))
 766
 767 (addtest (test-test-suite-with-no-tests)
 768   test-1
 769   (let ((r (run-tests :suite 'test-suite-with-no-tests-helper)))
 770     (ensure-same (length (tests-run r)) 0)))
 771
 772 ;;;;;
 773
 774
 775 (deftestsuite handle-serious-condition (lift-test)
 776   ()
 777   (:documentation
 778    "LIFT should keep running tests even when a testcase gets a
 779 serious condition. (though maybe there should be an option that
 780 these cancel testing instead.)")
 781   (:dynamic-variables
 782    (*test-break-on-errors?* nil)
 783    (*test-break-on-failures?* nil)))
 784
 785 (deftestsuite handle-serious-condition-helper ()
 786   ())
 787
 788 (addtest (handle-serious-condition-helper)
 789   test-1
 790   (signal 'serious-condition)
 791   #+(or)
 792   ;; I expect this to signal an error!
 793   (make-array (1- most-positive-fixnum)))
 794
 795 (addtest (handle-serious-condition)
 796   test-1
 797   (let ((got-condition nil))
 798     (handler-case
 799         (let ((tr (run-test :suite 'handle-serious-condition-helper
 800                             :name 'test-1)))
 801           (ensure-same (length (tests-run tr)) 1)
 802           (ensure-null (failures tr))
 803           (ensure (errors tr))
 804           (ensure-same (test-mode tr) :single))
 805       (condition (c)
 806         (setf got-condition c)))
 807     (ensure-null got-condition)))
 808
 809 ;;;;
 810
 811
 812 (deftestsuite test-interrupts (lift-test)
 813   ())
 814
 815 (deftestsuite test-interrupts-helper ()
 816   ())
 817
 818 (addtest (test-interrupts-helper)
 819   test-1
 820   (push :a *test-notepad*))
 821
 822 #+allegro
 823 (addtest (test-interrupts-helper)
 824   test-2
 825   (push :b *test-notepad*)
 826   (signal 'excl:interrupt-signal))
 827
 828 (addtest (test-interrupts-helper)
 829   test-3
 830   (push :c *test-notepad*))
 831
 832 #+allegro
 833 (addtest (test-interrupts)
 834   test-1
 835   (let ((*test-notepad* nil))
 836     (lift:run-tests :suite 'test-interrupts-helper)
 837     (ensure-same *test-notepad* '(:b :a) :test 'equal)))
 838
 839 #|
 840 ;;;;
 841
 842 (deftestsuite test-errors-in-equality-test (lift-test)
 843   ())
 844
 845 (deftestsuite test-errors-in-equality-test-helper ()
 846   ())
 847
 848 (addtest (test-errors-in-equality-test-helper
 849           :documentation "this is fun")
 850   test-1
 851   (ensure-same 1 1 :test (lambda (a b) (/ (- a b)))))
 852
 853 (addtest (test-errors-in-equality-test-helper
 854          )
 855   test-1
 856   (:documentation "this is fun")
 857   (ensure-same 1 1 :test (lambda (a b) (/ (- a b)))))
 858
 859
 860 (addtest (test-errors-in-equality-test)
 861   test-1
 862   (let ((*test-notepad* nil))
 863     (lift:run-tests :suite 'test-errors-in-equality-test-helper)
 864     (ensure-same *test-notepad* '(:b :a) :test 'equal)))
 865
 866
 867 (addtest (report-pathnamexx)
 868   initial-properties-are-null
 869   (ensure-null (lift::test-result-properties result))
 870 )
 871
 872 |#
 873
 874 (deftestsuite test-default-initargs-abstract (lift-test)
 875   ())
 876
 877 (deftestsuite test-default-initargs-parent (test-default-initargs-abstract)
 878   (a (b 1))
 879   (:default-initargs
 880       :a :parent
 881     :c :inherit))
 882
 883 (addtest (test-default-initargs-parent)
 884   no-initform
 885   (ensure-same a :parent))
 886
 887 (addtest (test-default-initargs-parent)
 888   with-initform
 889   (ensure-same b 1))
 890
 891 (deftestsuite test-default-initargs-child (test-default-initargs-parent)
 892   (c)
 893   (:default-initargs
 894       :a :child))
 895
 896 (addtest (test-default-initargs-child)
 897   no-initform-1
 898   (ensure-same a :child))
 899
 900 (addtest (test-default-initargs-child)
 901   no-initform-2
 902   (ensure-same c :inherit))
 903
 904 (defvar *test-default-initargs-helper-var* nil)
 905
 906 (deftestsuite test-default-initargs-helper ()
 907   (a)
 908   (:default-initargs
 909       :a 1))
 910
 911 (addtest (test-default-initargs-helper)
 912   test-1
 913   (ensure-same a *test-default-initargs-helper-var*))
 914
 915 (deftestsuite test-default-initargs (test-default-initargs-abstract)
 916   ())
 917
 918 (addtest (test-default-initargs)
 919   test-1
 920   (let* ((*test-default-initargs-helper-var* 1)
 921          (r (lift:run-tests :suite 'test-default-initargs-helper
 922                             :report-pathname nil)))
 923     (ensure-null (errors r))
 924     (ensure-null (failures r))))
 925
 926 (addtest (test-default-initargs)
 927   test-2
 928   (let* ((*test-default-initargs-helper-var* 2)
 929         (r (lift:run-tests :suite 'test-default-initargs-helper
 930                            :report-pathname nil
 931                            :testsuite-initargs '(:a 2))))
 932     (ensure-null (errors r))
 933     (ensure-null (failures r))))
 934
 935 ;;;;
 936
 937
 938 (deftestsuite test-dependencies (lift-test)
 939   ())
 940
 941 (deftestsuite test-dependencies-helper ()
 942   ()
 943   )
 944
 945 (addtest (test-dependencies-helper)
 946   test-a
 947   (push :a *test-notepad*))
 948
 949 (addtest (test-dependencies-helper)
 950   test-b
 951   (push :b *test-notepad*))
 952
 953 (addtest (test-dependencies-helper :depends-on 'test-b)
 954   test-c
 955   (push :c *test-notepad*))
 956
 957 (addtest (test-dependencies-helper :depends-on 'test-c)
 958   test-d
 959   (push :d *test-notepad*))
 960
 961 (addtest (test-dependencies)
 962   test-run-tests
 963   (setf *test-notepad* nil)
 964   (let ((r (lift:run-tests :suite 'test-dependencies-helper
 965                           :report-pathname nil)))
 966     (ensure (every (lambda (name)
 967                      (lift::test-case-tested-p
 968                       'test-dependencies-helper name :result r))
 969                    (list 'test-a 'test-b 'test-c 'test-d)))
 970     (ensure-same (length *test-notepad*) 4)
 971     (ensure-same *test-notepad* '(:a :b :c :d) :test 'set-equal)))
 972
 973 (addtest (test-dependencies)
 974   test-run-test-b
 975   (setf *test-notepad* nil)
 976   (let ((r (lift:run-test :suite 'test-dependencies-helper
 977                           :name 'test-b)))
 978     (ensure (every (lambda (name)
 979                      (lift::test-case-tested-p
 980                       'test-dependencies-helper name :result r))
 981                    (list 'test-b)))
 982     (ensure-same *test-notepad* '(:b) :test 'set-equal)))
 983
 984 (addtest (test-dependencies)
 985   test-run-test-c
 986   (setf *test-notepad* nil)
 987   (let ((r (lift:run-test :suite 'test-dependencies-helper
 988                           :name 'test-c)))
 989     (ensure (every (lambda (name)
 990                      (lift::test-case-tested-p
 991                       'test-dependencies-helper name :result r))
 992                    (list 'test-b 'test-c)))
 993     (ensure-same *test-notepad* '(:c :b) :test 'set-equal)))
 994
 995 (addtest (test-dependencies)
 996   test-run-test-d
 997   (setf *test-notepad* nil)
 998   (let ((r (lift:run-test :suite 'test-dependencies-helper
 999                           :name 'test-d)))
1000     (ensure-same (length *test-notepad*) 3)
1001     (ensure (every (lambda (name)
1002                      (lift::test-case-tested-p
1003                       'test-dependencies-helper name :result r))
1004                    (list 'test-b 'test-c 'test-d)))
1005     (ensure-same *test-notepad* '(:c :b :d) :test 'set-equal)))
1006
1007 ;;;;
1008
1009 #|
1010
1011 (deftestsuite lift-syntax-checks (lift-test)
1012   ()
1013   (:setup
1014    (eval '(deftestsuite test-xxx ()()))))
1015
1016 (addtest (lift-syntax-checks)
1017   options-are-plist-1
1018   (eval '(addtest (test-xxx :a 1 :b 2) test-1 (ensure t)))
1019   (ensure (find-test-case 'test-xxx 'test-1)))
1020
1021 (addtest (lift-syntax-checks)
1022   options-not-plist-1
1023   (eval '(addtest (test-xxx :a 1 :b 2 :c) test-1 (ensure t)))
1024   (ensure (find-test-case 'test-xxx 'test-1)))
1025
1026 (addtest (lift-syntax-checks)
1027   options-not-plist-2
1028   (eval '(addtest (test-xxx :b) test-1 (ensure t)))
1029   (ensure (find-test-case 'test-xxx 'test-1)))
1030
1031 (addtest (lift-syntax-checks)
1032   options-not-plist-3
1033   (eval '(addtest (test-xxx :b 2 :c 3 4 5) test-1 (ensure t)))
1034   (ensure (find-test-case 'test-xxx 'test-1)))
1035
1036 |#
1037
1038 ;;;;
1039
1040 #|
1041 (deftestsuite this-testsuite-fails (lift-test)
1042   ())
1043
1044 (addtest (this-testsuite-fails)
1045   test-1
1046   (ensure-same (+ 2 2) 3))
1047
1048 (deftestsuite this-testsuite-errors (lift-test)
1049   ())
1050
1051 (addtest (this-testsuite-errors)
1052   test-1
1053   (let ((x 0))
1054     (ensure (/ (* (+ 2 2) 3) x))))
1055
1056 (deftestsuite this-testsuite-is-generally-bad (lift-test)
1057   ()
1058   (:documentation "And that's OK."))
1059
1060 (addtest (this-testsuite-is-generally-bad :documentation "What happens here")
1061   test-1
1062 ;  (:documentation "What happens here")
1063   (let ((x 0))
1064     (ensure (/ (* (+ 2 2) 3) x))))
1065
1066 (addtest (this-testsuite-is-generally-bad)
1067   test-2
1068   (ensure-same (+ 2 2) 3))
1069
1070 (deftestsuite this-testsuite-cannot-be-made (lift-test)
1071   ((x (error "dang")))
1072   (:documentation "And that's the way we like it."))
1073
1074 (addtest (this-testsuite-cannot-be-made :documentation "What happens to this?")
1075   test-1
1076   (ensure-same 1 1))
1077
1078 (deftestsuite test-conditions (lift-test)
1079   ())
1080
1081 (addtest (test-conditions)
1082   test-1
1083   (signal 'excl:socket-chunking-end-of-file)
1084   (ensure-same 1 1))
1085
1086 |#
1087
1088 (defun slurp (pathname)
1089   (when (probe-file pathname)
1090     (with-open-file (s pathname :direction :input)
1091       (loop for line = (read-line s nil :eof)
1092          until (eq line :eof) collect line))))
1093
1094 (deftestsuite test-log-file (lift-test)
1095   (my-log-file)
1096   (:setup
1097    (setf my-log-file (format nil "/tmp/~a" (gensym "file-")))
1098    (when (probe-file my-log-file)
1099      (delete-file my-log-file))))
1100
1101 (deftestsuite test-log-file-helper ()
1102   (my-log-file))
1103
1104 (addtest (test-log-file-helper)
1105   test-1
1106   (let ((lines (slurp my-log-file)))
1107     (ensure (plusp (length lines)))
1108     (let* ((last-line (first (last lines)))
1109            (datum (read-from-string last-line nil nil)))
1110       (ensure datum)
1111       (ensure (consp datum))
1112       (ensure-same (car datum) :start-time-universal))))
1113
1114 (addtest (test-log-file)
1115   test-1
1116   (let ((r (lift:run-tests
1117             :suite 'test-log-file-helper
1118             :report-pathname my-log-file
1119             :testsuite-initargs `(:log-file ,my-log-file))))
1120     (ensure-null (errors r))
1121     (ensure-null (failures r))
1122     (ensure (plusp (length (tests-run r))))))