Commit 15d93e83 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Make the multiple-failures reporting apparatus actually work.

parent 1dc783cb
...@@ -7,12 +7,12 @@ ...@@ -7,12 +7,12 @@
;;; Documentation ;;; Documentation
(deftestcmd doc () (deftestcmd doc ()
"build documentation in doc/ directory" "build documentation in doc/ directory"
(with-failure-context ("in doc/ directory") (with-failure-context (:name "in doc/ directory")
(run* '(make) :directory (pn "doc/")))) (run* '(make) :directory (pn "doc/"))))
(deftestcmd website () (deftestcmd website ()
"publish documentation onto the public website" "publish documentation onto the public website"
(with-failure-context ("in doc/ directory") (with-failure-context (:name "in doc/ directory")
(run* '(make website) :directory (pn "doc/")))) (run* '(make website) :directory (pn "doc/"))))
......
...@@ -95,8 +95,8 @@ ...@@ -95,8 +95,8 @@
(defun make-failures (&optional list) (defun make-failures (&optional list)
(make-condition 'execution-failures :failures list)) (make-condition 'execution-failures :failures list))
(defmacro with-failure-context ((&optional context) &body body) (defmacro with-failure-context ((&key name (fail-fast t)) &body body)
`(call-with-failure-context (lambda () ,@body) ,context)) `(call-with-failure-context (lambda () ,@body) :name ,name :fail-fast ,fail-fast))
(defun register-failures (failure) (defun register-failures (failure)
(let ((failure (make-failure failure))) (let ((failure (make-failure failure)))
...@@ -107,18 +107,17 @@ ...@@ -107,18 +107,17 @@
(push failure *failures*))) (push failure *failures*)))
failure)) failure))
(defun call-with-failure-context (thunk context) (defun call-with-failure-context (thunk &key name (fail-fast t))
(let ((toplevel (null *execution-context*)) (let ((toplevel (null *execution-context*))
(*execution-context* (cons context *execution-context*)) (*execution-context* (cons name *execution-context*)))
(fail-fast *fail-fast*)
(*fail-fast* t))
(labels ((compute () (labels ((compute ()
(block nil (block nil
(handler-bind ((error (lambda (c) (handler-bind ((error (lambda (c)
(register-failures c) (register-failures c)
(if (and fail-fast (not toplevel)) (cond
(error (make-failures)) (toplevel (return (failure *failures*)))
(return (failure)))))) (fail-fast (error (make-failures)))
(t (return (failure)))))))
(funcall thunk)))) (funcall thunk))))
(doit () (doit ()
(let ((results (multiple-value-list (compute)))) (let ((results (multiple-value-list (compute))))
...@@ -128,13 +127,12 @@ ...@@ -128,13 +127,12 @@
(doit))))) (doit)))))
(defmacro without-stopping (() &body body) (defmacro without-stopping (() &body body)
`(call-without-stopping ,@(mapcar (lambda (form) `(lambda () ,form)) body))) `(call-without-stopping (list ,@(mapcar (lambda (form) `(lambda () ,form)) body))))
(defun call-without-stopping (&rest thunks) (defun call-without-stopping (thunks)
(let ((failurep nil) (with-failure-context (:fail-fast nil)
(*fail-fast* nil)) (let ((failurep nil))
(dolist (thunk thunks) (dolist (thunk thunks)
(when (failurep (multiple-value-list (with-failure-context () (funcall thunk)))) (when (failurep (multiple-value-list (with-failure-context () (funcall thunk))))
(setf failurep t))) (setf failurep t)))
(failure-if failurep (make-failures)))) (failure-if failurep (make-failures)))))
...@@ -38,15 +38,13 @@ ...@@ -38,15 +38,13 @@
(deftestcmd fix-local-git-tags () (deftestcmd fix-local-git-tags ()
"delete wrongful tags from local git repository" "delete wrongful tags from local git repository"
(without-stopping () (call-without-stopping
(dolist (tag *wrongful-tags*) (mapcar (lambda (tag) (lambda () (git `(tag -d ,tag) :on-error nil))) *wrongful-tags*)))
(git `(tag -d ,tag) :on-error nil))))
(deftestcmd fix-remote-git-tags ((remote "origin")) (deftestcmd fix-remote-git-tags ((remote "origin"))
"delete wrongful tags from remote git repository" "delete wrongful tags from remote git repository"
(without-stopping () (call-without-stopping
(dolist (tag *wrongful-tags*) (mapcar (lambda (tag) (lambda () (git `(push ,remote (:refs/tags/,tag)) :on-error nil))) *wrongful-tags*)))
(git `(push ,remote (:refs/tags/,tag)) :on-error nil))))
(deftestcmd git-all-committed-p () (deftestcmd git-all-committed-p ()
"is your checkout clean, with all files committed?" "is your checkout clean, with all files committed?"
......
...@@ -96,10 +96,11 @@ based on a list of targets" ...@@ -96,10 +96,11 @@ based on a list of targets"
;;; NB: For access control, you could check that only exported symbols are used as entry points. ;;; NB: For access control, you could check that only exported symbols are used as entry points.
(defun process-arguments (args) (defun process-arguments (args)
(if-let ((fun (and args (find-command (first args))))) (if-let ((fun (and args (find-command (first args)))))
(let ((results (multiple-value-list (apply fun (rest args))))) (let ((results (multiple-value-list (with-failure-context () (apply fun (rest args))))))
;; Don't print anything on success for regular commands, otherwise print all values returned. ;; Don't print anything on success for regular commands, otherwise print all values returned.
(if (failurep results) (if (failurep results)
(format t "~&Failure:~{~& ~A~}~&" (failure-failures results)) (let ((failures (failure-failures results)))
(format t "~&Failure~P:~{~& ~A~}~&" (length failures) failures))
(format t "~{~&~S~&~}" (if (successp results) (success-values results) results))) (format t "~{~&~S~&~}" (if (successp results) (success-values results) results)))
(apply 'values results)) (apply 'values results))
(progn (progn
......
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
(let ((thunks (let ((thunks
(loop :for lisp :in (get-lisps lisps) (loop :for lisp :in (get-lisps lisps)
:collect (let ((l lisp)) :collect (let ((l lisp))
(lambda () (with-failure-context ((format nil "using ~(~A~)" l)) (lambda () (with-failure-context (:name (format nil "using ~(~A~)" l))
(funcall thunk l))))))) (funcall thunk l)))))))
(if fail-fast (if fail-fast
(progn (map () 'funcall thunks) (success)) (progn (map () 'funcall thunks) (success))
......
...@@ -134,7 +134,7 @@ ...@@ -134,7 +134,7 @@
(return (return
`(defun ,name (&optional ,@largs) `(defun ,name (&optional ,@largs)
,@decl ,@decl
(with-failure-context (,(command-name name)) (with-failure-context (:name ,(command-name name))
,@inits ,@inits
,@body ,@body
(success))))))) ;; use return-from ,name to return a value. (success))))))) ;; use return-from ,name to return a value.
...@@ -200,7 +200,7 @@ ...@@ -200,7 +200,7 @@
(defun run* (cmd &rest keys) (defun run* (cmd &rest keys)
(let* ((string (strcat "`" (print-process-spec cmd) "`"))) (let* ((string (strcat "`" (print-process-spec cmd) "`")))
(with-failure-context (string) (with-failure-context (:name string)
(apply 'run cmd (apply 'run cmd
:on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c))) :on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c)))
keys)))) keys))))
......
...@@ -35,50 +35,51 @@ Use the preferred lisp implementation" ...@@ -35,50 +35,51 @@ Use the preferred lisp implementation"
(let* ((log (newlogfile "test" lisp))) (let* ((log (newlogfile "test" lisp)))
(log! log "Running the following ~D ASDF test script~:*~P on ~(~A~):~%~{ ~A~%~}" (log! log "Running the following ~D ASDF test script~:*~P on ~(~A~):~%~{ ~A~%~}"
(length test-scripts) lisp test-scripts)) (length test-scripts) lisp test-scripts))
(without-stopping ()) (let ((n-tests (length test-scripts))
(and (test-pass 0)
(run-test-lisp (test-fail 0)
"compiling ASDF" (failed-list ())))
'((load "test/script-support.lisp") (asdf-test::compile-asdf-script)) (call-without-stopping
:lisp lisp :log log)) `(,(lambda() (run-test-lisp
(loop "compiling ASDF"
:with n-tests = (length test-scripts) '((load "test/script-support.lisp") (asdf-test::compile-asdf-script))
:with test-pass = 0 :lisp lisp :log log))
:with test-fail = 0 ,@(mapcar
:with failed-list = () (lambda (test-script)
:for i :in test-scripts (lambda ()
:for ni = (native-namestring (subpathname "test/" i)) ;; TODO: do we want to delete the output file cache?
:for test-count :from 0 ;; If so, we need to do it in the inferior lisp,
:do ;; because only it knows for sure its output configuration.
;; TODO: do we want to delete the output file cache? ;; Or we could do it in a more heavy handed way.
;; If so, we need to do it in the inferior lisp, ;; A better solution would be to do any output operations in a temporary workspace,
;; because only it knows for sure its output configuration. ;; which would allow test parallelization.
;; Or we could do it in a more heavy handed way. (if (with-failure-context (:fail-fast nil)
(if (run-test-lisp (run-test-lisp
(format nil "testing ~A on ~(~A~)" i lisp) (format nil "testing ~A on ~(~A~)" test-script lisp)
`((load "test/script-support.lisp") `((load "test/script-support.lisp")
(asdf-test::load-asdf) (asdf-test::load-asdf)
(asdf-test::frob-packages) (asdf-test::frob-packages)
(asdf-test::run-test-script ,ni)) (asdf-test::run-test-script ,(native-namestring (subpathname "test/" test-script))))
:lisp lisp :log log) :lisp lisp :log log))
(incf test-pass) (incf test-pass)
(progn (progn
(incf test-fail) (incf test-fail)
(push i failed-list))) (push test-script failed-list)))))
:finally) test-scripts)
(let ((failp (plusp test-fail))) ,(lambda ()
(log! log "~ (let ((failp (plusp test-fail)))
(log! log "~
-#--------------------------------------- -#---------------------------------------
Using ~A Using ~A
Ran ~D tests, ~D passed, ~D failed~ Ran ~D tests, ~D passed, ~D failed~
~:[~%All tests apparently successful.~;:~:*~{~% ~A~}~] ~:[~%All tests apparently successful.~;:~:*~{~% ~A~}~]
-#---------------------------------------~%" -#---------------------------------------~%"
lisp lisp
n-tests test-pass test-fail (reverse failed-list)) n-tests test-pass test-fail (reverse failed-list))
(when failp (when failp
(log! log "To view full results and failures, try the following command: (log! log "To view full results and failures, try the following command:
less -p ABORTED ~A" (enough-namestring log (pn)))) less -p ABORTED ~A" (enough-namestring log (pn))))
(failure-if failp "~D test~:*~P failed" test-fail)))) (failure-if failp "~D test~:*~P failed" test-fail)))))))
(deftestcmd test (lisp test-scripts) (deftestcmd test (lisp test-scripts)
"run all normal tests but upgrade tests "run all normal tests but upgrade tests
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment