Commit 42f86c0b authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Moving the build & test code from Makefile + shell to Lisp:

fixing bugs, moving asdf-builder into tools and splitting it into
minimal script itself and Lisp source.
parent db16661b
# -*- Makefile -*- This minimal Makefile delegates most work to the meta-asdf script
# Users, all you need to do is:
# -*- Makefile -*- This minimal Makefile delegates most work to the asdf-tools script
#
# End-Users, all you need to do is:
# make
# Other targets are for the maintainer to use.
#
# Vendors, you may want to test your implementation with:
# make test l=sbcl
#
# Other targets are for maintainer use only.
#
# Default action: bootstrap asdf.lisp
# That's the only thing that we really need before we may invoke asdf-builder.
......@@ -33,10 +33,13 @@ defsystem-files:
### exclude source files from fallback rule.
%.lisp:
@:
Makefile:
@:
### Default fall back rule: delegate to asdf-builder.
### Default fall back rule: delegate to asdf-tools.
%: build/asdf.lisp
@echo "Delegating $@ to asdf-builder" ; ./bin/asdf-builder $@
@echo "Delegating $@ to asdf-tools" ; \
./tools/asdf-tools make-target $@ l="$l" L="$L" u="$u" U="$u" v="$v" s="$s" t="$t"
.PHONY: all driver-files defsystem-files
This diff is collapsed.
This diff is collapsed.
......@@ -628,7 +628,6 @@ is bound, write a message and exit on an error. If
(defun test-upgrade (old-method new-method tag) ;; called by run-test
(with-test ()
(verbose t nil)
(setf tag (string tag))
(when old-method
(cond
((string-equal tag "REQUIRE")
......@@ -639,7 +638,7 @@ is bound, write a message and exit on an error. If
(leave-test "Your Lisp implementation does not provide ASDF. Skipping test.~%" 0)))
(t
(format t "Loading old asdf ~A via ~A~%" tag old-method)
(funcall old-method tag))))
(acall (list old-method :asdf-test) tag))))
(when (find-package :asdf)
(configure-asdf))
(when (and (null old-method) (eq 'load-asdf-fasl new-method) (not (probe-file (asdf-fasl))))
......@@ -647,7 +646,7 @@ is bound, write a message and exit on an error. If
(leave-test "Your failed to compile ASDF before your run (test-upgrade ()'load-asdf-fasl ...)" 1)
(leave-test "Your Lisp doesn't provide ASDF. Skipping (test-upgrade ()'load-asdf-fasl ...)" 0)))
(format t "Now loading new asdf via method ~A~%" new-method)
(funcall new-method)
(acall (list new-method :asdf-test))
(format t "Testing it~%")
(register-directory *test-directory*)
(load-test-system :test-asdf/all)
......
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation
;;;;; Can also be invoked by cl-launch 4: cl-launch -sp asdf-tools -r restart -- "$@"
(in-package :cl-user) ;; That may be default, but let's make double sure and tell SLIME.
;;; Ensure we load and configure this particular ASDF
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :cl-launch *features*) ;; (not necessary if we're invoked via cl-launch)
(load (make-pathname
:name "load-asdf" :type "lisp" :defaults
(or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*))))))
;;; ASDF3 is loaded, now use it!
(eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:load-system :asdf-tools))
;;; Actually run the stuff!
(uiop:restore-image :entry-point 'asdf-tools::entry-point)
(defsystem "asdf-tools"
:description "tools to build, test, maintain and release ASDF itself"
:depends-on ((:version "asdf" "3.1.2")
(:version "inferior-shell" "2.0.0")
(:version "cl-ppcre" "2.0.4")
(:version "lisp-invocation" "1.0.2"))
:components
((:file "package")
(:file "pathnames" :depends-on ("package"))
(:file "git" :depends-on ("package"))
(:file "build" :depends-on ("pathnames"))
(:file "version" :depends-on ("pathnames"))
(:file "release" :depends-on ("version"))
(:file "invoke-lisp" :depends-on ("package"))
(:file "test-environment" :depends-on ("pathnames" "invoke-lisp"))
(: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 "main" :depends-on ("package"))))
(in-package :asdf-tools)
(defun build-asdf ()
"Make sure asdf.lisp is built"
(load-system :asdf)
(values))
;;; Documentation
(defun doc ()
(run '(make) :directory (pn "doc/")))
(defun website ()
(run '(make website) :directory (pn "doc/")))
;;; Line counting
(defun wc ()
(with-asdf-dir ()
(run `(pipe (wc ,@(driver-files)) (sort -n)))
(terpri)
(run `(pipe (wc header.lisp ,@(asdf-defsystem-files)) (sort -n)))
(terpri)
(run `(pipe (wc header.lisp ,@(driver-files) ,@(asdf-defsystem-files)) (tail -n 1)))))
(in-package :asdf-tools)
;;; Using git
;; 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 git (cmd &rest args)
(with-asdf-dir ()
(apply 'run (cons "git" cmd) args)))
(defun clean ()
(git '(clean -xfd))
(values))
(defun %push ()
"Push git branches master and release to cl.net and master"
(dolist (x '((status)
(push --tags cl.net release master)
(push --tags github release master)
(fetch)
(status)))
(apply 'git x)))
(defun merge-master-into-release ()
"Merge master into release"
(dolist (x '((checkout master)
(merge release)
(checkout release)
(merge master)
(checkout master)))
(apply 'git x)))
(defparameter *wrongful-tags*
'("1.37" ;; It's not asdf.lisp 1.37, it's asdf.lisp 1.85! 1.37 was the CVS version of the README.
"1.1720" ;; That was a typo for 1.720
"RELEASE" "STABLE" ;; These were misguided attempts for what should have been branches
"README" "emp")) ;; Mistakes
(defun fix-local-git-tags ()
"Delete wrongful tags from local repository"
(dolist (tag *wrongful-tags*)
(git `(tag -d ,tag) :on-error t)))
(defun fix-remote-git-tags (&optional (remote "origin"))
"Delete wrongful tags from remote repository"
(dolist (tag *wrongful-tags*)
(git `(push ,remote (:refs/tags/,tag)) :on-error t)))
(defun git-all-committed-p ()
"Is your checkout clean, with all files committed?"
(null (git '(status -s) :output :lines)))
(defun check-git-all-committed ()
(or (git-all-committed-p)
(die 2 "Your git checkout isn't clean and all committed:~%~A~%"
(git '(status) :output :string))))
":" ; exec cl-launch "$0" "$@"
#| -*- Lisp -*-
Usage: make && cl-launch -l lispworks bin/install-asdf-as-module
":" ; exec cl-launch "$0" "$@" # -*- Lisp -*-
#|
Usage: ./tools/asdf-tools install-asdf-as-module l=lispworks
This script will install the current version of ASDF
as a module pre-compiled for your implementation,
......@@ -22,12 +22,13 @@ It notably doesn't work on:
* Corman Lisp, RMCL, Genera, that are obsolete anyway.
|#
(ignore-errors (funcall 'require "asdf")) ;; Load the implementation-provided ASDF
#-asdf2 (load (merge-pathnames ;; Fall back to loading ASDF manually
(make-pathname :name "asdf" :type "lisp" :version nil
:directory '(:relative :back "build") :defaults *load-pathname*)
*load-pathname*))
(asdf:load-system :asdf) ;; Upgrade to the latest ASDF3 (assumes you have it configured properly)
;;; Ensure we load and configure this particular ASDF
#-cl-launch
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (member :cl-launch *features*) ;; (not necessary if we're invoked via cl-launch)
(load (make-pathname
:name "load-asdf" :type "lisp" :defaults
(or *compile-file-truename* *load-truename* (truename *default-pathname-defaults*))))))
(in-package :asdf)
......
This diff is collapsed.
This diff is collapsed.
;;;; Generic code to interface a Lisp script to the shell command-line.
(in-package :asdf-tools)
(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)
"Find the function for an asdf-builder command by name"
(block nil
(flet ((try (x)
(multiple-value-bind (sym foundp)
(find-symbol* (string-upcase x) :asdf-tools nil)
(when (and sym (eq foundp :internal) (fboundp sym))
(return (fdefinition sym))))))
(try (strcat "%" x)) ;; so that you may use load, t, etc., as targets
(try x))))
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
(defun main (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)))))
(when results
(format t "~&~{~S~%~}" results))
(return (first results))))
(format t "Command ~A not found~%" (first args))
(return)))
(defun entry-point ()
(setf *lisp-interaction* nil)
(uiop:with-fatal-condition-handler ()
(initialize-environment)
(main *command-line-arguments*)))
(defpackage :asdf-tools
(:use :common-lisp :uiop :asdf :fare-utils :inferior-shell :lisp-invocation :cl-ppcre))
;; Just so we can use the name in our test scripts...
(defpackage :asdf-test
(:use :common-lisp))
(in-package :asdf-tools)
;;; ASDF directory
(defvar *asdf-dir*
(ensure-pathname (system-relative-pathname :asdf/defsystem ())
:want-physical t :want-absolute t
:want-existing t :truename t))
(defun pn (&rest x)
(subpathname *asdf-dir* (and x (uiop:resolve-relative-location x))))
(defun nn (&rest x)
(native-namestring (apply 'pn x)))
(defun call-with-asdf-dir (thunk &rest subs)
(with-current-directory ((apply 'pn subs))
(funcall thunk)))
(defmacro with-asdf-dir ((&rest subs) &body body)
`(call-with-asdf-dir (lambda () ,@body) ,@subs))
(in-package :asdf-tools)
;;; Getting a list of source files in a system
(defun enough-namestring! (base pathname)
(let ((e (enough-namestring base pathname)))
(assert (relative-pathname-p e))
e))
(defun enough-namestrings (base pathnames)
(loop :with b = (ensure-pathname base :want-absolute t :want-directory t)
:for p :in pathnames
:collect (enough-namestring! p b)))
(defun system-source-files (system &key monolithic)
(let* ((sys (find-system system))
(components
(required-components system
:other-systems monolithic
:goal-operation 'load-op
:keep-operation 'load-op
:keep-component 'file-component))
(dir (ensure-pathname
(system-source-directory sys)
:want-absolute t :want-directory t))
(pathnames (mapcar 'component-pathname components)))
(enough-namestrings dir pathnames)))
;;; Making release tarballs for asdf, asdf/defsystem, uiop.
(defun tarname (name) (strcat name ".tar.gz"))
(defun make-tarball-under-build (name base files)
(check-type name string)
(ensure-pathname base :want-absolute t :want-existing t :want-directory t)
(dolist (f files)
(check-type f string))
(let* ((base
(ensure-pathname
base
:want-absolute t :want-directory t
:want-existing t :truename t))
(destination
(ensure-pathname
name
:defaults (pn "build/")
:want-relative t :ensure-absolute t
:ensure-subpath t :ensure-directory t))
(tarball
(ensure-pathname
(tarname name)
:defaults (pn "build/")
:want-relative t :ensure-absolute t
:ensure-subpath t :want-file t
:ensure-directories-exist t)))
(assert (< 6 (length (pathname-directory destination))))
(when (probe-file* destination)
(error "Destination ~S already exists, not taking chances - you can delete it yourself."
destination))
(ensure-directories-exist destination)
(run `(cp "-pHux" --parents ,@files ,destination) :directory base :show t)
(run `(tar "zcfC" ,tarball ,(pn "build/") (,name /)) :show t)
(delete-directory-tree destination :validate (lambda (x) (equal x destination)))
(values)))
(defun driver-files ()
(list* "README" "uiop.asd" "asdf-driver.asd" (system-source-files :uiop)))
(defun driver-name ()
(format nil "uiop-~A" *version*))
(defun make-driver-tarball ()
(make-tarball-under-build (driver-name) (pn "uiop/") (driver-files)))
(defun asdf-defsystem-files ()
(list* "asdf.asd" "build/asdf.lisp" "version.lisp-expr" "header.lisp"
(system-source-files :asdf/defsystem)))
(defun asdf-defsystem-name ()
(format nil "asdf-defsystem-~A" *version*))
(defun make-asdf-defsystem-tarball ()
(build-asdf)
(make-tarball-under-build (asdf-defsystem-name) (pn) (asdf-defsystem-files)))
(defun asdf-git-name ()
(strcat "asdf-" *version*))
(defun make-git-tarball ()
(build-asdf)
(with-asdf-dir ()
(run `(tar zcf ("build/" ,(asdf-git-name) ".tar.gz") build/asdf.lisp ,@(run/lines '(git ls-files))
(asdf-git-name)) :show t))
(values))
(defun asdf-lisp-name ()
(format nil "asdf-~A.lisp" *version*))
(defun make-asdf-lisp ()
(build-asdf)
(concatenate-files (list (pn "build/asdf.lisp"))
(pn "build/" (asdf-lisp-name))))
(defun make-archive ()
(make-driver-tarball)
(make-asdf-defsystem-tarball)
(make-git-tarball)
(make-asdf-lisp)
(values))
;;; Publishing tarballs onto the public repository
(defvar *clnet* "common-lisp.net")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")
(defun public-path (x) (strcat *clnet-asdf-public* x))
(defun publish-archive ()
(let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
(run `(rsync ,@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/
~%")
(values))
(defun link-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*)
(values))
(defun make-and-publish-archive ()
(make-archive)
(publish-archive)
(link-archive))
(defun archive () "alias for make-and-publish-archive" (make-and-publish-archive))
(defun install () "alias for make-and-publish-archive" (make-and-publish-archive))
;;; Making a debian package
(defun debian-package (&optional (release "release"))
(let* ((debian-version (debian-version-from-file release))
(version (version-from-file release)))
(unless (cl-ppcre:register-groups-bind (x epoch ver rel)
("^(([0-9]+):)?([0-9.]+)-([0-9]+)$" debian-version)
(declare (ignorable x epoch rel))
(equal ver version))
(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)))
(defun release ()
"Release the code (not implemented)"
#| RELEASE or PUSH checklist:
make test-all
make test-load-systems s=fare-all
make bump v=3.0
edit debian/changelog # RELEASE only...
git commit
git tag 3.0 # for example ...
make debian-package
git push
git push origin 3.0 # for example...
everything from here for RELEASE only
make release-push archive website debian-package
dput mentors ../*.changes
send debian mentors request
send announcement to asdf-announce, asdf-devel, etc.
Move all fixed bugs from Fix Committed -> Fix Released on launchpad
|#
(die 42 "release is not implemented yet"))
(in-package :asdf-tools)
(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)))))
(defmacro with-all-lisps ((&rest maybe-lisps) &body body)
`(call-with-all-lisps (lambda () ,@body) ,@maybe-lisps))
(deftestcmd test-all-clean-load ()
"test that all lisp implementations can load asdf cleanly without any output message"
(with-all-lisps () (test-clean-load)))
(deftestcmd test-all-lisp ()
"test that all lisp implementations pass all asdf test scripts"
(with-all-lisps () (test-scripts)))
(deftestcmd test-all-no-upgrade ()
"test that all lisp implementations pass all normal asdf; also test-basic"
(all-pass (test-basic) (test-all-lisp)))
(deftestcmd test-all-upgrade ()
"test that all lisp implementations pass all asdf upgrade tests"
(with-all-lisps (*upgrade-test-lisps*) (test-upgrade)))
(deftestcmd test-all-lisps ()
"test that all lisp implementations pass all asdf tests"
(all-pass (test-all-no-upgrade) (test-all-upgrade)))
(defalias test-all test-all-lisps)
(deftestcmd test-all-lisp-no-stop ()
"test that all lisp implementations pass all asdf test scripts, but don't stop on error"
(with-all-lisps ()
(ignore-errors (test-scripts))))
(deftestcmd test-all-upgrade-no-stop ()
"test that all lisp implementations pass all asdf upgrade tests, but don't stop on error"
(with-all-lisps (*upgrade-test-lisps*)
(ignore-errors (test-upgrade))))
(deftestcmd test-all-no-upgrade-no-stop ()
"test that all lisp implementations pass all normal asdf tests (no upgrade), but don't stop on error."
(all-pass
(test-basic)
(test-all-clean-load)
(test-all-lisp-no-stop)
(check-all-test-results)))
(deftestcmd test-all-no-stop ()
"test that all lisp implementations pass all asdf tests (including upgrade), but don't stop on error."
(all-pass
(test-basic)
(test-all-clean-load)
(test-all-lisp-no-stop)
(test-all-upgrade-no-stop)
(check-all-results)))
(deftestcmd check-all-test-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*)))))
(or (null a)
(progn
(format! *error-output* "Unexpected test failures on these implementations:~%~{~A~%~}" a)
nil)))))
(deftestcmd check-all-upgrade-results ()
"were there upgrade tests 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*)))))
(or (null a)
(progn
(format t "Unexpected upgrade failures on these implementations:~%~{~A~%~}~%" a)
nil)))))
(deftestcmd check-all-results ()
"check that there were no errors in either test scripts or upgrade tests"
(all-pass (check-all-test-results) (check-all-upgrade-results)))
(in-package :asdf-tools)
(deftestcmd %load (lisp) ;; load would be a clash, so use %load instead
"make load will start a Lisp and load ASDF from individual source files.
This is great to quickly locate compilation errors and interactively debug ASDF."
(with-asdf-dir ()
(run-test-lisp
(format nil "loading ASDF into an interactive ~(~A~)" lisp)
`((load "test/script-support.lisp")
(asdf-test::interactive-test
',(system-source-files :asdf/defsystem :monolithic t)))
:lisp lisp :debugger t :output :interactive)))
(deftestcmd test-load-systems (lisp systems)
"test that the preferred lisp implementation can load your favorite systems without error"
(with-asdf-dir ()
(let* ((log (newlogfile "systems" lisp)))
(log! log "Loading all these systems on ~(~A~):~{~% ~A~}~%~%" lisp systems)
(run-test-lisp
"loading the systems"
`((load "test/script-support.lisp")
(asdf-test::with-test () (asdf-test::test-load-systems ,@systems)))
:lisp lisp :log log))))
(deftestcmd test-clean-load (lisp log)
"test that the preferred lisp implementation can load asdf cleanly without any output message"
(nest
(block ()
(case lisp ((:gcl :cmucl) (return t)))) ;; These are hopeless
(with-asdf-dir ())
(let ((nop (newlogfile "nop" lisp))
(load (newlogfile "load" lisp)))
(run-test-lisp
(format nil "Starting ~(~A~), loading the script support, and exiting without doing anything" lisp)
`((load "test/script-support.lisp" :verbose nil :print nil)
(asdf-test::exit-lisp 0))
:lisp lisp :output nop :log log)
(run-test-lisp
(format nil "Starting ~(~A~), loading the script support, loading ASDF from source, then exiting" lisp)
`((load "test/script-support.lisp" :verbose nil :print nil)
(load "build/asdf.lisp" :verbose nil :print nil)
"(uiop/image:quit 0)")
:lisp lisp :output load :log log)
(if (nth-value 2 (run `(diff ,nop ,load)
:output :interactive :error-output :output :input nil))
(progn
(log! log "GOOD: Loading ASDF on ~(~A~) produces no message" lisp)
(return t))
(progn
(log! log "BAD: Loading ASDF on ~(~A~) produces messages" lisp)
(return nil))))))
;;; BONUS: install asdf as module for your favorite Lisp implementation.
(deftestcmd install-asdf-as-module (lisp)
(flet ((doit ()
(with-asdf-dir ()
(run-test-lisp
(format nil "Installing ASDF to be provided as a module on ~(~A~)" lisp)
'((load "tools/install-asdf-as-module")(uiop:quit))
:lisp lisp))))
(case lisp
((:allegro :allegromodern :ccl :clisp :cmucl :lispworks :sbcl :scl :xcl)
(doit))
((:abcl :ecl :ecl_bytecodes :mkcl)
(format t "Upgrading the implementation-provided ASDF on ~(~A~) isn't supported (yet).
Happily, that implementation is known to keep ASDF reasonably up to date.~%" lisp))
((:cormancl :gcl :genera :mcl :mocl)
(format t "Installing ASDF so it is provided by ~(~A~) isn't supported.
If you care, go hack the implementation.~%" lisp))
(otherwise
(if (string-prefix-p "allegro" (string-downcase lisp))
(doit)
(error "Unknown implementation ~(~A~)" lisp))))))
(deftestcmd test-basic (lisp systems)
"basic smoke test"
(doc)
(test-clean-load lisp)
(test-load-systems lisp systems))
(in-package :asdf-tools)
;;; Testing
(defparameter *test-lisps* :default
"The list of lisp implementations to use for tests")
(defparameter *upgrade-test-lisps* :default
"The list of lisp implementations to use for upgrade tests")
(defparameter *upgrade-test-tags* :default)
(defparameter *test-systems* nil)
(defparameter *test-scripts* :default)
(defparameter *environment-variable-table* nil)
(defparameter *environment-variable-specs*
'((*test-lisps* ensure-list-of-keywords :default
"ASDF_TEST_LISPS" "l")
(*upgrade-test-lisps* ensure-list-of-keywords :default
"ASDF_UPGRADE_TEST_LISPS" "L")
(*test-systems* ensure-list-of-keywords ()
"ASDF_TEST_SYSTEMS" "s")
(*test-scripts* ensure-list-of-strings :default
"ASDF_TESTS" "t")
(*upgrade-test-tags* ensure-list-of-strings :default
"ASDF_UPGRADE_TEST_TAGS" "u")
(*upgrade-test-methods* ensure-list-of-test-methods :default
"ASDF_UPGRADE_TEST_METHODS" "U")
(*new-version* string :default
"=NEW_ASDF_VERSION" "v")))
(defun ensure-list-of-strings (x)
(remove nil
(etypecase x
(string (uiop:split-string x :separator " "))
(list x))))
(defun ensure-keyword (x)
(etypecase x
((or null keyword) x)
((or string symbol) (intern (string-upcase x) :keyword))))
(defun ensure-list-of-keywords (x)
(mapcar 'ensure-keyword (ensure-list-of-strings x)))
(defun ensure-test-method (x)
(safe-read-from-string (strcat "(" (substitute #\space #\: x) ")") :package :keyword)) ; UGLY!
(defun ensure-list-of-test-methods (x)
(mapcar 'ensure-test-method (ensure-list-of-strings x)))
(defun initialize-environment ()
(let ((h (make-hash-table :test 'equal)))
(setf *environment-variable-table* h)
(loop :for (variable transformer defaults envvar short) :in *environment-variable-specs*
:for x = (list variable transformer)
:do (setf (symbol-value variable)
(if-let (x (getenvp envvar))
(funcall transformer x)
defaults))
(setf (gethash envvar h) x)
(setf (gethash short h) x))))
(defun test-definition (def)
(block ()
(cl-ppcre:register-groups-bind (var val) ("^([^=]+)=(.*)$" def)
(if-let (x (gethash var *environment-variable-table*))
(destructuring-bind (sym transformer &rest r) x
(declare (ignore r))
(unless (emptyp val)
(setf (symbol-value sym) (funcall transformer val)))
(return))
(error "Unknown variable ~A" var)))
(error "Unrecognized argument ~A" def)))
(defun show-environment ()
(loop :for (v) :in *environment-variable-specs* :do
(format t "~A = ~S~%" v (symbol-value v)))
t)