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 @@
;;; Documentation
(deftestcmd doc ()
"build documentation in doc/ directory"
(with-failure-context ("in doc/ directory")
(with-failure-context (:name "in doc/ directory")
(run* '(make) :directory (pn "doc/"))))
(deftestcmd 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/"))))
......@@ -95,8 +95,8 @@
(defun make-failures (&optional list)
(make-condition 'execution-failures :failures list))
(defmacro with-failure-context ((&optional context) &body body)
`(call-with-failure-context (lambda () ,@body) ,context))
(defmacro with-failure-context ((&key name (fail-fast t)) &body body)
`(call-with-failure-context (lambda () ,@body) :name ,name :fail-fast ,fail-fast))
(defun register-failures (failure)
(let ((failure (make-failure failure)))
......@@ -107,18 +107,17 @@
(push failure *failures*)))
(defun call-with-failure-context (thunk context)
(defun call-with-failure-context (thunk &key name (fail-fast t))
(let ((toplevel (null *execution-context*))
(*execution-context* (cons context *execution-context*))
(fail-fast *fail-fast*)
(*fail-fast* t))
(*execution-context* (cons name *execution-context*)))
(labels ((compute ()
(block nil
(handler-bind ((error (lambda (c)
(register-failures c)
(if (and fail-fast (not toplevel))
(error (make-failures))
(return (failure))))))
(toplevel (return (failure *failures*)))
(fail-fast (error (make-failures)))
(t (return (failure)))))))
(funcall thunk))))
(doit ()
(let ((results (multiple-value-list (compute))))
......@@ -128,13 +127,12 @@
(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)
(let ((failurep nil)
(*fail-fast* nil))
(defun call-without-stopping (thunks)
(with-failure-context (:fail-fast nil)
(let ((failurep nil))
(dolist (thunk thunks)
(when (failurep (multiple-value-list (with-failure-context () (funcall thunk))))
(setf failurep t)))
(failure-if failurep (make-failures))))
(failure-if failurep (make-failures)))))
......@@ -38,15 +38,13 @@
(deftestcmd fix-local-git-tags ()
"delete wrongful tags from local git repository"
(without-stopping ()
(dolist (tag *wrongful-tags*)
(git `(tag -d ,tag) :on-error nil))))
(mapcar (lambda (tag) (lambda () (git `(tag -d ,tag) :on-error nil))) *wrongful-tags*)))
(deftestcmd fix-remote-git-tags ((remote "origin"))
"delete wrongful tags from remote git repository"
(without-stopping ()
(dolist (tag *wrongful-tags*)
(git `(push ,remote (:refs/tags/,tag)) :on-error nil))))
(mapcar (lambda (tag) (lambda () (git `(push ,remote (:refs/tags/,tag)) :on-error nil))) *wrongful-tags*)))
(deftestcmd git-all-committed-p ()
"is your checkout clean, with all files committed?"
......@@ -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.
(defun process-arguments (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.
(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)))
(apply 'values results))
......@@ -4,7 +4,7 @@
(let ((thunks
(loop :for lisp :in (get-lisps lisps)
: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)))))))
(if fail-fast
(progn (map () 'funcall thunks) (success))
......@@ -134,7 +134,7 @@
`(defun ,name (&optional ,@largs)
(with-failure-context (,(command-name name))
(with-failure-context (:name ,(command-name name))
(success))))))) ;; use return-from ,name to return a value.
......@@ -200,7 +200,7 @@
(defun run* (cmd &rest keys)
(let* ((string (strcat "`" (print-process-spec cmd) "`")))
(with-failure-context (string)
(with-failure-context (:name string)
(apply 'run cmd
:on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c)))
......@@ -35,37 +35,38 @@ Use the preferred lisp implementation"
(let* ((log (newlogfile "test" lisp)))
(log! log "Running the following ~D ASDF test script~:*~P on ~(~A~):~%~{ ~A~%~}"
(length test-scripts) lisp test-scripts))
(without-stopping ())
(let ((n-tests (length test-scripts))
(test-pass 0)
(test-fail 0)
(failed-list ())))
`(,(lambda() (run-test-lisp
"compiling ASDF"
'((load "test/script-support.lisp") (asdf-test::compile-asdf-script))
:lisp lisp :log log))
:with n-tests = (length test-scripts)
:with test-pass = 0
:with test-fail = 0
:with failed-list = ()
:for i :in test-scripts
:for ni = (native-namestring (subpathname "test/" i))
:for test-count :from 0
(lambda (test-script)
(lambda ()
;; TODO: do we want to delete the output file cache?
;; If so, we need to do it in the inferior lisp,
;; because only it knows for sure its output configuration.
;; Or we could do it in a more heavy handed way.
(if (run-test-lisp
(format nil "testing ~A on ~(~A~)" i lisp)
;; A better solution would be to do any output operations in a temporary workspace,
;; which would allow test parallelization.
(if (with-failure-context (:fail-fast nil)
(format nil "testing ~A on ~(~A~)" test-script lisp)
`((load "test/script-support.lisp")
(asdf-test::run-test-script ,ni))
:lisp lisp :log log)
(asdf-test::run-test-script ,(native-namestring (subpathname "test/" test-script))))
:lisp lisp :log log))
(incf test-pass)
(incf test-fail)
(push i failed-list)))
(push test-script failed-list)))))
,(lambda ()
(let ((failp (plusp test-fail)))
(log! log "~
......@@ -78,7 +79,7 @@ Ran ~D tests, ~D passed, ~D failed~
(when failp
(log! log "To view full results and failures, try the following command:
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)
"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