tests/run-tests.lisp

   1 #+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
   2 (require :asdf)
   3
   4 #+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
   5 (handler-bind (#+win32 (warning #'muffle-warning))
   6   (require :sb-posix))
   7
   8 (load "test-util.lisp")
   9
  10 (defpackage :run-tests
  11     (:use :cl :test-util :sb-ext))
  12
  13 (load "assertoid.lisp")
  14
  15 (in-package run-tests)
  16
  17 (load "colorize.lisp")
  18
  19 (defvar *all-failures* nil)
  20 (defvar *break-on-error* nil)
  21 (defvar *report-skipped-tests* nil)
  22 (defvar *accept-files* nil)
  23
  24 (defun run-all ()
  25   (dolist (arg (cdr *posix-argv*))
  26     (cond ((string= arg "--break-on-failure")
  27            (setf *break-on-error* t)
  28            (setf test-util:*break-on-failure* t))
  29           ((string= arg "--break-on-expected-failure")
  30            (setf test-util:*break-on-expected-failure* t))
  31           ((string= arg "--report-skipped-tests")
  32            (setf *report-skipped-tests* t))
  33           ((string= arg "--no-color"))
  34           (t
  35            (push (truename (parse-namestring arg)) *accept-files*))))
  36   (pure-runner (pure-load-files) #'load-test)
  37   (pure-runner (pure-cload-files) #'cload-test)
  38   (impure-runner (impure-load-files) #'load-test)
  39   (impure-runner (impure-cload-files) #'cload-test)
  40   #-win32 (impure-runner (sh-files) #'sh-test)
  41   (report)
  42   (sb-ext:exit :code (if (unexpected-failures)
  43                          1
  44                          104)))
  45
  46 (defun report ()
  47   (terpri)
  48   (format t "Finished running tests.~%")
  49   (let ((skipcount 0)
  50         (*print-pretty* nil))
  51     (cond (*all-failures*
  52            (format t "Status:~%")
  53            (dolist (fail (reverse *all-failures*))
  54              (cond ((eq (car fail) :unhandled-error)
  55                     (output-colored-text (car fail)
  56                                           " Unhandled Error")
  57                     (format t " ~a~%"
  58                             (enough-namestring (second fail))))
  59                    ((eq (car fail) :invalid-exit-status)
  60                     (output-colored-text (car fail)
  61                                           " Invalid exit status:")
  62                     (format t " ~a~%"
  63                             (enough-namestring (second fail))))
  64                    ((eq (car fail) :skipped-disabled)
  65                     (when *report-skipped-tests*
  66                       (format t " ~20a ~a / ~a~%"
  67                               "Skipped (irrelevant):"
  68                               (enough-namestring (second fail))
  69                               (third fail)))
  70                     (incf skipcount))
  71                    (t
  72                     (output-colored-text
  73                      (first fail)
  74                      (ecase (first fail)
  75                        (:expected-failure " Expected failure:")
  76                        (:unexpected-failure " Failure:")
  77                        (:leftover-thread " Leftover thread (broken):")
  78                        (:unexpected-success " Unexpected success:")
  79                        (:skipped-broken " Skipped (broken):")
  80                        (:skipped-disabled " Skipped (irrelevant):")))
  81                     (format t " ~a / ~a~%"
  82                             (enough-namestring (second fail))
  83                             (third fail)))))
  84            (when (> skipcount 0)
  85              (format t " (~a tests skipped for this combination of platform and features)~%"
  86                      skipcount)))
  87           (t
  88            (format t "All tests succeeded~%")))))
  89
  90 (defun pure-runner (files test-fun)
  91   (format t "// Running pure tests (~a)~%" test-fun)
  92   (let ((*package* (find-package :cl-user))
  93         (*failures* nil))
  94     (setup-cl-user)
  95     (dolist (file files)
  96       (when (accept-test-file file)
  97         (format t "// Running ~a~%" file)
  98         (restart-case
  99             (handler-bind ((error (make-error-handler file)))
 100               (eval (funcall test-fun file)))
 101           (skip-file ()))))
 102     (append-failures)))
 103
 104 (defun run-in-child-sbcl (load-forms forms)
 105   ;; We used to fork() for POSIX platforms, and use this for Windows.
 106   ;; However, it seems better to use the same solution everywhere.
 107   (process-exit-code
 108    (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
 109      (sb-ext:run-program
 110       (first *POSIX-ARGV*)
 111       (append
 112        (list "--core" SB-INT:*CORE-STRING*
 113              "--noinform"
 114              "--no-sysinit"
 115              "--no-userinit"
 116              "--noprint"
 117              "--disable-debugger")
 118        (loop for form in (append load-forms forms)
 119              collect "--eval"
 120              collect (write-to-string form)))
 121       :output sb-sys:*stdout*
 122       :input #-win32 devnull #+win32 sb-sys:*stdin*))))
 123
 124 (defun run-impure-in-child-sbcl (test-file test-code)
 125   (run-in-child-sbcl
 126     `((load "test-util")
 127       (load "assertoid")
 128       (defpackage :run-tests
 129         (:use :cl :test-util :sb-ext)))
 130
 131     `((in-package :cl-user)
 132       (use-package :test-util)
 133       (use-package :assertoid)
 134       (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
 135       (setf test-util:*break-on-expected-failure*
 136             ,test-util:*break-on-expected-failure*)
 137       (let ((file ,test-file)
 138             (*break-on-error* ,run-tests::*break-on-error*))
 139         (declare (special *break-on-error*))
 140         (format t "// Running ~a~%" file)
 141         (restart-case
 142             (handler-bind
 143                 ((error (lambda (condition)
 144                           (push (list :unhandled-error file)
 145                                 test-util::*failures*)
 146                           (cond (*break-on-error*
 147                                  (test-util:really-invoke-debugger condition))
 148                                 (t
 149                                  (format *error-output* "~&Unhandled ~a: ~a~%"
 150                                          (type-of condition) condition)
 151                                  (sb-debug:print-backtrace)))
 152                           (invoke-restart 'skip-file))))
 153               ,test-code)
 154           (skip-file ()
 155             (format t ">>>~a<<<~%" test-util::*failures*)))
 156         (test-util:report-test-status)
 157         (sb-ext:exit :code 104)))))
 158
 159 (defun impure-runner (files test-fun)
 160   (format t "// Running impure tests (~a)~%" test-fun)
 161   (let ((*package* (find-package :cl-user)))
 162     (setup-cl-user)
 163     (dolist (file files)
 164       (when (accept-test-file file)
 165         (force-output)
 166         (let ((exit-code (run-impure-in-child-sbcl file
 167                                                    (funcall test-fun file))))
 168           (if (= exit-code 104)
 169               (with-open-file (stream "test-status.lisp-expr"
 170                                       :direction :input
 171                                       :if-does-not-exist :error)
 172                 (append-failures (read stream)))
 173               (push (list :invalid-exit-status file)
 174                     *all-failures*)))))))
 175
 176 (defun make-error-handler (file)
 177   (lambda (condition)
 178     (push (list :unhandled-error file) *failures*)
 179     (cond (*break-on-error*
 180            (test-util:really-invoke-debugger condition))
 181           (t
 182            (format *error-output* "~&Unhandled ~a: ~a~%"
 183                    (type-of condition) condition)
 184            (sb-debug:print-backtrace)))
 185     (invoke-restart 'skip-file)))
 186
 187 (defun append-failures (&optional (failures *failures*))
 188   (setf *all-failures* (append failures *all-failures*)))
 189
 190 (defun unexpected-failures ()
 191   (remove-if (lambda (x)
 192                (or (eq (car x) :expected-failure)
 193                    (eq (car x) :unexpected-success)
 194                    (eq (car x) :skipped-broken)
 195                    (eq (car x) :skipped-disabled)))
 196              *all-failures*))
 197
 198 (defun setup-cl-user ()
 199   (use-package :test-util)
 200   (use-package :assertoid))
 201
 202 (defun load-test (file)
 203   `(load ,file))
 204
 205 (defun cload-test (file)
 206   `(let ((compile-name (compile-file-pathname ,file)))
 207      (unwind-protect
 208           (progn
 209             (compile-file ,file)
 210             (load compile-name))
 211        (ignore-errors
 212          (delete-file compile-name)))))
 213
 214 (defun sh-test (file)
 215   ;; What? No SB-POSIX:EXECV?
 216   `(let ((process (sb-ext:run-program "/bin/sh"
 217                                       (list (native-namestring ,file))
 218                                       :output *error-output*)))
 219      (let ((*failures* nil))
 220        (test-util:report-test-status))
 221      (sb-ext:exit :code (process-exit-code process))))
 222
 223 (defun accept-test-file (file)
 224   (if *accept-files*
 225       (find (truename file) *accept-files* :test #'equalp)
 226       t))
 227
 228 (defun pure-load-files ()
 229   (directory "*.pure.lisp"))
 230
 231 (defun pure-cload-files ()
 232   (directory "*.pure-cload.lisp"))
 233
 234 (defun impure-load-files ()
 235   (directory "*.impure.lisp"))
 236
 237 (defun impure-cload-files ()
 238   (directory "*.impure-cload.lisp"))
 239
 240 (defun sh-files ()
 241   (directory "*.test.sh"))