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.
### 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
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation
;;;;; Can also be invoked by cl-launch 4: cl-launch "$0" "$@"
;;;; This file is conceptually in several parts:
;;;; 1- a header that loads ASDF, even when the implementation might or might not provide it.
;;;; 2- a body that defines various functions used to build and release ASDF
;;;; 3- a footer that makes these Lisp functions available from the shell command-line
;;; The code below exemplifies how to load and configure ASDF
;;; as part of your own deterministic build.
;;; See "User-configurable parts" for where you'd customize it to suit your build.
;;; Everything is MUCH simpler if you can assume your implementation has a recent-enough ASDF 3:
;;; just (require "asdf"), then configure in a subsequent eval-when form,
;;; in which you may then use asdf: and uiop: prefix.
;;; To use the user-configured ASDF rather than a deterministic self-contained project build,
;;; see instead how cl-launch 4.0.4 loads ASDF.
(in-package :cl-user) ;; That may be default, but let's make double sure and tell SLIME.
;; Do everything in eval-when, so this works
;; whether this file is being loaded directly or compiled first.
(eval-when (:compile-toplevel :load-toplevel :execute)
(let ((required-asdf-version "3.0.1") ;; This script wants ASDF 3 (and no beta release).
(verbose *load-verbose*))
(labels ((asdf-symbol (name)
(and (find-package :asdf) (find-symbol (string name) :asdf)))
(asdf-call (name &rest args)
(apply (asdf-symbol name) args))
(asdf-version ()
(when (find-package :asdf)
(or (symbol-value (or (asdf-symbol '*asdf-version*)
(asdf-symbol '*asdf-revision*)))
(subpath (parent &key directory name type version)
;; We need subpath here, because we can't yet assume ASDF 3 and its subpathname
(merge-pathnames (make-pathname :defaults parent
:directory (cons :relative directory)
:name name :type type :version version)
(here-directory ()
(subpath (or *compile-file-truename* *load-truename*
(truename *default-pathname-defaults*))))
(load-and-configure-asdf ()
;; First, try to require ASDF from the implementation, if not already loaded.
;; Most implementations provide ASDF 3.0, LispWorks still lags with ASDF 2.019,
;; and some unmaintained implementations, or obsolete implementations or versions thereof
;; only provide ASDF 2, ASDF 1, or don't provide ASDF.
;; Note that CLISP is case-sensitive, so we need to specify a lowercase string,
;; and not the keyword :asdf or symbol 'asdf; old CLISP versions that don't provide ASDF
;; may error at compile-time if we call (require "asdf") directly.
(ignore-errors (funcall 'require "asdf"))
;; If ASDF 2 isn't provided, load our ASDF from source.
;; ASDF 1 is not enough, because it won't heed our project's output-translations.
;; (Beside, no one serious provides ASDF 1 anymore.)
(unless (member :asdf2 *features*)
(let ((asdf-lisp (asdf-lisp)))
(if (probe-file asdf-lisp)
(load asdf-lisp)
(error "This Lisp implementation fails to provide ASDF 2 or later"))))
;; Configure ASDF
(let ((provided-version (asdf-version)))
;; Upgrade ASDF to what we configured it to be.
(asdf-call 'load-system :asdf)
;; If the implementation-provided version was too old,
;; we need to re-configure, because old configuration may have been moved away.
(unless (asdf-call 'version-satisfies provided-version "2.27")
(unless (asdf-call 'version-satisfies (asdf-version) required-asdf-version)
(error "This program needs ASDF ~A but could only find ASDF ~A"
required-asdf-version (asdf-version))))
;; User-configurable parts
(asdf-lisp ()
;; Here, define where your Lisp source code hierarchy stores its copy of ASDF.
;; In your project, that might be :directory '("libraries" "asdf" "build")
;; Or NIL, if you don't do use any fancy ASDF feature, and
;; trust your implementation to provide a recent enough copy.
(subpath (here-directory) :directory '(:back "build") :name "asdf" :type "lisp"))
(configure-asdf ()
(let* ((source-directory
;; Here, define the top of your Lisp source code hierarchy.
;; If you can assume an implementation that has ASDF 2 or later
;; (you should: all serious ones do), you might compute it based on
;; (asdf-call 'getenv "MY_PROJECT_ROOT") instead of (here-directory).
;; If you can assume an implementation that has ASDF 3 or later
;; (you probably can: most serious ones do), you might use instead
;; (asdf-call 'getenv-pathname "MY_PROJECT_ROOT"
;; :want-absolute t :ensure-directory t)
(subpath (here-directory) :directory '(:back)))
(or (asdf-call 'getenv "ASDF_DEVEL_SOURCE_REGISTRY")
(:tree ,source-directory)
;; In a fully controlled build, you'd :ignore-inherited-configuration instead:
;; There again, you might want to use some getenv variant.
;; Also, "fasls" might be redundant for your project.
(subpath source-directory :directory '("build" "fasls")))
;; Segregate output by ABI.
;; You could replace "asdf" below by the name of your project,
;; or not need it at all if everything is under your source-directory.
(,source-directory (,output-directory :implementation "asdf"))
;; In a fully controlled build, we shouldn't be using code outside
;; our source-directory, but in case we do, we still want to control the output,
;; and easily detect the fact by looking at this directory
(t (,output-directory :implementation "root"))
;; The above should already cover all paths that we use;
;; we don't want user configuration to interfere with the build.
;; No more user-configurable parts below.
(asdf-call 'initialize-source-registry source-registry)
(asdf-call 'initialize-output-translations output-translations))))
;; Configure the printer
(setf *print-readably* nil ; allegro 5.0 may bork without this
*print-level* nil)
;; Hush the compiler and loader
(setf *load-verbose* nil *load-print* nil
*compile-verbose* nil *compile-print* nil)
;; Load and configure ASDF
;;; ASDF3 is loaded, now use it!
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (uiop:featurep :cl-launch) (uiop:restore-image))
(asdf:load-systems :cl-ppcre :fare-utils :inferior-shell))
(defpackage :asdf-builder
(:use :cl :uiop :asdf :cl-ppcre :fare-utils :inferior-shell))
(in-package :asdf-builder)
(defun build-asdf ()
"Make sure asdf.lisp is built"
(load-system :asdf)
;;; 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))
;;; Using git
;; Note that the debian git at git:// is stale,
;; as we currently build directly from upstream at git://
(defun git (cmd &rest args)
(with-asdf-dir ()
(apply 'run (cons "git" cmd) args)))
(defun clean ()
(git '(clean -xfd))
(defun %push ()
"Push git branches master and release to and master"
(with-asdf-dir ()
(dolist (x '((git status)
(git push --tags release master)
(git push --tags github release master)
(git fetch)
(git status)))
(run x))))
(defun merge-master-into-release ()
"Merge master into release"
(with-asdf-dir ()
(dolist (x '((git checkout master)
(git merge release)
(git checkout release)
(git merge master)
(git checkout master)))
(run 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))))
;;; Documentation
(defun doc ()
(run '(make) :directory (pn "doc/")))
(defun website ()
(run '(make website) :directory (pn "doc/")))
;;; Extracting version information
(defparameter *version-tag-glob* "[0-9][.][0-9]*")
(defun version-from-tag (&optional commit)
(git `(describe --tags --match ,*version-tag-glob*)
:output :line :directory (pn)))
(defun version-from-file (&optional commit)
(if commit
(git `(show (,commit":version.lisp-expr")) :output :form)
(safe-read-file-form (pn "version.lisp-expr"))))
(defun debian-version-from-file (&optional commit)
(let ((line
(if commit
(git `(show (,commit":debian/changelog")) :output :line)
(read-file-line (pn "debian/changelog")))))
(cl-ppcre:register-groups-bind (ver) ("^cl-asdf [(]([0-9.:-]+)[)] " line)
(defparameter *version* (version-from-file))
;;; Bumping the version of ASDF
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
("asdf.asd" " :version \"" "\" ;; to be automatically updated by make bump-version")
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defparameter *old-version* nil)
(defparameter *new-version* nil)
(defun next-version (v)
(let ((pv (parse-version v 'error)))
(assert (first pv))
(assert (second pv))
(unless (third pv) (appendf pv (list 0)))
(unless (fourth pv) (appendf pv (list 0)))
(incf (car (last pv)))
(unparse-version pv)))
(defun versions-from-args (&optional v1 v2)
(labels ((check (old new)
(parse-version old 'error)
(parse-version new 'error)
(values old new)))
((and v1 v2) (check v1 v2))
(v1 (check (version-from-file) v1))
(t (let ((old (version-from-file)))
(check old (next-version old)))))))
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
(defun maybe-replace-file (file transformer
&key (reader 'read-file-string)
(writer nil) (comparator 'equalp)
(external-format *utf-8-external-format*))
(format t "Transforming file ~A... " (file-namestring file))
(let* ((old-contents (funcall reader file))
(new-contents (funcall transformer old-contents)))
(if (funcall comparator old-contents new-contents)
(format t "no changes needed!~%")
(let ((written-contents
(if writer
(with-output (s ())
(funcall writer s new-contents))
(check-type written-contents (or string (byte-vector)))
(clobber-file-with-vector file written-contents :external-format external-format)
(format t "done.~%")))))
(defun version-transformer (new-version file prefix suffix &optional dont-warn)
(let* ((qprefix (cl-ppcre:quote-meta-chars prefix))
(versionrx "([0-9]+(\\.[0-9]+)+)")
(qsuffix (cl-ppcre:quote-meta-chars suffix))
(regex (strcat "(" qprefix ")(" versionrx ")(" qsuffix ")"))
(constantly (strcat prefix new-version suffix))))
(lambda (text)
(multiple-value-bind (new-text foundp)
(cl-ppcre:regex-replace regex text replacement)
(unless (or foundp dont-warn)
(warn "Missing version in ~A" (file-namestring file)))
(values new-text foundp)))))
(defun transform-file (new-version file prefix suffix)
(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)))
(defun test-transform-file (new-version file prefix suffix)
(let ((lines (read-file-lines (pn file))))
(dolist (l lines (progn (warn "Couldn't find a match in ~A" file) nil))
(multiple-value-bind (new-text foundp)
(funcall (version-transformer new-version file prefix suffix t) l)
(when foundp
(format t "Found a match:~% ==> ~A~%Replacing with~% ==> ~A~%~%"
l new-text)
(return t))))))
(defun test-transform (new-version)
(apply 'test-transform-file new-version (first *versioned-files*)))
(defun bump-version (&optional v1 v2)
(with-asdf-dir ()
(multiple-value-bind (old-version new-version)
(versions-from-args v1 v2)
(a "Bumping ASDF version from " old-version " to " new-version)
(transform-files new-version)
(a "Rebuilding ASDF with bumped version")
(defun bump (&optional v1 v2)
(let ((v (bump-version v1 v2)))
(git `(commit -a -m ("Bump version to ",v)))
(git `(tag ,v))
;;; 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))
(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))
(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
:want-absolute t :want-directory t
:want-existing t :truename t))
:defaults (pn "build/")
:want-relative t :ensure-absolute t
:ensure-subpath t :ensure-directory t))
(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."
(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)))
(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 ()
(make-tarball-under-build (asdf-defsystem-name) (pn) (asdf-defsystem-files)))
(defun asdf-git-name ()
(strcat "asdf-" *version*))
(defun make-git-tarball ()
(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)
(defun asdf-lisp-name ()
(format nil "asdf-~A.lisp" *version*))
(defun make-asdf-lisp ()
(concatenate-files (list (pn "build/asdf.lisp"))
(pn "build/" (asdf-lisp-name))))
(defun make-archive ()
;;; Publishing tarballs onto the public repository
(defvar *clnet* "")
(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:~%
(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")
(public-path "archives/asdf.lisp"))
:show t :host *clnet*)
(defun make-and-publish-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))
(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)))
(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"))
;;; Line counting
(defun wc ()
(with-asdf-dir ()
(run `(pipe (wc ,@(driver-files)) (sort -n)))
(run `(pipe (wc header.lisp ,@(asdf-defsystem-files)) (sort -n)))
(run `(pipe (wc header.lisp ,@(driver-files) ,@(asdf-defsystem-files)) (tail -n 1)))))
;;; Testing
(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
(remove nil
(etypecase x
(string (uiop:split-string (string-upcase x) :separator " "))
(list x)))))
(defparameter *default-test-lisps*
'(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro
:lispworks :allegromodern :gcl :xcl :mkcl)
;; :cormancl :genera :lispworks-personal-edition :mcl
;; Also, grep for #+/#- features in the test/ directory
;; to see plenty of disabled tests on some platforms
"Default Lisp implementations for tests")
(defparameter *test-lisps* *default-test-lisps*
"The list of lisp implementations to use for tests")
(defparameter *upgrade-test-lisps* *default-test-lisps*
"The list of lisp implementations to use for upgrade tests")
(defparameter *test-systems*
(ensure-list-of-keywords (getenvp "ASDF_TEST_SYSTEMS")))
(defparameter *test-scripts* ()) ;; TODO: use :all instead of NIL (?)
(defparameter *environment-variable-table* nil)
(defparameter *environment-variable-specs*
'((*test-lisps* ensure-list-of-keywords *default-test-lisps*
(*upgrade-test-lisps* ensure-list-of-keywords *default-test-lisps*
(*test-systems* ensure-list-of-keywords ()
(*test-scripts* ensure-list-of-keywords ()
"ASDF_TESTS" "t")))
(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))))
(defparameter *extra-environment-definitions* ())
(defun test-lisp/k () (first *test-lisps*))
(defun test-lisp/s () (string-downcase (first *test-lisps*)))
(defun test-definition (def)
(block ()
(cl-ppcre:register-groups-bind (var val) ("^([^=]+)=(.*)$" def)
(if-let (x (gethash var *environment-variable-table*))
(destructuring-bind (var transformer default) x
(declare (ignore default))
(setf (symbol-value var) (funcall transformer val))
(push def *extra-environment-definitions*)))
(defun test-environment (env)
(loop :for def :in env :do (test-definition def)))
(defun run-tests (args)
(with-asdf-dir ()
(run `(./test/ ,@args) :output :interactive)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun decl-or-docstring-p (form)
(or (stringp form)
(and (consp form) (eq 'declare (car form)))))
(defun decl-and-body (decl-and-body)
(let ((p (position-if-not 'decl-or-docstring-p decl-and-body)))
(values (subseq decl-and-body 0 p)
(nthcdr p decl-and-body)))))
(defmacro deftestcmd (name args &rest decl-and-body)
(let ((env (gensym "ENV")))