Commit 97927dc4 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Refactor how asdf-tools represents success.

Don't re-bind special variable in with-all-lisps.
parent 9d53233a
......@@ -3,18 +3,17 @@
# End-Users, all you need to do is:
# make
#
# If you want a list of all of the new targets, use
# make help
#
# Vendors, you may want to test your implementation with:
# make test l=sbcl
# BUT you first need have installed the development-time external dependencies of ASDF,
# which will be done automatically if you are using quicklisp,
# which you can do manually with your favorite tools (e.g. clbuild or git), or
# which you can do using `git submodule update` which is also available as:
# BUT you first need have installed the development-time external dependencies of ASDF;
# this will be done automatically if you are using quicklisp;
# you can do it manually with your favorite tools (e.g. clbuild or git);
# or you can do it using `git submodule update` which is also available as:
# make ext
# To undo the `git submodule update` you can use: `make noext`
#
# Other targets are for maintainer use only.
# Other targets are for maintainer use only. If you want a list of all of the targets, use
# make help
#
# Default action: bootstrap asdf.lisp
......
......@@ -3,18 +3,18 @@
(defun build-asdf ()
"make sure asdf.lisp is built"
(load-system :asdf)
(values))
(success))
;;; Documentation
(defun doc ()
"build documentation in doc/ directory"
(run '(make) :directory (pn "doc/"))
(values))
(success))
(defun website ()
"publish documentation onto the public website"
(run '(make website) :directory (pn "doc/"))
(values))
(success))
;;; Line counting
......@@ -29,11 +29,12 @@
(run `(pipe (wc header.lisp ,@defsystem-files) (sort -n)))
(terpri)
(run `(pipe (wc header.lisp ,@driver-files ,@defsystem-files) (tail -n 1))))))
(values))
(success))
;;; debug the source registry that is being used to execute these tools.
(defun list-source-registry ()
"Display the source-registry cache"
(writeln (sort (alexandria:hash-table-alist asdf::*source-registry*)
'string< :key 'car)))
'string< :key 'car))
(success))
......@@ -7,7 +7,9 @@
(defun run* (cmd &rest keys)
(multiple-value-bind (out err code)
(apply 'run cmd keys)
(values (eql 0 code) out err code)))
(if (eql 0 code)
(success)
(values nil out err code))))
(defun git (cmd &rest keys)
(with-asdf-dir ()
......
......@@ -222,4 +222,3 @@ a preformatted string, or a LIST that specifies a program."
(typecase x (string x)
(t (write-to-string x))))
forms)))))))
;;;; 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)"
(eval (read-from-string arg)))
(defun find-command (x &optional earlyp)
"Find the function for an asdf-tools command by name"
(defun find-command (name &optional earlyp)
"Given a string NAME, find the symbol for the function that implements the command, or else NIL.
Unless EARLYP is true, return NIL if the symbol is not fbound."
(block nil
(flet ((try (x)
(multiple-value-bind (sym foundp)
(find-symbol* (string-upcase x) :asdf-tools nil)
(when (and sym (or earlyp (and foundp (fboundp sym))))
(return sym)))))
(try (strcat "%" (string x))) ;; so that you may use load, t, etc., as targets
(try x))))
(try (strcat "%" (string name))) ;; so that you may use load, t, etc., as targets
(try name))))
(defun command-name (x &optional earlyp)
"Given a command designator as per FIND-COMMAND, return the unix-y name for it, as a string"
(let ((c (find-command x earlyp)))
(when c
(let ((s (string-downcase c)))
......@@ -55,7 +68,7 @@
(defun show-commands ()
"print the (sorted list of) names of all the public commands of asdf-tools."
(format t "~{~A~^ ~}~%" (public-command-strings))
(values))
(success))
(defun makefile-targets ()
"print declaration for the public commands of asdf-tools as as many Makefile targets
......@@ -64,7 +77,7 @@ based on a list of targets"
(let ((c (public-command-strings)))
(format t ".PHONY: ~{~A~^ ~}~%~%~{~A~^ ~}: force
./tools/asdf-tools env l='$l' L='$L' u='$u' U='$u' v='$v' s='$s' t='$t' $@~%" c c))
(values))
(success))
(defun help (&optional x)
"help about a command, or list of commands"
......@@ -73,7 +86,7 @@ based on a list of targets"
(loop :for x :in (public-command-strings)
:do (format t "~(~27A~)~@[ ~A~]~%"
x (short-function-description x)))
(values))
(success))
(t
(let ((x (find-command x)))
(when x
......@@ -81,7 +94,7 @@ based on a list of targets"
(command-name x)
(or ()) ;; TODO: remember the arguments to deftestcmd, translate to v=, etc
(documentation x 'function))
(values))))))
(success))))))
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
......@@ -91,13 +104,15 @@ based on a list of targets"
(format t "No command provided~%")
(return))
(if-let ((fun (find-command (first args))))
(let ((results
(multiple-value-list (apply fun (rest args)))))
(when results
(format t "~&~{~S~%~}" results))
(return (or (null results) (first results))))) ;; Trick: (values) counts as T, not NIL.
(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)))
(return nil)))
;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main
(defun main (argv)
......
......@@ -36,7 +36,7 @@
(let ((tarball (strcat name "." type)))
(run `(git archive -o ,(pn "build" tarball)
:prefix (,name /) ,*version* -- ,@files) :show t)))
(values))
(success))
(defun make-tarball-from-git-plus (name base files &key asdf-lisp version-file)
;; make a tarball, then add build/asdf.lisp to it
......@@ -63,7 +63,7 @@
(let ((dir (pn "build" name "")))
(when (directory-exists-p dir) (delete-empty-directory dir)))
(run `(gzip -f9 ,tarball) :show t)))
(values))
(success))
(defun uiop-files ()
"list files in uiop"
......@@ -99,7 +99,8 @@
(defun make-asdf-lisp ()
(build-asdf)
(concatenate-files (list (pn "build/asdf.lisp"))
(pn "build/" (asdf-lisp-name))))
(pn "build/" (asdf-lisp-name)))
(success))
(defun make-archive ()
"build tarballs for release"
......@@ -107,7 +108,7 @@
(make-asdf-defsystem-tarball)
(make-git-tarball)
(make-asdf-lisp)
t)
(success))
;;; Publishing tarballs onto the public repository
......@@ -125,7 +126,7 @@
(format t "~&To download the tarballs, point your browser at:~%
http://common-lisp.net/project/asdf/archives/
~%")
t)
(success))
(defun link-archive ()
"symlink new tarballs on the website"
......@@ -139,7 +140,7 @@
(asdf-lisp-name)
(public-path "archives/asdf.lisp"))
:show t :host *clnet*)
t)
(success))
(defun make-and-publish-archive ()
"make and publish tarballs"
......@@ -170,7 +171,8 @@
;; --git-no-pristine-tar
--git-force-create
--git-ignore-branch)
:directory (pn) :show t)))
:directory (pn) :show t))
(success))
(defun debian-architecture ()
(run/ss `(dpkg --print-architecture)))
......@@ -182,7 +184,7 @@
(run* `(dput mentors ,(pn "../" changes)))))
(deftestcmd release (new-version lisps scripts systems)
"all steps to release the code (not implemented)"
"all steps to release the code (NOT YET IMPLEMENTED)"
(break) ;; for each function, offer to do it or not (?)
(with-asdf-dir ()
(let ((log (newlogfile "release" "all"))
......@@ -212,4 +214,5 @@
(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"))))
(success))
......@@ -2,41 +2,39 @@
(defun call-with-all-lisps (thunk &optional (lisps *test-lisps*))
(apply 'all-pass
(loop :for lisp :in lisps
:collect (let ((*test-lisps* (list lisp))) (funcall thunk)))))
(loop :for lisp :in (get-lisps lisps)
:collect (funcall thunk lisp))))
(defmacro with-all-lisps ((&rest maybe-lisps) &body body)
`(call-with-all-lisps (lambda () ,@body) ,@maybe-lisps))
(defmacro with-all-lisps ((&optional (lisp-var 'lisp) (lisps '*test-lisps*)) &body body)
`(call-with-all-lisps (lambda (,lisp-var) ,@body) ,lisps))
(deftestcmd test-all-clean-load ()
(deftestcmd test-all-clean-load (lisps)
"test-clean-load on all lisps"
(with-all-lisps () (test-clean-load)))
(with-all-lisps (l lisps) (test-clean-load l)))
(deftestcmd test-all-scripts ()
(deftestcmd test-all-scripts (lisps)
"test-scripts on all lisps"
(with-all-lisps () (test-scripts)))
(with-all-lisps (l lisps) (test-scripts l)))
(deftestcmd test-all-no-upgrade ()
"test-basic, and test-all-script"
(all-pass (test-basic) (test-all-scripts)))
(deftestcmd test-all-upgrade ()
(deftestcmd test-all-upgrade (upgrade-lisps)
"test-upgrade on all lisps"
(with-all-lisps (*upgrade-test-lisps*) (test-upgrade)))
(with-all-lisps (l upgrade-lisps) (test-upgrade l)))
(deftestcmd test-all ()
"all tests"
(all-pass (test-all-no-upgrade) (test-all-upgrade)))
(deftestcmd test-all-scripts-no-stop ()
(deftestcmd test-all-scripts-no-stop (lisps)
"test-scripts on all lisps, no stop"
(with-all-lisps ()
(ignore-errors (test-scripts))))
(with-all-lisps (l lisps) (ignore-errors (test-scripts l))))
(deftestcmd test-all-upgrade-no-stop ()
(deftestcmd test-all-upgrade-no-stop (upgrade-lisps)
"test-upgrade on all lisps, no stop"
(with-all-lisps (*upgrade-test-lisps*)
(ignore-errors (test-upgrade))))
(with-all-lisps (l upgrade-lisps) (ignore-errors (test-upgrade l))))
(deftestcmd test-all-no-upgrade-no-stop ()
"all tests but upgrade on all lisps, no stop"
......@@ -62,7 +60,7 @@
`(grep "-L" "[5-9][0-9] passing and 0 failing"
,(mapcar (lambda (l) (format nil "build/results/~(~A~)-test.text" l))
*test-lisps*)))))
(or (null a)
(if (null a) (success)
(progn
(format! *error-output* "Unexpected test failures on these implementations:~%~{~A~%~}" a)
nil)))))
......@@ -74,7 +72,7 @@
`(grep "-L" "Upgrade test succeeded for "
,(mapcar (lambda (l) (format nil "build/results/~(~A~)-upgrade.text" l))
*upgrade-test-lisps*)))))
(or (null a)
(if (null a) (success)
(progn
(format t "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" a)
nil)))))
......
......@@ -49,13 +49,14 @@ Use your preferred lisp implementation and check that asdf is loaded without any
:output :interactive :error-output :output :input nil))
(progn
(log! log "GOOD: Loading ASDF on ~(~A~) produces no message" lisp)
(return t))
(return (success)))
(progn
(log! log "BAD: Loading ASDF on ~(~A~) produces messages" lisp)
(return nil))))))
(deftestcmd test-basic (lisp systems)
"basic test: doc, clean-load, load-systems"
(doc)
(test-clean-load lisp)
(test-load-systems lisp systems))
(all-pass
(doc)
(test-clean-load lisp)
(test-load-systems lisp systems)))
......@@ -70,7 +70,7 @@
(loop :for variable-name :in (mapcar 'first *environment-variable-specs*)
:do (format t "~T~S = ~S~%"
variable-name (symbol-value variable-name))))
(values))
(success))
(defun test-definition (def)
(block ()
......@@ -88,7 +88,7 @@
(defun show-environment ()
(loop :for (v) :in *environment-variable-specs* :do
(format t "~A = ~S~%" v (symbol-value v)))
(values))
(success))
(defun env (&rest env)
(loop :for (first . rest) :on env
......@@ -114,6 +114,8 @@
(setf lisp (get-lisp lisp)))
(lisps ((lisps *test-lisps*))
(setf lisps (get-lisps lisps)))
(upgrade-lisps ((lisps *upgrade-test-lisps*))
(setf upgrade-lisps (get-upgrade-lisps lisps)))
(systems ((systems *test-systems*)))
(test-scripts ((test-scripts *test-scripts*))
(setf test-scripts (get-test-scripts test-scripts)))
......@@ -136,7 +138,7 @@
,@body)))))
(defun all-pass (&rest tests)
(every 'identity tests))
(success (every 'identity tests)))
(defmacro defalias (name real)
`(defun ,name (&rest args)
......@@ -162,6 +164,9 @@
(defun get-lisp (&optional (lisp *test-lisps*))
(if (and (keywordp lisp) (not (eq lisp :default))) lisp (first (get-lisps lisp))))
(defun get-upgrade-lisps (&optional (x *upgrade-test-lisps*))
(if (eq x :default) (get-lisps) x))
(defun date-string (&optional (date (get-universal-time)))
(multiple-value-bind (second minute hour date month year weekday daylight-savings-p timezone)
(decode-universal-time date)
......@@ -186,7 +191,7 @@
;; re-open every time because we're interleaved with inferior process writing to the log,
;; and on e.g. Windows there might be a locking conflict if we keep it open.
(format s "~&~A~&" msg))))
(values))
(success))
;; TODO: When composing a form to evaluate in the test lisp implementation,
;; our shell script went through great lengths to avoid a double-quote #\" in the command line,
......@@ -222,4 +227,4 @@ then copy/paste:
(print-process-spec command nil)
(print-process-spec (interactive-command) nil)
(compose-copy-paste-string forms)))
(values okp out err code))))
(if okp (success) (values nil out err code)))))
......@@ -63,20 +63,20 @@ Use the preferred lisp implementation"
(progn
(incf test-fail)
(push i failed-list)))
:finally
(let ((okp (zerop test-fail)))
(log! log "~
:finally)
(let ((okp (zerop test-fail)))
(log! log "~
-#---------------------------------------
Using ~A
Ran ~D tests, ~D passed, ~D failed~
~:[~%All tests apparently successful.~;:~:*~{~% ~A~}~]
-#---------------------------------------~%"
lisp
n-tests test-pass test-fail (reverse failed-list))
(unless okp
(log! log "To view full results and failures, try the following command:
lisp
n-tests test-pass test-fail (reverse failed-list))
(unless okp
(log! log "To view full results and failures, try the following command:
less -p ABORTED ~A" (enough-namestring log (pn))))
(return okp)))))
(return (success okp)))))
(deftestcmd %test (lisp test-scripts)
"run all normal tests but upgrade tests
......
......@@ -2,9 +2,6 @@
;;; Upgrade tests
(defun get-upgrade-lisps (&optional (x *upgrade-test-lisps*))
(if (eq x :default) (get-lisps) x))
(defparameter *default-upgrade-test-tags*
;; We return a list of entries in reverse chronological order,
;; which should also be more or less the order of decreasing relevance.
......@@ -63,11 +60,13 @@ Use at a given tag, put it under build/asdf-${tag}.lisp"
(ensure-directories-exist (pn "build/old/build/"))
(run `(pipe (git archive ,tag) (tar "xfC" - ,(pn "build/old/"))))
(run `(make) :directory (pn "build/old/"))
(rename-file-overwriting-target (pn "build/old/build/asdf.lisp") file))))))))
(rename-file-overwriting-target (pn "build/old/build/asdf.lisp") file)))))))
(success))
(deftestcmd extract-all-tagged-asdf (upgrade-tags)
"extract all asdf tags used for upgrade"
(map () 'extract-tagged-asdf upgrade-tags))
(map () 'extract-tagged-asdf upgrade-tags)
(success))
(defalias extract extract-all-tagged-asdf)
......@@ -142,14 +141,17 @@ Use the preferred lisp implementation"
(loop :for tag :in upgrade-tags :do
(loop :for method :in upgrade-methods
:when (valid-upgrade-test-p lisp tag method) :do
(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))
:finally (log! log "Upgrade test succeeded for ~(~A~)" lisp))))
(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))))
(defalias u test-upgrade)
......@@ -88,7 +88,8 @@
new-contents)))
(check-type written-contents (or string (byte-vector)))
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(format t "done.~%"))))
(success))
(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
......@@ -108,7 +109,8 @@
(maybe-replace-file (pn file) (version-transformer new-version file prefix suffix)))
(defun transform-files (new-version)
(loop :for f :in *versioned-files* :do (apply 'transform-file new-version f)))
(loop :for f :in *versioned-files* :do (apply 'transform-file new-version f))
(success))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (pn file))))
......@@ -118,7 +120,7 @@
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(return (success)))))))
(defun test-transform (new-version)
(apply 'test-transform-file new-version (first *versioned-files*)))
......
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