From a0317bc159295199cd7a4d255a0367b173f54821 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 9 Apr 2015 03:30:57 -0400 Subject: [PATCH] Remember failures and show them at the end. --- .gitignore | 1 + doc/Makefile | 9 ++- tools/asdf-tools.asd | 11 +-- tools/build.lisp | 31 ++++---- tools/failure.lisp | 140 ++++++++++++++++++++++++++++++++++++ tools/git.lisp | 32 ++++----- tools/install-asdf.lisp | 2 +- tools/main.lisp | 39 ++++------ tools/release.lisp | 106 +++++++++++++-------------- tools/test-all.lisp | 80 +++++++++++---------- tools/test-basic.lisp | 8 +-- tools/test-environment.lisp | 40 ++++++----- tools/test-scripts.lisp | 22 ++++-- tools/test-upgrade.lisp | 22 +++--- 14 files changed, 339 insertions(+), 204 deletions(-) create mode 100644 tools/failure.lisp diff --git a/.gitignore b/.gitignore index b17f0de93..024ee67a8 100644 --- a/.gitignore +++ b/.gitignore @@ -24,6 +24,7 @@ doc/asdf.vrs doc/asdf.t2d/ doc/asdf.dvi doc/version.texinfo +doc/*.log *.tmp LICENSE diff --git a/doc/Makefile b/doc/Makefile index 632804cff..c9c4fce44 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -16,16 +16,19 @@ version.texinfo: ../version.lisp-expr head -n 1 $^ | perl -ne 'm|\"(.*)\"|; print "\@set VERSION $$1\n"' > $@ manual-html: asdf.texinfo version.texinfo - makeinfo --html asdf.texinfo + makeinfo --html asdf.texinfo \ + 2>&1 > manual-html.log || { echo "failed. See log in manual-html.log" ; exit 1 ;} asdf.html: asdf.texinfo version.texinfo - makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo + makeinfo --html --no-split --no-headers -o asdf.html asdf.texinfo \ + 2>&1 > asdf.html.log || { echo "failed. See log in asdf.html.log" ; exit 1 ;} asdf.info: asdf.texinfo version.texinfo makeinfo asdf.texinfo asdf.pdf: asdf.texinfo version.texinfo - texi2pdf asdf.texinfo + texi2pdf asdf.texinfo \ + 2>&1 > asdf.pdf.log || { echo "failed. See log in asdf.pdf.log" ; exit 1 ;} website: all rsync -lt --no-g ${webfiles} ${website} diff --git a/tools/asdf-tools.asd b/tools/asdf-tools.asd index 0c616db02..661d45709 100644 --- a/tools/asdf-tools.asd +++ b/tools/asdf-tools.asd @@ -8,16 +8,17 @@ (:feature :sbcl "sb-introspect")) :components ((:file "package") - (:file "main" :depends-on ("package")) + (:file "failure" :depends-on ("package")) + (:file "main" :depends-on ("failure")) (:file "pathnames" :depends-on ("package")) - (:file "git" :depends-on ("package")) - (:file "build" :depends-on ("pathnames")) - (:file "version" :depends-on ("pathnames")) + (:file "version" :depends-on ("failure")) (:file "invoke-lisp" :depends-on ("package")) (:file "test-environment" :depends-on ("pathnames" "invoke-lisp" "main")) + (:file "build" :depends-on ("test-environment")) + (:file "git" :depends-on ("test-environment")) (:file "test-basic" :depends-on ("test-environment")) (:file "test-scripts" :depends-on ("test-environment")) (:file "test-upgrade" :depends-on ("test-environment" "git")) (:file "test-all" :depends-on ("test-environment")) (:file "installation" :depends-on ("test-environment")) - (:file "release" :depends-on ("version" "test-environment")))) + (:file "release" :depends-on ("version" "test-environment" "git")))) diff --git a/tools/build.lisp b/tools/build.lisp index 48f9780c3..6313b572d 100644 --- a/tools/build.lisp +++ b/tools/build.lisp @@ -1,40 +1,37 @@ (in-package :asdf-tools) -(defun build-asdf () +(deftestcmd build-asdf () "make sure asdf.lisp is built" - (load-system :asdf) - (success)) + (load-system :asdf)) ;;; Documentation -(defun doc () +(deftestcmd doc () "build documentation in doc/ directory" - (run '(make) :directory (pn "doc/")) - (success)) + (with-failure-context ("in doc/ directory") + (run* '(make) :directory (pn "doc/")))) -(defun website () +(deftestcmd website () "publish documentation onto the public website" - (run '(make website) :directory (pn "doc/")) - (success)) + (with-failure-context ("in doc/ directory") + (run* '(make website) :directory (pn "doc/")))) ;;; Line counting -(defun wc () +(deftestcmd wc () "count lines of lisp code in asdf and uiop" (with-asdf-dir () (flet ((lisp-only (x) (remove "lisp" x :test-not 'equal :key 'pathname-type))) (let ((driver-files (mapcar #'(lambda (x) (subpathname "uiop/" x)) (lisp-only (uiop-files)))) (defsystem-files (lisp-only (asdf-defsystem-files)))) - (run `(pipe (wc ,@driver-files) (sort -n))) + (run* `(pipe (wc ,@driver-files) (sort -n))) (terpri) - (run `(pipe (wc header.lisp ,@defsystem-files) (sort -n))) + (run* `(pipe (wc header.lisp ,@defsystem-files) (sort -n))) (terpri) - (run `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1)))))) - (success)) + (run* `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1))))))) ;;; debug the source registry that is being used to execute these tools. -(defun list-source-registry () +(deftestcmd list-source-registry () "Display the source-registry cache" (writeln (sort (alexandria:hash-table-alist asdf::*source-registry*) - 'string< :key 'car)) - (success)) + 'string< :key 'car))) diff --git a/tools/failure.lisp b/tools/failure.lisp new file mode 100644 index 000000000..8a69f00ee --- /dev/null +++ b/tools/failure.lisp @@ -0,0 +1,140 @@ +;;;; Useful information when failing. +(in-package :asdf-tools) + +(defvar *fail-fast* nil) +(defvar *fail-verbose* nil) +(defvar *execution-context* nil) ;; context for debugging information +(defvar *failures* nil) +(defvar *failurep* nil) + +;;;(defvar *failure-handler* nil) + +(define-condition execution-error (error) + ()) + +(defmethod print-object ((failure execution-error) stream) + (if *print-escape* + (print-unreadable-object (failure stream :type t :identity nil) + (let ((*print-escape* nil)) + (print-object failure stream))) + (princ "FAILED" stream))) + +(define-condition execution-failure (execution-error) + ((context :initform nil :initarg :context :reader failure-context) + (reason :initarg :reason :reader failure-reason))) + +(defmethod print-object ((failure execution-failure) stream) + (if *print-escape* (call-next-method) + (format stream "~@[In ~{~A~^, ~}: ~]~:[FAILED~;~:*~A~]" + (reverse (remove nil (failure-context failure))) + (failure-reason failure)))) + +(define-condition execution-failures (execution-error) + ((failures :initform nil :initarg :failures :reader failure-list))) + +(defmethod print-object ((failures execution-failures) stream) + (if *print-escape* (call-next-method) + (format stream "Failure~@[~P~:*~{~&~A~&~}~]" + (reverse (failure-list failures))))) + +(defun make-error (&optional reason &rest arguments) + (etypecase reason + (error reason) + (string (make-condition 'simple-error + :format-control reason :format-arguments arguments)) + (null (make-failures)) + (symbol (apply 'make-condition reason arguments)))) + +(defun fail! (&rest reason-arguments) + (error (apply 'make-error reason-arguments))) + +(defun success (&rest values) + "Return magic values that signal success" + (cond + ((successp values) (apply 'values values)) + ((failurep values) (apply 'values values)) + (t (apply 'values t '#:success values)))) + +(defun failure (&optional failures) + "Return magic values that signal failure" + (values nil '#:failure failures)) + +(defun successp (value-list) + (and (length>=n-p value-list 2) + (equal (subseq value-list 0 2) + (multiple-value-list (success))))) + +(defun success-values (value-list) + (subseq value-list 2)) + +(defun failurep (value-list) + (and (length>=n-p value-list 2) + (equal (subseq value-list 0 2) + (subseq (multiple-value-list (failure)) 0 2)))) + +(defun failure-failures (value-list) + (third value-list)) + +(defun success-if (test &rest failure-args) + "If TEST, return success, otherwise, return failure with FAILURE-ARGS" + (if test + (success) + (apply 'fail! (or failure-args '("failed"))))) + +(defun failure-if (test &rest failure-args) + "If not TEST, return success, otherwise, return failure with FAILURE-ARGS" + (apply 'success-if (not test) failure-args)) + +(defun make-failure (&optional reason &rest arguments) + (if (typep reason 'execution-error) + reason + (make-condition 'execution-failure + :context *execution-context* + :reason (apply 'make-error reason arguments)))) + +(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)) + +(defun register-failures (failure) + (let ((failure (make-failure failure))) + (etypecase failure + (execution-failures + (setf *failures* (append (failure-list failure) *failures*))) + (execution-failure + (push failure *failures*))) + failure)) + +(defun call-with-failure-context (thunk context) + (let ((toplevel (null *execution-context*)) + (*execution-context* (cons context *execution-context*)) + (fail-fast *fail-fast*) + (*fail-fast* t)) + (labels ((compute () + (block nil + (handler-bind ((error (lambda (c) + (register-failures c) + (if (and fail-fast (not toplevel)) + (error (make-failures)) + (return (failure)))))) + (funcall thunk)))) + (doit () + (let ((results (multiple-value-list (compute)))) + (if (and toplevel *failures*) (failure (reverse *failures*)) (apply 'success results))))) + (if toplevel + (let ((*failures* nil)) (doit)) + (doit))))) + +(defmacro without-stopping (() &body body) + `(call-without-stopping ,@(mapcar (lambda (form) `(lambda () ,form)) body))) + +(defun call-without-stopping (&rest thunks) + (let ((failurep nil) + (*fail-fast* nil)) + (dolist (thunk thunks) + (when (failurep (multiple-value-list (with-failure-context () (funcall thunk)))) + (setf failurep t))) + (failure-if failurep (make-failures)))) + diff --git a/tools/git.lisp b/tools/git.lisp index 3c55892a4..137a1fc77 100644 --- a/tools/git.lisp +++ b/tools/git.lisp @@ -4,22 +4,15 @@ ;; Note that the debian git at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git is stale, ;; as we currently build directly from upstream at git://common-lisp.net/projects/asdf/asdf.git -(defun run* (cmd &rest keys) - (multiple-value-bind (out err code) - (apply 'run cmd keys) - (if (eql 0 code) - (success) - (values nil out err code)))) - (defun git (cmd &rest keys) (with-asdf-dir () - (apply 'run* (cons "git" cmd) keys))) + (apply 'run* `(git ,@cmd) keys))) -(defun clean () +(deftestcmd clean () "clean the checkout with git clean -xfd" (git '(clean -xfd))) -(defun %push () +(deftestcmd %push () "push git branches master and release upstream" (dolist (x '((status) (push --tags cl.net release master) @@ -28,7 +21,7 @@ (status))) (git x))) -(defun merge-master-into-release () +(deftestcmd merge-master-into-release () "merge git branch master into release" (dolist (x '((checkout master) (merge release) @@ -43,17 +36,18 @@ "RELEASE" "STABLE" ;; These were misguided attempts for what should have been branches "README" "emp")) ;; Mistakes -(defun fix-local-git-tags () +(deftestcmd fix-local-git-tags () "delete wrongful tags from local git repository" - (dolist (tag *wrongful-tags*) - (git `(tag -d ,tag) :on-error nil))) + (without-stopping () + (dolist (tag *wrongful-tags*) + (git `(tag -d ,tag) :on-error nil)))) -(defun fix-remote-git-tags (&optional (remote "origin")) +(deftestcmd fix-remote-git-tags ((remote "origin")) "delete wrongful tags from remote git repository" - (dolist (tag *wrongful-tags*) - (git `(push ,remote (:refs/tags/,tag)) :on-error nil))) + (without-stopping () + (dolist (tag *wrongful-tags*) + (git `(push ,remote (:refs/tags/,tag)) :on-error nil)))) -(defun git-all-committed-p () +(deftestcmd git-all-committed-p () "is your checkout clean, with all files committed?" (null (nth-value 1 (git '(status -s) :output :lines)))) - diff --git a/tools/install-asdf.lisp b/tools/install-asdf.lisp index b07e9a7d5..787509e30 100755 --- a/tools/install-asdf.lisp +++ b/tools/install-asdf.lisp @@ -30,7 +30,7 @@ Note that if you're using it with LispWorks (known to only provide ASDF 2 as of LispWorks 6.1 in 2015), you first have to create a command-line executable for LispWorks this way: - echo '(hcl:save-image "lispworks" :environment nil)' > si.lisp + echo '(hcl:save-image "lispworks-console" :environment nil)' > si.lisp lispworks-6-1-0-x86-linux -siteinit - -init - -build si.lisp |# diff --git a/tools/main.lisp b/tools/main.lisp index 23e79c7ca..153130389 100644 --- a/tools/main.lisp +++ b/tools/main.lisp @@ -1,17 +1,6 @@ ;;;; Generic code to interface a Lisp script to the shell command-line. (in-package :asdf-tools) -(defun success (&optional (success t)) - "Return magic values that signal success (default), or failure depending on SUCCESS" - (if success - (values t '#:success) - (values nil '#:failure))) - -(defun failure () - "Return magic values that signal failure" - (success nil)) - - (defun re (arg) "Read-Eval function (the RE of REPL) (the Print and Loop parts are not here)" @@ -52,7 +41,7 @@ Unless EARLYP is true, return NIL if the symbol is not fbound." git-all-committed-p bump-version bump ;; version test-load-systems test-clean-load test-basic %load install-asdf ;; test-basic - %test %t test-scripts ;; test-scripts + test %t test-scripts ;; test-scripts test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade test-all-clean-load test-all-scripts test-all-no-upgrade test-all-upgrade ;; test-all test-all test-all-scripts-no-stop test-all-upgrade-no-stop @@ -99,20 +88,18 @@ based on a list of targets" ;;; Main entry point. ;;; NB: For access control, you could check that only exported symbols are used as entry points. (defun process-arguments (args) - (block nil - (unless args - (format t "No command provided~%") - (return)) - (if-let ((fun (find-command (first args)))) - (let ((results (multiple-value-list (apply fun (rest args))))) - ;; Don't print anything on success for regular commands, otherwise print all values returned. - (cond - ((equal results (multiple-value-list (success)))) - ((equal results (multiple-value-list (failure))) (format t "~&Command failed.~%")) - (t (format t "~&~{~S~%~}" results))) - (return (first results)))) - (format t "Command ~A not found~%" (first args)) - (return nil))) + (if-let ((fun (and args (find-command (first args))))) + (let ((results (multiple-value-list (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)) + (format t "~{~&~S~&~}" (if (successp results) (success-values results) results))) + (apply 'values results)) + (progn + (if args + (format t "Command ~A not found~%" (first args)) + (format t "No command provided~%")) + nil))) ;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main (defun main (argv) diff --git a/tools/release.lisp b/tools/release.lisp index 3d954b2bb..99e65b626 100644 --- a/tools/release.lisp +++ b/tools/release.lisp @@ -31,39 +31,37 @@ (defun tarname (name) (strcat name ".tar.gz")) -(defun make-tarball-from-git (name base files &key (type "tar.gz")) +(deftestcmd make-tarball-from-git (name base files (type "tar.gz")) (with-asdf-dir (base) (let ((tarball (strcat name "." type))) - (run `(git archive -o ,(pn "build" tarball) - :prefix (,name /) ,*version* -- ,@files) :show t))) - (success)) + (git `(archive -o ,(pn "build" tarball) + :prefix (,name /) ,*version* -- ,@files) :show t)))) -(defun make-tarball-from-git-plus (name base files &key asdf-lisp version-file) +(deftestcmd make-tarball-from-git-plus (name base files asdf-lisp version-file) ;; make a tarball, then add build/asdf.lisp to it - (make-tarball-from-git name base files :type "tar") + (make-tarball-from-git name base files "tar") (let* ((tarball (strcat name ".tar"))) (with-asdf-dir ("build/") (when asdf-lisp (build-asdf) (ensure-directories-exist (pn "build" name "build/")) - (run `(cp -a asdf.lisp (,name /build/))) + (run* `(cp -a asdf.lisp (,name /build/))) ;; TODO: find which tar it is and tell --uid 0 --gid 0 to BSD tar ;; and --owner root --group root to GNU tar, ;; falling back to nothing. Sigh. - (run `(env "COPYFILE_DISABLE=1" + (run* `(env "COPYFILE_DISABLE=1" tar "-rf" ,tarball (,name /build/asdf.lisp)) :show t) - (run `(rm -f (,name /build/asdf.lisp))) + (run* `(rm -f (,name /build/asdf.lisp))) (delete-empty-directory (pn "build" name "build/"))) (when version-file (ensure-directories-exist (pn "build" name "")) - (run `(cp -a ../version.lisp-expr (,name /))) - (run `(env "COPYFILE_DISABLE=1" + (run* `(cp -a ../version.lisp-expr (,name /))) + (run* `(env "COPYFILE_DISABLE=1" tar "-rf" ,tarball (,name /version.lisp-expr)) :show t) - (run `(rm -f (,name /version.lisp-expr)))) + (run* `(rm -f (,name /version.lisp-expr)))) (let ((dir (pn "build" name ""))) (when (directory-exists-p dir) (delete-empty-directory dir))) - (run `(gzip -f9 ,tarball) :show t))) - (success)) + (run* `(gzip -f9 ,tarball) :show t)))) (defun uiop-files () "list files in uiop" @@ -74,7 +72,7 @@ (make-tarball-from-git-plus (driver-name) "uiop/" (remove "version.lisp-expr" (uiop-files) :test 'equal) - :version-file t)) + nil t)) (defun asdf-defsystem-files () @@ -96,19 +94,17 @@ (defun asdf-lisp-name () (format nil "asdf-~A.lisp" *version*)) -(defun make-asdf-lisp () +(deftestcmd make-asdf-lisp () (build-asdf) (concatenate-files (list (pn "build/asdf.lisp")) - (pn "build/" (asdf-lisp-name))) - (success)) + (pn "build/" (asdf-lisp-name)))) -(defun make-archive () +(deftestcmd make-archive () "build tarballs for release" (make-driver-tarball) (make-asdf-defsystem-tarball) (make-git-tarball) - (make-asdf-lisp) - (success)) + (make-asdf-lisp)) ;;; Publishing tarballs onto the public repository @@ -117,32 +113,30 @@ (defvar *clnet-asdf-public* "/project/asdf/public_html/") (defun public-path (x) (strcat *clnet-asdf-public* x)) -(defun publish-archive () +(deftestcmd publish-archive () "publish tarballs to the website" (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name))))) - (run `(rsync "--times" "--chmod=a+rX,ug+w" - ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/"))) - :show t :directory (pn "build/"))) + (run* `(rsync "--times" "--chmod=a+rX,ug+w" + ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/"))) + :show t :directory (pn "build/"))) (format t "~&To download the tarballs, point your browser at:~% http://common-lisp.net/project/asdf/archives/ -~%") - (success)) +~%")) -(defun link-archive () +(deftestcmd link-archive () "symlink new tarballs on the website" - (run (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S" - (tarname (driver-name)) - (public-path "archives/uiop.tar.gz") - (tarname (asdf-defsystem-name)) - (public-path "archives/asdf-defsystem.tar.gz") - (tarname (asdf-git-name)) - (public-path "archives/asdf.tar.gz") - (asdf-lisp-name) - (public-path "archives/asdf.lisp")) - :show t :host *clnet*) - (success)) - -(defun make-and-publish-archive () + (run* (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S" + (tarname (driver-name)) + (public-path "archives/uiop.tar.gz") + (tarname (asdf-defsystem-name)) + (public-path "archives/asdf-defsystem.tar.gz") + (tarname (asdf-git-name)) + (public-path "archives/asdf.tar.gz") + (asdf-lisp-name) + (public-path "archives/asdf.lisp")) + :show t :host *clnet*)) + +(deftestcmd make-and-publish-archive () "make and publish tarballs" (make-archive) (publish-archive) @@ -153,7 +147,7 @@ ;;; Making a debian package -(defun debian-package (&optional (release "release")) +(deftestcmd debian-package ((release "release")) "build a debian package" (let* ((debian-version (debian-version-from-file release)) (version (version-from-file release))) @@ -161,23 +155,22 @@ (error "Debian version ~A doesn't match asdf version ~A" debian-version version)) (clean) (format t "building package version ~A~%" (debian-version-from-file)) - (run `(git-buildpackage - ;; --git-ignore-new ;; for testing purpose - (--git-debian-branch= ,release) - (--git-upstream-tag="%(version)s") - ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag - ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag - --git-tag --git-retag - ;; --git-no-pristine-tar - --git-force-create - --git-ignore-branch) - :directory (pn) :show t)) - (success)) + (run* `(git-buildpackage + ;; --git-ignore-new ;; for testing purpose + (--git-debian-branch= ,release) + (--git-upstream-tag="%(version)s") + ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag + ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag + --git-tag --git-retag + ;; --git-no-pristine-tar + --git-force-create + --git-ignore-branch) + :directory (pn) :show t))) (defun debian-architecture () (run/ss `(dpkg --print-architecture))) -(defun publish-debian-package (&optional release) +(deftestcmd publish-debian-package (release) "publish a debian package" (let ((changes (strcat "cl-asdf_" (debian-version-without-epoch (debian-version-from-file release)) "_" (debian-architecture) ".changes"))) @@ -214,5 +207,4 @@ (when releasep (log! log t "Don't forget to send a debian mentors request!")) (log! log "Don't forget to send announcement to asdf-announce, asdf-devel, etc.") - (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad")))) - (success)) + (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad"))))) diff --git a/tools/test-all.lisp b/tools/test-all.lisp index adbf2ddd3..7e9c68170 100644 --- a/tools/test-all.lisp +++ b/tools/test-all.lisp @@ -1,12 +1,16 @@ (in-package :asdf-tools) -(defun call-with-all-lisps (thunk &optional (lisps *test-lisps*)) - (apply 'all-pass - (loop :for lisp :in (get-lisps lisps) - :collect (funcall thunk lisp)))) +(defun call-with-all-lisps (thunk &key (lisps *test-lisps*) (fail-fast t)) + (let ((thunks + (loop :for lisp :in (get-lisps lisps) + :collect (lambda () (with-failure-context ((format nil "using ~(~A~)" lisp)) + (funcall thunk lisp)))))) + (if fail-fast + (progn (map () 'funcall thunks) (success)) + (apply 'call-without-stopping thunks)))) -(defmacro with-all-lisps ((&optional (lisp-var 'lisp) (lisps '*test-lisps*)) &body body) - `(call-with-all-lisps (lambda (,lisp-var) ,@body) ,lisps)) +(defmacro with-all-lisps ((lisp-var lisps &key (fail-fast t)) &body body) + `(call-with-all-lisps (lambda (,lisp-var) ,@body) :lisps ,lisps :fail-fast ,fail-fast)) (deftestcmd test-all-clean-load (lisps) "test-clean-load on all lisps" @@ -18,7 +22,7 @@ (deftestcmd test-all-no-upgrade () "test-basic, and test-all-script" - (all-pass (test-basic) (test-all-scripts))) + (test-basic) (test-all-scripts)) (deftestcmd test-all-upgrade (upgrade-lisps) "test-upgrade on all lisps" @@ -26,58 +30,56 @@ (deftestcmd test-all () "all tests" - (all-pass (test-all-no-upgrade) (test-all-upgrade))) + (test-all-no-upgrade) (test-all-upgrade)) (deftestcmd test-all-scripts-no-stop (lisps) "test-scripts on all lisps, no stop" - (with-all-lisps (l lisps) (ignore-errors (test-scripts l)))) + (with-all-lisps (l lisps :fail-fast nil) (test-scripts l))) (deftestcmd test-all-upgrade-no-stop (upgrade-lisps) "test-upgrade on all lisps, no stop" - (with-all-lisps (l upgrade-lisps) (ignore-errors (test-upgrade l)))) + (with-all-lisps (l upgrade-lisps :fail-fast nil) (test-upgrade l))) (deftestcmd test-all-no-upgrade-no-stop () "all tests but upgrade on all lisps, no stop" - (all-pass - (doc) (test-load-systems) - (test-all-clean-load) - (test-all-scripts-no-stop) - (check-all-scripts-results))) + (without-stopping () + (doc) (test-load-systems) + (test-all-clean-load) + (test-all-scripts-no-stop) + (check-all-scripts-results))) (deftestcmd test-all-no-stop () ;; TODO: pass arguments! "all tests on all lisps, no stop" - (all-pass - (doc) (test-load-systems) - (test-all-clean-load) - (test-all-scripts-no-stop) - (test-all-upgrade-no-stop) - (check-all-results))) + (without-stopping () + (doc) (test-load-systems) + (test-all-clean-load) + (test-all-scripts-no-stop) + (test-all-upgrade-no-stop) + (check-all-results))) (deftestcmd check-all-scripts-results () "were there errors in test scripts?" (with-asdf-dir () - (let ((a (run/lines - `(grep "-L" "[5-9][0-9] passing and 0 failing" - ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l)) - *test-lisps*))))) - (if (null a) (success) - (progn - (format! *error-output* "Unexpected test failures on these implementations:~%~{~A~%~}" a) - nil))))) + (let ((bad-lisps + (run/lines + `(grep "-L" "[5-9][0-9] passing and 0 failing" + ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l)) + *test-lisps*))))) + (failure-if bad-lisps + "Unexpected test failures on these implementations:~%~{~A~%~}" bad-lisps)))) (deftestcmd check-all-upgrade-results () "were there upgrade test failures?" (with-asdf-dir () - (let ((a (run/lines - `(grep "-L" "Upgrade test succeeded for " - ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l)) - *upgrade-test-lisps*))))) - (if (null a) (success) - (progn - (format t "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" a) - nil))))) + (let ((bad-lisps + (run/lines + `(grep "-L" "Upgrade test succeeded for " + ,(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l)) + *upgrade-test-lisps*))))) + (failure-if bad-lisps + "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" bad-lisps)))) (deftestcmd check-all-results () "were there failures in any scripts or upgrade?" - (all-pass (check-all-scripts-results) (check-all-upgrade-results))) - + (without-stopping () + (check-all-scripts-results) (check-all-upgrade-results))) diff --git a/tools/test-basic.lisp b/tools/test-basic.lisp index be7f69791..aece56eb9 100644 --- a/tools/test-basic.lisp +++ b/tools/test-basic.lisp @@ -56,7 +56,7 @@ Use your preferred lisp implementation and check that asdf is loaded without any (deftestcmd test-basic (lisp systems) "basic test: doc, clean-load, load-systems" - (all-pass - (doc) - (test-clean-load lisp) - (test-load-systems lisp systems))) + (without-stopping () + (doc) + (test-clean-load lisp) + (test-load-systems lisp systems))) diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp index ed866f9db..b11bf7a01 100644 --- a/tools/test-environment.lisp +++ b/tools/test-environment.lisp @@ -134,11 +134,10 @@ (return `(defun ,name (&optional ,@largs) ,@decl - ,@inits - ,@body))))) - -(defun all-pass (&rest tests) - (success (every 'identity tests))) + (with-failure-context (,(command-name name)) + ,@inits + ,@body + (success))))))) ;; use return-from ,name to return a value. (defmacro defalias (name real) `(defun ,name (&rest args) @@ -147,7 +146,7 @@ (deftestcmd interactive-command (lisp) (let* ((command (lisp-invocation-arglist :implementation-type lisp :debugger t))) - (cons "rlwrap" command))) + (return-from interactive-command (cons "rlwrap" command)))) (defparameter *default-test-lisps* '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro @@ -181,7 +180,7 @@ log (add-pathname-suffix log (strcat "-" (date-string date))))) (with-output-file (s log) s) ;; create the file ;;(format t "Logging results to ~A" log) - log)) + (return-from newlogfile log))) (defun log! (log fmt &rest args) (let ((msg (apply 'format nil fmt args))) @@ -199,6 +198,13 @@ ;; While we're at it, we also avoid spaces and backslashes. ;; We haven't tested our new Lisp implementation of the test infrastructure on Windows, though. +(defun run* (cmd &rest keys) + (let* ((string (strcat "`" (print-process-spec cmd) "`"))) + (with-failure-context (string) + (apply 'run cmd + :on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c))) + keys)))) + (defun run-test-lisp (activity forms &key (output t) log lisp debugger) ;; Activity is of the form "compiling ASDF", "running this test", etc. (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log) @@ -209,14 +215,16 @@ (output (if (eq output t) *standard-output* output)) (output (if (eq output *stdout*) :interactive output))) (log! log "~A" (print-process-spec command nil)) - (multiple-value-bind (okp out err code) - (run* `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command - ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-( - :input interactive :output output :error-output (or interactive :output) :on-error nil) - (unless interactive - (log! log (if okp - "SUCCEEDED at ~A." - "FAILED at ~A. + (multiple-value-bind (out err code) + (run `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command + ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-( + :input interactive :output output :error-output (or interactive :output) :on-error nil) + (declare (ignore out err)) + (let ((okp (eql code 0))) + (unless interactive + (log! log (if okp + "SUCCEEDED at ~A." + "FAILED at ~A. You can retry ~A with: ~A or more interactively, start with: @@ -227,4 +235,4 @@ then copy/paste: (print-process-spec command nil) (print-process-spec (interactive-command) nil) (compose-copy-paste-string forms))) - (if okp (success) (values nil out err code))))) + (success-if okp "failed at ~A" activity))))) diff --git a/tools/test-scripts.lisp b/tools/test-scripts.lisp index fbbbe4789..ae48132cf 100644 --- a/tools/test-scripts.lisp +++ b/tools/test-scripts.lisp @@ -35,6 +35,7 @@ Use the preferred lisp implementation" (let* ((log (newlogfile "test" lisp))) (log! log "Running the following ~D ASDF test scripts on ~(~A~):~%~{ ~A~%~}" (length test-scripts) lisp test-scripts)) + (without-stopping ()) (and (run-test-lisp "compiling ASDF" @@ -65,7 +66,7 @@ Use the preferred lisp implementation" (incf test-fail) (push i failed-list))) :finally) - (let ((okp (zerop test-fail))) + (let ((failp (plusp test-fail))) (log! log "~ -#--------------------------------------- Using ~A @@ -74,14 +75,23 @@ Ran ~D tests, ~D passed, ~D failed~ -#---------------------------------------~%" lisp n-tests test-pass test-fail (reverse failed-list)) - (unless okp + (when failp (log! log "To view full results and failures, try the following command: less -p ABORTED ~A" (enough-namestring log (pn)))) - (return (success okp))))) + (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 Use the preferred lisp implementation" - (all-pass (doc) (test-clean-load lisp) (test-scripts lisp test-scripts))) + (without-stopping () (doc) (test-clean-load lisp) (test-scripts lisp test-scripts))) -(defalias %t %test) +;;(defalias %t test) + +(deftestcmd %t () + (with-failure-context ("foo") + (without-stopping () + (with-failure-context ("1") (error "bar")) + (with-failure-context ("2") (error "baz")) + (error "frob") + (with-failure-context ("3") (error "quux")) + (success)))) diff --git a/tools/test-upgrade.lisp b/tools/test-upgrade.lisp index 989b8d204..e954e31a7 100644 --- a/tools/test-upgrade.lisp +++ b/tools/test-upgrade.lisp @@ -140,18 +140,18 @@ Use the preferred lisp implementation" (map () 'delete-file (directory* pattern)))) (loop :for tag :in upgrade-tags :do (loop :for method :in upgrade-methods + :for description + = (format nil "Testing ASDF upgrade on ~(~A~) from ~A to ~A using method ~(~{~A~^:~}~)" + lisp tag *version* method) :when (valid-upgrade-test-p lisp tag method) :do - (unless (and - (extract-tagged-asdf tag) - (run-test-lisp - (format nil "Testing ASDF upgrade on ~(~A~) from ~A to ~A using method ~(~{~A~^:~}~)" - lisp tag *version* method) - `((load "test/script-support.lisp") - (asdf-test::test-upgrade ,@method ,tag)) - :lisp lisp :log log)) - (return-from test-upgrade nil))) - :finally (log! log "Upgrade test succeeded for ~(~A~)" lisp)) - (return (success)))) + (failure-if (and + (extract-tagged-asdf tag) + (run-test-lisp description + `((load "test/script-support.lisp") + (asdf-test::test-upgrade ,@method ,tag)) + :lisp lisp :log log)) + description)) + :finally (log! log "Upgrade test succeeded for ~(~A~)" lisp)))) (defalias u test-upgrade) -- GitLab