tests/run-tests.lisp

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