Commit a0317bc1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Remember failures and show them at the end.

parent 69c76bfe
......@@ -24,6 +24,7 @@ doc/asdf.vrs
......@@ -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.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}
......@@ -8,16 +8,17 @@
(:feature :sbcl "sb-introspect"))
((: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"))))
(in-package :asdf-tools)
(defun build-asdf ()
(deftestcmd build-asdf ()
"make sure asdf.lisp is built"
(load-system :asdf)
(load-system :asdf))
;;; Documentation
(defun doc ()
(deftestcmd doc ()
"build documentation in doc/ directory"
(run '(make) :directory (pn "doc/"))
(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/"))
(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)))
(run `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
(run* `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
(run `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1))))))
(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))
'string< :key 'car)))
;;;; 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"
((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
(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)
(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
(setf *failures* (append (failure-list failure) *failures*)))
(push failure *failures*)))
(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))
(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))))
......@@ -4,22 +4,15 @@
;; Note that the debian git at git:// is stale,
;; as we currently build directly from upstream at git://
(defun run* (cmd &rest keys)
(multiple-value-bind (out err code)
(apply 'run cmd keys)
(if (eql 0 code)
(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 release master)
......@@ -28,7 +21,7 @@
(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))))
......@@ -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
;;;; 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."
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~%")
(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.
((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))
(if args
(format t "Command ~A not found~%" (first args))
(format t "No command provided~%"))
;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main
(defun main (argv)
......@@ -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)))
(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
(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)))
(run* `(gzip -f9 ,tarball) :show t))))
(defun uiop-files ()
"list files in uiop"
......@@ -74,7 +72,7 @@
(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 ()
(concatenate-files (list (pn "build/asdf.lisp"))
(pn "build/" (asdf-lisp-name)))
(pn "build/" (asdf-lisp-name))))
(defun make-archive ()
(deftestcmd make-archive ()
"build tarballs for release"
;;; 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:~%
(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")
(public-path "archives/asdf.lisp"))
:show t :host *clnet*)
(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")
(public-path "archives/asdf.lisp"))
:show t :host *clnet*))
(deftestcmd make-and-publish-archive ()
"make and publish tarballs"
......@@ -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))
(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-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
:directory (pn) :show t))
(run* `(git-buildpackage
;; --git-ignore-new ;; for testing purpose
(--git-debian-branch= ,release)
;;--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
: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"))))
(log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad")))))
(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))))