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