-#+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
-(require :asdf)
-
-#+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
(handler-bind (#+win32 (warning #'muffle-warning))
(require :sb-posix))
(in-package run-tests)
+(load "colorize.lisp")
+
(defvar *all-failures* nil)
(defvar *break-on-error* nil)
(defvar *report-skipped-tests* nil)
-(defvar *accept-files* nil)
+(defvar *explicit-test-files* nil)
(defun run-all ()
(dolist (arg (cdr *posix-argv*))
(setf test-util:*break-on-expected-failure* t))
((string= arg "--report-skipped-tests")
(setf *report-skipped-tests* t))
+ ((string= arg "--no-color"))
(t
- (push (truename (parse-namestring arg)) *accept-files*))))
+ (push (truename (parse-namestring arg)) *explicit-test-files*))))
(pure-runner (pure-load-files) #'load-test)
(pure-runner (pure-cload-files) #'cload-test)
(impure-runner (impure-load-files) #'load-test)
(format t "Status:~%")
(dolist (fail (reverse *all-failures*))
(cond ((eq (car fail) :unhandled-error)
- (format t " ~20a ~a~%"
- "Unhandled error"
+ (output-colored-text (car fail)
+ " Unhandled Error")
+ (format t " ~a~%"
(enough-namestring (second fail))))
((eq (car fail) :invalid-exit-status)
- (format t " ~20a ~a~%"
- "Invalid exit status:"
+ (output-colored-text (car fail)
+ " Invalid exit status:")
+ (format t " ~a~%"
(enough-namestring (second fail))))
((eq (car fail) :skipped-disabled)
(when *report-skipped-tests*
(third fail)))
(incf skipcount))
(t
- (format t " ~20a ~a / ~a~%"
- (ecase (first fail)
- (:expected-failure "Expected failure:")
- (:unexpected-failure "Failure:")
- (:leftover-thread "Leftover thread (broken):")
- (:unexpected-success "Unexpected success:")
- (:skipped-broken "Skipped (broken):")
- (:skipped-disabled "Skipped (irrelevant):"))
+ (output-colored-text
+ (first fail)
+ (ecase (first fail)
+ (:expected-failure " Expected failure:")
+ (:unexpected-failure " Failure:")
+ (:leftover-thread " Leftover thread (broken):")
+ (:unexpected-success " Unexpected success:")
+ (:skipped-broken " Skipped (broken):")
+ (:skipped-disabled " Skipped (irrelevant):")))
+ (format t " ~a / ~a~%"
(enough-namestring (second fail))
(third fail)))))
(when (> skipcount 0)
(format t "All tests succeeded~%")))))
(defun pure-runner (files test-fun)
- (format t "// Running pure tests (~a)~%" test-fun)
- (let ((*package* (find-package :cl-user))
- (*failures* nil))
- (setup-cl-user)
- (dolist (file files)
- (when (accept-test-file file)
+ (when files
+ (format t "// Running pure tests (~a)~%" test-fun)
+ (let ((*package* (find-package :cl-user))
+ (*failures* nil))
+ (setup-cl-user)
+ (dolist (file files)
(format t "// Running ~a~%" file)
(restart-case
(handler-bind ((error (make-error-handler file)))
(eval (funcall test-fun file)))
- (skip-file ()))))
- (append-failures)))
+ (skip-file ())))
+ (append-failures))))
(defun run-in-child-sbcl (load-forms forms)
;; We used to fork() for POSIX platforms, and use this for Windows.
(sb-ext:exit :code 104)))))
(defun impure-runner (files test-fun)
- (format t "// Running impure tests (~a)~%" test-fun)
- (let ((*package* (find-package :cl-user)))
- (setup-cl-user)
- (dolist (file files)
- (when (accept-test-file file)
+ (when files
+ (format t "// Running impure tests (~a)~%" test-fun)
+ (let ((*package* (find-package :cl-user)))
+ (setup-cl-user)
+ (dolist (file files)
(force-output)
(let ((exit-code (run-impure-in-child-sbcl file
(funcall test-fun file))))
;; What? No SB-POSIX:EXECV?
`(let ((process (sb-ext:run-program "/bin/sh"
(list (native-namestring ,file))
- :environment (test-util::test-env)
:output *error-output*)))
(let ((*failures* nil))
(test-util:report-test-status))
(sb-ext:exit :code (process-exit-code process))))
-(defun accept-test-file (file)
- (if *accept-files*
- (find (truename file) *accept-files* :test #'equalp)
- t))
+(defun filter-test-files (wild-mask)
+ (if *explicit-test-files*
+ (loop for file in *explicit-test-files*
+ when (pathname-match-p file wild-mask)
+ collect file)
+ (directory wild-mask)))
(defun pure-load-files ()
- (directory "*.pure.lisp"))
+ (filter-test-files "*.pure.lisp"))
(defun pure-cload-files ()
- (directory "*.pure-cload.lisp"))
+ (filter-test-files "*.pure-cload.lisp"))
(defun impure-load-files ()
- (directory "*.impure.lisp"))
+ (filter-test-files "*.impure.lisp"))
(defun impure-cload-files ()
- (directory "*.impure-cload.lisp"))
+ (filter-test-files "*.impure-cload.lisp"))
(defun sh-files ()
- (directory "*.test.sh"))
+ (filter-test-files "*.test.sh"))