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

   1 ;;;-*- Mode: Lisp; Package: LIFT -*-
   2
   3 #|
   4
   5 See file COPYING for license
   6
   7 |#
   8
   9 (defpackage #:lift-test
  10   (:use #:common-lisp #:lift)
  11   (:import-from #:lift
  12                 #:failures
  13                 #:errors
  14                 #:tests-run
  15                 #:test-mode
  16                 #:test-interactive?
  17                 #:make-test-result
  18                 #:testsuite-test-count
  19                 #:*test-environment*))
  20 (in-package #:lift-test)
  21
  22 (deftestsuite lift-test () ())
  23
  24 ;;; ---------------------------------------------------------------------------
  25 ;;; lift-test-ensure
  26 ;;; make sure that ensure and its friends work as expected
  27 ;;;
  28 ;;; The strategy here is to pair "regular" tests with meta-tests. The
  29 ;;; regular tests are normal tests written using LIFT. The meta-tests
  30 ;;; use run-tests or run-tests to run the regular test and then grovel
  31 ;;; over the returned test-result to make sure it contains what it is
  32 ;;; supposed to.
  33 ;;; ---------------------------------------------------------------------------
  34
  35 (deftestsuite lift-test-ensure (lift-test) ())
  36 (deftestsuite lift-test-ensure-helper () ())
  37
  38 (addtest (lift-test-ensure-helper)
  39   simple-ensure-test-1
  40   (ensure t))
  41
  42 (addtest (lift-test-ensure)
  43   simple-ensure-test-1
  44   (let ((tr (run-test :suite 'lift-test-ensure-helper
  45                       :name 'simple-ensure-test-1)))
  46     (ensure-same (length (tests-run tr)) 1)
  47     (ensure-null (failures tr))
  48     (ensure-null (errors tr))
  49     (ensure-same (test-mode tr) :single)
  50     (ensure-same (mapcar #'second (tests-run tr))
  51                  '(lift-test::simple-ensure-test-1))))
  52
  53 ;;; ---------------------------------------------------------------------------
  54
  55 (addtest (lift-test-ensure-helper)
  56   simple-ensure-test-2
  57   (ensure nil))
  58
  59 (addtest (lift-test-ensure)
  60   simple-ensure-test-2
  61   (let ((tr (run-test :suite 'lift-test-ensure-helper
  62                       :name 'simple-ensure-test-2)))
  63     (ensure-same (length (tests-run tr)) 1 :report "Number of tests-run")
  64     (ensure-same (length (failures tr)) 1 :report "Number of failures")
  65     (ensure-null (errors tr) :report "Number of errors")
  66     (ensure-same (mapcar #'second (tests-run tr))
  67                  '(lift-test::simple-ensure-test-2))))
  68
  69 ;;; ---------------------------------------------------------------------------
  70
  71 (addtest (lift-test-ensure-helper)
  72   simple-ensure-test-3
  73   (ensure (let ((x 0)) (/ x))))
  74
  75 (addtest (lift-test-ensure)
  76   simple-ensure-test-3
  77   (let ((tr (run-test :suite 'lift-test-ensure-helper
  78                       :name 'simple-ensure-test-3)))
  79     (ensure-same (length (tests-run tr)) 1)
  80     (ensure-same (length (failures tr)) 0)
  81     (ensure-same (length (errors tr)) 1)
  82     (ensure-same (mapcar #'second (tests-run tr))
  83                  '(lift-test::simple-ensure-test-3))))
  84
  85
  86 ;;; ---------------------------------------------------------------------------
  87 ;;; lift-test-setup-teardown
  88 ;;; make sure that setup and teardown happen in the right order
  89 ;;; ---------------------------------------------------------------------------
  90
  91 (deftestsuite lift-test-setup-teardown (lift-test) ())
  92
  93 (deftestsuite lift-test-setup-teardown-1 (lift-test-setup-teardown) ()
  94   (:setup (push 1 *test-notepad*))
  95   (:teardown (push :a *test-notepad*))
  96   (:tests (setup-teardown-1 (push 'test-1 *test-notepad*))))
  97
  98 (addtest (lift-test-setup-teardown)
  99   setup-teardown-1
 100   (setf *test-notepad* nil)
 101   (run-test
 102    :name 'setup-teardown-1
 103    :suite 'lift-test-setup-teardown-1
 104    :result (make-test-result 'lift-test-setup-teardown-1 :single))
 105   (ensure-same (reverse *test-notepad*)
 106                '(1 test-1 :a)))
 107
 108 (addtest (lift-test-setup-teardown)
 109   setup-teardown-1-all
 110   (setf *test-notepad* nil)
 111   (run-tests
 112    :suite 'lift-test-setup-teardown-1
 113    :result (make-test-result 'lift-test-setup-teardown-1 :multiple))
 114   (ensure-same (reverse *test-notepad*)
 115                '(1 test-1 :a 1 2 test-2 :b :a 1 2 3 test-3 :c :b :a)))
 116
 117 (deftestsuite lift-test-setup-teardown-2 (lift-test-setup-teardown-1) ()
 118   (:setup (push 2 *test-notepad*))
 119   (:teardown (push :b *test-notepad*))
 120   (:tests (setup-teardown-2 (push 'test-2 *test-notepad*))))
 121
 122 (deftestsuite lift-test-setup-teardown-3 (lift-test-setup-teardown-2) ()
 123   (:setup (push 3 *test-notepad*))
 124   (:teardown (push :c *test-notepad*))
 125   (:tests (setup-teardown-3 (push 'test-3 *test-notepad*))))
 126
 127 (addtest (lift-test-setup-teardown)
 128   setup-teardown-3
 129   (setf *test-notepad* nil)
 130   (run-test
 131    :name 'setup-teardown-3
 132    :suite 'lift-test-setup-teardown-3
 133    :result (make-test-result 'lift-test-setup-teardown-3 :single))
 134   (ensure-same (reverse *test-notepad*)
 135                '(1 2 3 test-3 :c :b :a)))
 136
 137 (addtest (lift-test-setup-teardown)
 138   setup-teardown-3-all
 139   (setf *test-notepad* nil)
 140   (run-tests
 141    :suite 'lift-test-setup-teardown-3
 142    :result (make-test-result 'lift-test-setup-teardown-3 :multiple))
 143   (ensure-same (reverse *test-notepad*)
 144                '(1 2 3 test-3 :c :b :a)))
 145
 146 ;;; ---------------------------------------------------------------------------
 147 ;;; test ensure same
 148 ;;; ---------------------------------------------------------------------------
 149
 150 (deftestsuite lift-test-ensure-same (lift-test)
 151   ())
 152
 153 ;;?? Gary King 2004-06-21: not really a test yet, more of a syntax works check
 154 (addtest (lift-test-ensure-same)
 155   (ensure-same 2 2 :test =)
 156   (ensure-same 2 2 :test '=)
 157   (ensure-same 2 2 :test #'=))
 158
 159 ;;; ---------------------------------------------------------------------------
 160 ;;; test single setup
 161 ;;; ---------------------------------------------------------------------------
 162
 163 (deftestsuite test-single-setup (lift-test) ())
 164
 165 ;; helpers
 166 (deftestsuite test-single-setup-helper () ())
 167
 168 (deftestsuite test-single-setup-child-a (test-single-setup-helper) ()
 169   (:setup (push :a *test-notepad*))
 170   (:test (test-1 (ensure t))))
 171
 172 (deftestsuite test-single-setup-child-a-1 (test-single-setup-child-a) ()
 173   (:setup (push :a-1 *test-notepad*))
 174   (:test (test-1 (ensure t)))
 175   (:test (test-2 (ensure t))))
 176
 177 (deftestsuite test-single-setup-child-b (test-single-setup-helper) ()
 178   (:setup (push :b *test-notepad*))
 179   (:test (test-1 (ensure t))))
 180
 181 (deftestsuite test-single-setup-child-b-1-ss (test-single-setup-child-b) ()
 182   (:run-setup :once-per-suite)
 183   (:setup (push :b-1 *test-notepad*))
 184   (:test (test-1 (ensure t)))
 185   (:test (test-2 (ensure t))))
 186
 187 (deftestsuite test-single-setup-child-b-1-a (test-single-setup-child-b-1-ss) ()
 188   (:setup (push :b-1-a *test-notepad*))
 189   (:test (test-1 (ensure t)))
 190   (:test (test-2 (ensure t))))
 191
 192 (deftestsuite test-single-setup-child-b-1-b (test-single-setup-child-b-1-ss) ()
 193   (:setup (push :b-1-b *test-notepad*))
 194   (:test (test-1 (ensure t)))
 195   (:test (test-2 (ensure t))))
 196
 197 (deftestsuite test-single-setup-child-c (test-single-setup-helper) ()
 198   (:setup (push :c *test-notepad*))
 199   (:test (test-1 (ensure t))))
 200
 201 (deftestsuite test-single-setup-child-c-1 (test-single-setup-child-c) ()
 202   (:setup (push :c-1 *test-notepad*))
 203   (:test (test-1 (ensure t))))
 204
 205 ;;; ---------------------------------------------------------------------------
 206
 207 (addtest (test-single-setup)
 208   test-a-multiple-setup
 209   (setf *test-notepad* nil)
 210   (run-test :suite 'test-single-setup-child-a-1 :name 'test-1)
 211   (run-test :suite 'test-single-setup-child-a-1 :name 'test-2)
 212   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 213
 214 (addtest (test-single-setup)
 215   test-b-single-setup-1
 216   (setf *test-notepad* nil)
 217   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-1)
 218   (run-test :suite 'test-single-setup-child-b-1-ss :name 'test-2)
 219   ;; single tests do all the setup so this should be exactly the same
 220   (ensure-same *test-notepad* '(:b-1 :b :b-1 :b)))
 221
 222 (addtest (test-single-setup)
 223   test-a-single-setup-2
 224   (setf *test-notepad* nil)
 225   (run-tests :suite 'test-single-setup-child-a-1 :do-children? nil)
 226   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 227
 228 (addtest (test-single-setup)
 229   test-a-single-setup-3
 230   (setf *test-notepad* nil)
 231   (run-tests :suite 'test-single-setup-child-a-1
 232              :run-setup :once-per-suite
 233              :do-children? nil)
 234   (ensure-same *test-notepad* '(:a-1 :a :a-1 :a)))
 235
 236 (addtest (test-single-setup)
 237   test-b-single-setup-2
 238   (setf *test-notepad* nil)
 239   (run-tests :suite 'test-single-setup-child-b-1-ss :do-children? nil)
 240   (ensure-same *test-notepad* '(:b-1 :b)))
 241
 242 ;;; ---------------------------------------------------------------------------
 243 ;;; warning behavior
 244 ;;; ---------------------------------------------------------------------------
 245
 246 (deftestsuite test-ignore-warnings (lift-test) ())
 247
 248 (deftestsuite test-ignore-warnings-helper () ())
 249
 250 (deftestsuite test-ignore-warnings-helper-warning (test-ignore-warnings-helper) ()
 251   (:test (do-it
 252           (push :a *test-scratchpad*)
 253           (warn "Ouch")
 254           (push :b *test-scratchpad*))))
 255
 256 (deftestsuite test-ignore-warnings-helper-no-warning (test-ignore-warnings-helper) ()
 257   (:test (do-it
 258           (push :a *test-scratchpad*)
 259           (+ 2 2)
 260           (push :b *test-scratchpad*))))
 261
 262 (addtest (test-ignore-warnings)
 263   test-has-warning
 264   (run-test :suite 'test-ignore-warnings-helper-warning :name 'do-it)
 265   (ensure-same *test-scratchpad* '(:b :a)))
 266
 267 (addtest (test-ignore-warnings)
 268   test-has-no-warning
 269   (run-test :suite 'test-ignore-warnings-helper-no-warning :name 'do-it)
 270   (ensure-same *test-scratchpad* '(:b :a)))
 271
 272 ;;; ---------------------------------------------------------------------------
 273 ;;; test-environment stays clean
 274 ;;; ---------------------------------------------------------------------------
 275
 276 (deftestsuite lift-test-environment-pristine (lift-test) ()
 277   (:setup (setf *test-environment* nil)))
 278
 279 (deftestsuite lift-test-environment-pristine-helper ()
 280   ((a 2)
 281    (b (* a a))))
 282
 283 (addtest (lift-test-environment-pristine-helper)
 284   do-it
 285   (ensure-same (* a a) b))
 286
 287 (addtest (lift-test-environment-pristine
 288           :expected-failure "This is no longer guarenteed; I'm not sure yet whether or not this is a good thing.")
 289   test-1
 290   (run-test :suite 'lift-test-environment-pristine-helper :name 'do-it)
 291   (ensure (null *test-environment*)))
 292
 293
 294 ;;; ---------------------------------------------------------------------------
 295 ;;; test-creating-multiple-tests
 296 ;;; ---------------------------------------------------------------------------
 297
 298 (deftestsuite test-creating-multiple-tests (lift-test)
 299   ())
 300
 301 (deftestsuite test-creating-multiple-tests-helper ()
 302  ()
 303  (:tests ((ensure-same 1 1)
 304           (ensure-same 2 2))
 305          ((ensure-same 3 3))))
 306
 307 (addtest (test-creating-multiple-tests)
 308   test-1
 309   (ensure-same (testsuite-test-count 'test-creating-multiple-tests-helper) 2))
 310
 311 ;;;;;
 312
 313 (defvar *dynamics-before-setup* :dbs)
 314
 315 (deftestsuite dynamics-before-setup (lift-test)
 316   ()
 317   :setup (setf *test-notepad* nil))
 318
 319 (deftestsuite dynamics-before-setup-helper ()
 320   ((slot (progn (push :slot *test-notepad*) :slot)))
 321   :dynamic-variables (*dynamics-before-setup*
 322                       (progn (push :dynamics *test-notepad*) :dynamics))
 323   :setup (push :setup *test-notepad*))
 324
 325 (addtest (dynamics-before-setup-helper)
 326   test-1
 327   (push :test *test-notepad*)
 328   (ensure-same *dynamics-before-setup* :dynamics))
 329
 330 (addtest (dynamics-before-setup)
 331   test-1
 332   (run-test :suite 'dynamics-before-setup-helper
 333             :name 'test-1)
 334   (ensure-same (reverse *test-notepad*)
 335                '(:dynamics :slot :setup :test)))
 336
 337
 338 ;;;;;
 339 ;;; inherited functions
 340
 341 (deftestsuite test-inherited-functions-helper ()
 342   ()
 343   (:function
 344    (really? (a b c)
 345             (ensure-same (+ a b) c :test '=))))
 346
 347 (deftestsuite test-inherited-functions-pos (test-inherited-functions-helper)
 348   ()
 349   (:tests ((really? 1 2 3))
 350           ((really? 4 5 9))))
 351
 352 (deftestsuite test-inherited-functions-neg (test-inherited-functions-helper)
 353   ()
 354   (:tests ((really? -4 -2 -6))
 355           ((really? -1 -1 -2))))
 356
 357 (deftestsuite test-inherited-functions (lift-test)
 358   ())
 359
 360 (addtest (test-inherited-functions)
 361   one
 362   (let ((tr (run-tests :suite 'test-inherited-functions-helper)))
 363     (ensure-same (length (tests-run tr)) 4)
 364     (ensure-null (failures tr))
 365     (ensure-null (errors tr))))
 366
 367
 368 ;;;;;
 369 ;;; slot initialization takes place with every setup
 370
 371 (deftestsuite test-initialize-slots-helper ()
 372   ((slot (incf *test-notepad*))))
 373
 374 (addtest (test-initialize-slots-helper)
 375   one
 376   (ensure t))
 377
 378 (addtest (test-initialize-slots-helper)
 379   two
 380   (ensure-null nil))
 381
 382 (deftestsuite test-initialize-slots (lift-test)
 383   ()
 384   (:setup (setf *test-notepad* 0)))
 385
 386 (addtest (test-initialize-slots)
 387   slot-initform-evaluated-every-time
 388   (let ((tr (run-tests :suite 'test-initialize-slots-helper)))
 389     (ensure-same (length (tests-run tr)) 2)
 390     (ensure-same *test-notepad* 2 :test '=)))