tests/run-tests.lisp

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