dev/test-runner.lisp

   1 (in-package #:lift)
   2
   3 (defvar *in-middle-of-failure?* t)
   4
   5 (defun run-test (&key
   6                  (name *last-test-case-name*)
   7                  (suite *last-testsuite-name*)
   8                  (break-on-errors? *test-break-on-errors?*)
   9                  (break-on-failures? *test-break-on-failures?*)
  10                  (result nil)
  11                  (profile *profile-style* profile-supplied?)
  12                  (testsuite-initargs nil))
  13   "Run a single test-case in a testsuite. Will run the most recently
  14 defined or run testcase unless the name and suite arguments are used
  15 to override them."
  16   (assert suite nil "Test suite could not be determined.")
  17   (assert name nil "Test-case could not be determined.")
  18   (when profile-supplied?
  19     (push profile testsuite-initargs)
  20     (push :profile testsuite-initargs))
  21   (let* ((*test-break-on-errors?* break-on-errors?)
  22          (*test-break-on-failures?* break-on-failures?))
  23     (unless result
  24       (setf result (make-test-result
  25                     suite :single :testsuite-initargs testsuite-initargs)))
  26     (prog1
  27         (let ((*current-test-case-name* (find-test-case suite name :errorp t))
  28               (*test-result* result))
  29           (do-testing-in-environment
  30               suite result
  31               (lambda ()
  32                 (run-test-internal *current-test* *current-test-case-name* result))))
  33       (setf *test-result* result)
  34       (setf *last-test-case-name* (find-test-case suite name)
  35             *last-testsuite-name* suite))))
  36
  37 (defun do-testing-in-environment (suite-name result fn)
  38   (let ((suite nil)
  39         (*current-testsuite-name* suite-name))
  40     (catch :test-end
  41       (tagbody
  42        :test-start
  43          (restart-case
  44              (handler-bind ((warning #'muffle-warning)
  45                                         ; ignore warnings...
  46                             #+(and allegro)
  47                             (excl:interrupt-signal
  48                              (lambda (_)
  49                                (declare (ignore _))
  50                                (cancel-testing :interrupt)))
  51                             (error
  52                              (lambda (condition)
  53                                (handle-error-while-testing
  54                                 condition 'testsuite-error suite-name result)
  55                                (go :test-end)))
  56                             (serious-condition
  57                              (lambda (condition)
  58                                (handle-error-while-testing
  59                                 condition 'testsuite-serious-condition
  60                                 suite-name result)
  61                                (go :test-end))))
  62                (setf (current-step result) :create)
  63                (setf suite (make-testsuite
  64                             suite-name (testsuite-initargs result)))
  65                (let ((*current-test* suite))
  66                  (unwind-protect
  67                       (let ((*lift-equality-test* (equality-test suite)))
  68                         (%start-test-suite (type-of suite) result)
  69                         (testsuite-setup suite result)
  70                         (do-testing suite result fn)
  71                         result)
  72                    ;; cleanup
  73                    (testsuite-teardown suite result))))
  74            (ensure-failed (condition)
  75              :test (lambda (c) (declare (ignore c)) *in-middle-of-failure?*)
  76              (report-test-problem
  77               'testsuite-failure result suite-name
  78               *current-test-case-name* condition))
  79            (retry-test-suite ()
  80              :report (lambda (s) (format s "Re-run test-suite ~a"
  81                                          *current-testsuite-name*))
  82              (go :test-start))
  83            (skip-test-suite ()
  84              :report (lambda (s) (format s "Skip rest of test-suite ~a"
  85                              *current-testsuite-name*))
  86              (go :test-end)))
  87        :test-end)))
  88   (values result))
  89
  90 (defmethod do-testing ((suite test-mixin) result fn)
  91   (funcall fn)
  92   result)
  93
  94 (defun run-tests (&rest args &key
  95                   (suite nil)
  96                   (break-on-errors? *test-break-on-errors?*)
  97                   (break-on-failures? *test-break-on-failures?*)
  98                   (config nil)
  99                   (dribble *lift-dribble-pathname*)
 100                   (report-pathname *lift-report-pathname*)
 101                   (profile *profile-style* profile-supplied?)
 102                   (skip-tests *skip-tests*)
 103                   ;(timeout nil)
 104                   (do-children? *test-run-subsuites?*)
 105                   (testsuite-initargs nil)
 106                   result
 107                   &allow-other-keys)
 108   "Run all of the tests in a suite."
 109   (prog1
 110       (let ((args-copy (copy-list args)))
 111         (remf args :suite)
 112         (remf args :break-on-errors?)
 113         (remf args :break-on-failures?)
 114         (remf args :run-setup)
 115         (remf args :dribble)
 116         (remf args :config)
 117         (remf args :skip-tests)
 118         (remf args :report-pathname)
 119         (remf args :do-children?)
 120         (remf args :testsuite-initargs)
 121         (remf args :profile)
 122         (when profile-supplied?
 123           (push profile testsuite-initargs)
 124           (push :profile testsuite-initargs))
 125         (let* ((*lift-report-pathname*
 126                 (cond ((null report-pathname) nil)
 127                       ((eq report-pathname t)
 128                        (report-summary-pathname))
 129                       (t
 130                        report-pathname)))
 131                (*test-run-subsuites?* do-children?)
 132                (*skip-tests* (canonize-skip-tests skip-tests))
 133                (*print-readably* nil)
 134                (report-pathname *lift-report-pathname*))
 135           (when report-pathname
 136             (ensure-directories-exist report-pathname))
 137           (cond ((and suite config)
 138                  (error "Specify either configuration file or test suite
 139 but not both."))
 140                 (config
 141                  (unless result
 142                    (setf result
 143                          (apply #'make-test-result config :multiple
 144                                 :testsuite-initargs testsuite-initargs
 145                                 args)))
 146                  (when report-pathname
 147                    (write-log-header report-pathname result args-copy))
 148                  (let* ((*test-result* result))
 149                    (setf result (run-tests-from-file config))))
 150                 ((or suite (setf suite *last-testsuite-name*))
 151                  (unless result
 152                    (setf result
 153                          (apply #'make-test-result suite
 154                                 :multiple :testsuite-initargs testsuite-initargs
 155                                 args)))
 156                  (setf (testsuite-initargs result) testsuite-initargs)
 157                  (when report-pathname
 158                    (write-log-header report-pathname result args-copy))
 159                  (let* ((*test-break-on-errors?* break-on-errors?)
 160                         (*test-break-on-failures?* break-on-failures?)
 161                         (*test-result* result)
 162                         (dribble-stream
 163                          (when dribble
 164                            (open dribble
 165                                  :direction :output
 166                                  :if-does-not-exist :create
 167                                  :if-exists *lift-if-dribble-exists*)))
 168                         (*lift-standard-output*
 169                          (maybe-add-dribble
 170                           *lift-standard-output* dribble-stream))
 171                         (*standard-output* *lift-standard-output*)
 172                         (*error-output* (maybe-add-dribble
 173                                          *error-output* dribble-stream))
 174                         (*debug-io* (maybe-add-dribble
 175                                      *debug-io* dribble-stream))
 176                         (*lift-debug-output* (maybe-add-dribble
 177                                               *lift-debug-output* dribble-stream)))
 178                    (unwind-protect
 179                         (restart-case
 180                             (run-tests-internal suite result)
 181                            (cancel-testing (&optional (result *test-result*))
 182                              :report (lambda (stream)
 183                                        (format stream "Cancel testing of ~a"
 184                                                *current-testsuite-name*))
 185                              (declare (ignore result))
 186                              (values nil t)))
 187                      ;; cleanup
 188                      (when dribble-stream
 189                        (close dribble-stream)))
 190                    ;; FIXME -- ugh!
 191                    (setf (tests-run result) (reverse (tests-run result)))
 192                    (when report-pathname
 193                      (write-log-footer report-pathname result))
 194                    (values result)))
 195                 (t
 196                  (error "There is not a current test suite and neither suite
 197 nor configuration file options were specified.")))))
 198         (setf *test-result* result)))
 199
 200 (defun run-tests-internal (suite-name result)
 201   (dolist (suite-name (if *test-run-subsuites?*
 202                           (collect-testsuites suite-name)
 203                           (list suite-name)))
 204     (do-testing-in-environment
 205         suite-name result
 206         (lambda ()
 207           (testsuite-run *current-test* result)))
 208     (setf *test-result* result)))
 209
 210 (defun testsuite-run (testsuite result)
 211   "Run the cases in `testsuite`"
 212   (let* ((methods (testsuite-methods testsuite))
 213          (suite-name (class-name (class-of testsuite)))
 214          (*current-testsuite-name* suite-name)
 215          data)
 216     (cond ((skip-test-suite-children-p result suite-name)
 217            (skip-testsuite result suite-name))
 218           (t
 219            (unless (start-time result)
 220              (setf (start-time result) (get-test-real-time)
 221                    (start-time-universal result) (get-universal-time)))
 222            (unwind-protect
 223                 (loop for method in methods do
 224                      (unwind-protect
 225                           (progn
 226                             (write-log-test-start :save suite-name method
 227                                                   :stream *lift-report-pathname*)
 228                             (setf data
 229                                   (if (skip-test-case-p result suite-name method)
 230                                       `(:problem ,(skip-test-case
 231                                                    result suite-name method))
 232                                       (run-test-internal testsuite method result))))
 233                        (when *lift-report-pathname*
 234                          (write-log-test-end
 235                           :save suite-name method data
 236                           :stream *lift-report-pathname*))))
 237              (setf (end-time result) (get-universal-time)))))
 238     (setf *last-testsuite-name* suite-name)))
 239
 240 (defmethod do-test ((suite test-mixin) name result)
 241   (declare (ignore result))
 242   (let* ((suite-name (class-name (class-of suite)))
 243          (fn (gethash name (test-name->methods suite-name))))
 244     (if fn
 245         (funcall fn suite)
 246         (error "expected to find ~a test for ~a but didn't" name suite-name))))
 247
 248 (defun run-test-internal (suite test-case-name result)
 249   (let* ((result-pushed? nil)
 250          (suite-name (class-name (class-of suite)))
 251          (*current-test-case-name* test-case-name)
 252          (*current-testsuite-name* suite-name)
 253          (error nil)
 254          (current-condition nil))
 255     (set-test-case-options suite-name test-case-name)
 256     (loop for case in (ensure-list
 257                        (test-case-option suite-name test-case-name :depends-on))
 258        unless (test-case-tested-p suite-name case) do
 259        (run-test-internal suite case result))
 260     (flet ((maybe-push-result ()
 261              (let ((datum (list suite-name test-case-name (test-data suite))))
 262                (cond ((null result-pushed?)
 263                       (setf result-pushed? t)
 264                       (push datum (tests-run result)))
 265                      (t
 266                       ;; replace
 267                       (setf (first (tests-run result)) datum))))))
 268       (%start-test-case test-case-name result)
 269       (tagbody
 270        :test-start
 271          (restart-case
 272              (handler-bind ((warning #'muffle-warning)
 273                                         ; ignore warnings...
 274                             #+(and allegro)
 275                             (excl:interrupt-signal
 276                              (lambda (_)
 277                                (declare (ignore _))
 278                                (cancel-testing :interrupt)))
 279                             (error
 280                              (lambda (condition)
 281                                (handle-error-while-testing
 282                                 condition 'test-error suite-name result)
 283                                (go :test-end)))
 284                             (serious-condition
 285                              (lambda (condition)
 286                                (handle-error-while-testing
 287                                 condition 'test-serious-condition
 288                                 suite-name result)
 289                                (go :test-end))))
 290                (restart-case
 291                    (progn
 292                      (setf (current-method suite) test-case-name)
 293                      (record-start-times result suite)
 294                      (unwind-protect
 295                           (progn
 296                             (setup-test suite)
 297                             (setf (current-step result) :testing)
 298                             (multiple-value-bind (result measures error-condition)
 299                                 (while-measuring (t measure-space measure-seconds)
 300                                                  (do-test suite test-case-name result))
 301                               (declare (ignore result))
 302                               (setf error error-condition)
 303                               (destructuring-bind (space seconds) measures
 304                                 (setf (getf (test-data suite) :seconds) seconds
 305                                       (getf (test-data suite) :conses) space)))
 306                             (when error
 307                               (error error))
 308                             (check-for-surprises suite-name test-case-name))
 309                        ;; cleanup
 310                        (maybe-push-result)
 311                        (when (run-teardown-p suite :test-case)
 312                          (test-case-teardown suite result))
 313                        (record-end-times result suite))
 314                      (go :test-end))
 315                  (ensure-failed (condition)
 316                    :test (lambda (c) (declare (ignore c))
 317                                  *in-middle-of-failure?*)
 318                    (report-test-problem
 319                     'test-failure result suite-name
 320                     *current-test-case-name* condition)
 321                    (setf current-condition condition)
 322                    (if (and *test-break-on-failures?*
 323                             (not (failure-okay-p suite-name test-case-name)))
 324                        (let ((*in-middle-of-failure?* nil))
 325                          (invoke-debugger current-condition))
 326                        (go :test-end))
 327                    (go :test-failed))))
 328            (skip-test-case ()
 329              :report (lambda (s) (format s "Skip test-case ~a"
 330                                          *current-test-case-name*))
 331              (go :test-end))
 332            (test-failed (condition)
 333              :test (lambda (c) (declare (ignore c))
 334                            *in-middle-of-failure?*)
 335              (setf current-condition condition)
 336              (go :test-failed))
 337            (retry-test ()
 338              :report (lambda (s) (format s "Re-run test-case ~a"
 339                                          *current-test-case-name*))
 340              (go :test-start)))
 341        :test-failed
 342        :test-end)
 343       (maybe-push-result)))
 344   (when *test-print-test-case-names*
 345     (when (not (eq *test-print-test-case-names* :brief))
 346       (format *lift-debug-output* "~40T"))
 347     (print-lift-message "~a"
 348                         (result-summary-tag (getf (test-data suite) :problem)
 349                                             *test-print-test-case-names*)))
 350   (setf *current-test-case-name* test-case-name)
 351   (setf *test-result* result)
 352   (third (first (tests-run result))))
 353
 354 (defun handle-error-while-testing (condition error-class suite-name result)
 355   (let ((*in-middle-of-failure?* nil))
 356     (report-test-problem
 357      error-class result suite-name
 358      *current-test-case-name* condition
 359      :backtrace (get-backtrace condition))
 360     (when (and *test-break-on-errors?*
 361                (not (error-okay-p *current-testsuite-name* *current-test-case-name*)))
 362       (invoke-debugger condition))))
 363
 364 (defun maybe-add-dribble (stream dribble-stream)
 365   (if dribble-stream
 366       (values (make-broadcast-stream stream dribble-stream) t)
 367       (values stream nil)))
 368