external/lift/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 (in-package #:lift-test)
  20
  21 (deftestsuite lift-test () ())
  22
  23 ;;; ---------------------------------------------------------------------------
  24 ;;; lift-test-ensure
  25 ;;; make sure that ensure and its friends work as expected
  26 ;;;
  27 ;;; The strategy here is to pair "regular" tests with meta-tests. The
  28 ;;; regular tests are normal tests written using LIFT. The meta-tests
  29 ;;; use run-tests or run-tests to run the regular test and then grovel
  30 ;;; over the returned test-result to make sure it contains what it is
  31 ;;; supposed to.
  32 ;;; ---------------------------------------------------------------------------
  33
  34 (deftestsuite lift-test-ensure (lift-test) ())
  35 (deftestsuite lift-test-ensure-helper () ())
  36
  37 (addtest (lift-test-ensure-helper)
  38   simple-ensure-test-1
  39   (ensure t))
  40
  41 (addtest (lift-test-ensure)
  42   simple-ensure-test-1
  43   (let ((tr (run-test :suite 'lift-test-ensure-helper
  44                       :name 'simple-ensure-test-1)))
  45     (ensure-same (length (tests-run tr)) 1)
  46     (ensure-same (failures tr) nil)
  47     (ensure-same (errors tr) nil)
  48     (ensure-same (test-mode tr) :single)
  49 ;    (ensure-same (test-interactive? tr) nil)
  50     (ensure-same (mapcar #'first (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-same (errors tr) nil :report "Number of errors")
  66     (ensure-same (mapcar #'first (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 #'first (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-2
 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 (deftestsuite lift-test-environment-pristine-helper ()
 279   ((a 2)
 280    (b (* a a))))
 281
 282 (addtest (lift-test-environment-pristine-helper)
 283   do-it
 284   (ensure-same (* a a) b))
 285
 286 (addtest (lift-test-environment-pristine)
 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                '(:dynamics :slot :setup :test)))
 334