From 42f86c0b0880336a6ccb84ec0151197e755e2964 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sun, 18 May 2014 04:26:37 -0400 Subject: [PATCH] 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. --- Makefile | 17 +- bin/asdf-builder | 827 -------------------------- test/run-tests.sh | 522 ---------------- test/script-support.lisp | 5 +- tools/asdf-tools | 19 + tools/asdf-tools.asd | 20 + tools/build.lisp | 24 + tools/git.lisp | 56 ++ {bin => tools}/install-asdf-as-module | 19 +- tools/invoke-lisp.lisp | 222 +++++++ tools/load-asdf.lisp | 190 ++++++ tools/main.lisp | 41 ++ tools/package.lisp | 6 + tools/pathnames.lisp | 19 + tools/release.lisp | 189 ++++++ tools/test-all.lisp | 86 +++ tools/test-basic.lisp | 79 +++ tools/test-environment.lisp | 206 +++++++ tools/test-scripts.lisp | 84 +++ tools/test-upgrade.lisp | 145 +++++ tools/version.lisp | 128 ++++ 21 files changed, 1536 insertions(+), 1368 deletions(-) delete mode 100755 bin/asdf-builder delete mode 100755 test/run-tests.sh create mode 100755 tools/asdf-tools create mode 100644 tools/asdf-tools.asd create mode 100644 tools/build.lisp create mode 100644 tools/git.lisp rename {bin => tools}/install-asdf-as-module (83%) create mode 100644 tools/invoke-lisp.lisp create mode 100644 tools/load-asdf.lisp create mode 100644 tools/main.lisp create mode 100644 tools/package.lisp create mode 100644 tools/pathnames.lisp create mode 100644 tools/release.lisp create mode 100644 tools/test-all.lisp create mode 100644 tools/test-basic.lisp create mode 100644 tools/test-environment.lisp create mode 100644 tools/test-scripts.lisp create mode 100644 tools/test-upgrade.lisp create mode 100644 tools/version.lisp diff --git a/Makefile b/Makefile index b93243034..d1328cac2 100644 --- a/Makefile +++ b/Makefile @@ -1,13 +1,13 @@ -# -*- 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 diff --git a/bin/asdf-builder b/bin/asdf-builder deleted file mode 100755 index 4f9346d0a..000000000 --- a/bin/asdf-builder +++ /dev/null @@ -1,827 +0,0 @@ -":" ; 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*))) - "1.0"))) - (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) - parent)) - (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 - (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") - (configure-asdf))) - (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))) - (source-registry - (or (asdf-call 'getenv "ASDF_DEVEL_SOURCE_REGISTRY") - `(:source-registry - (:tree ,source-directory) - ;; In a fully controlled build, you'd :ignore-inherited-configuration instead: - :inherit-configuration))) - (output-directory - ;; There again, you might want to use some getenv variant. - ;; Also, "fasls" might be redundant for your project. - (subpath source-directory :directory '("build" "fasls"))) - (output-translations - `(:output-translations - ;; 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. - :ignore-inherited-configuration))) - ;; 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 - (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) - -;;(uiop-debug) - -(defun build-asdf () - "Make sure asdf.lisp is built" - (load-system :asdf) - (values)) - -;;; 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://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" - (with-asdf-dir () - (dolist (x '((git status) - (git push --tags cl.net 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) - ver))) - -(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))) - (cond - ((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)) - 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 ")")) - (replacement - (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") - (build-asdf) - new-version))) - -(defun bump (&optional v1 v2) - (let ((v (bump-version v1 v2))) - (git `(commit -a -m ("Bump version to ",v))) - (git `(tag ,v)) - 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)) - 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")) - - -;;; 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))))) - - -;;; 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) - ;; NOT SUPPORTED BY OUR AUTOMATED TESTS: - ;; :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* - "ASDF_TEST_LISPS" "l") - (*upgrade-test-lisps* ensure-list-of-keywords *default-test-lisps* - "ASDF_UPGRADE_TEST_LISPS" "u") - (*test-systems* ensure-list-of-keywords () - "ASDF_TEST_SYSTEMS" "s") - (*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)) - (return)))) - (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/run-tests.sh ,@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"))) - (multiple-value-bind (decl body) (decl-and-body decl-and-body) - `(defun ,name (,@args &rest ,env) - ,@decl - (test-environment ,env) - ,@body)))) - -(deftestcmd %load () ;; 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." - ;; Try this instead? - '(with-asdf-dir () - (run `(rlwrap ,@(lisp-invocation-arglist :implementation (test-lisp/k) :eval (format nil "(or'#.(load(string'|test/script-support.lisp|))#.(asdf-test:interactive-test'(~{~A~^ ~})))" (system-source-files :asdf/defsystem :monolithic t)))) - :output :interactive)) - (run-tests `(-t ,(test-lisp/s) ,@(system-source-files :asdf/defsystem :monolithic t)))) - -(deftestcmd test-basic () - "basic smoke test" - (doc) - (test-load-systems)) - -(deftestcmd test-lisp () - "run test scripts with the preferred lisp implementation" - (with-asdf-dir ("test/") - (run `("./run-tests.sh" ,(test-lisp/s) ,@*test-scripts*)))) -(deftestcmd %t () "alias for test-lisp" (test-lisp)) - -(deftestcmd test-upgrade () - "run upgrade tests with the preferred lisp implementation" - (run-tests `("-u" ,(test-lisp/s)))) -(deftestcmd u () "alias for test-upgrade" (test-upgrade)) - -(deftestcmd test-clean-load () - "test that the preferred lisp implementation can load asdf cleanly without any output message" - (run-tests `("-c" ,(test-lisp/s)))) - -(deftestcmd test-load-systems () - "test that the preferred lisp implementation can load your favorite systems without error" - (run-tests `(-l ,(test-lisp/s) ,@*test-systems*))) - -(deftestcmd %test () - "run all normal tests (excluding upgrade tests) with the preferred lisp implementation" - (test-lisp) - (test-clean-load) - (test-basic)) - -(defun call-with-all-lisps (thunk &optional (lisps *test-lisps*)) - (dolist (lisp lisps) - (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-lisp))) - -(deftestcmd test-all-no-upgrade () - "test that all lisp implementations pass all normal asdf; also test-basic" - (test-basic) - (test-all-clean-load) - (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" - (test-all-no-upgrade) - (test-all-upgrade)) -(deftestcmd test-all () "alias for test-all-lisps" (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-lisp)))) - -(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." - (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." - (test-basic) - (test-all-clean-load) - (test-all-lisp-no-stop) - (test-all-upgrade-no-stop) - (check-all-results)) - -(deftestcmd test-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-test-results () - "check that there were no errors in test scripts" - (or (test-all-test-results) (die 1 ""))) - -(deftestcmd test-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! *error-output* "Unexpected upgrade failures on these implementations:~%~{~A~%~}" a) - nil))))) - -(deftestcmd check-all-upgrade-results () - "check that there were no errors in upgrade tests" - (or (test-all-upgrade-results) (die 1 ""))) - -(deftestcmd check-all-results () - "check that there were no errors in either test scripts or upgrade tests" - (or (and (test-all-test-results) (test-all-upgrade-results)) (die 1 ""))) - - -;;; Extract old asdf versions -(defun extract-all-tagged-asdf () - (with-asdf-dir () (run `(./test/run-tests.sh "-H")))) -(defun extract () "alias for extract-all-tagged-asdf" (extract-all-tagged-asdf)) - - -;;;; Generic code to interface a Lisp script to the shell command-line. - -;;; Read-Eval function (the RE of REPL; the Print and Loop parts are not here) -(defun re (arg) - (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-builder nil) - (when (and sym (eq foundp :internal) (fboundp sym)) - (return (fdefinition sym)))))) - (try x) - (try (strcat "%" x))))) ;; so that you may use load, t, etc., as targets - -;;; 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 - (progn - (initialize-environment) - (multiple-value-list (apply fun (rest args)))))) - (when results - (format t "~&Results:~%~{ ~S~%~}" results)) - (return t))) - (format t "Command ~A not found~%" (first args)) - (return))) - -;;; Actually run the stuff! -(setf *lisp-interaction* nil) -(uiop:with-fatal-condition-handler () - (main *command-line-arguments*)) diff --git a/test/run-tests.sh b/test/run-tests.sh deleted file mode 100755 index 37b88001e..000000000 --- a/test/run-tests.sh +++ /dev/null @@ -1,522 +0,0 @@ -#!/bin/sh - -# run-tests {lisp invocation} {scripts-regex} -# - read lisp forms one at a time from standard input -# - quit with exit status 0 on getting eof -# - quit with exit status >0 if an unhandled error occurs - -usage () { - echo "$0 [lisp invocation] [scripts-regex]" - echo " - read lisp forms one at a time from matching scripts" - echo " - quit with exit status 0 on getting eof" - echo " - quit with exit status >0 if an unhandled error occurs" - echo " you need to supply the .script in the second argument" - echo " lisps include abcl, ccl (clozure)," - echo " allegro, allegro8, allegromodern, allegromodern8," - echo " allegro_s, allegro8_s, allegromodern_s, allegromodern8_s (SMP variants)" - echo " allegro_64, allegro8_64, allegromodern_64, allegromodern8_64 (64-bit variants)," - echo " allegro_64_s, allegro8_64_s, allegromodern_64_s, allegromodern8_64_s, (SMP, 64-bit variants)" - echo " clisp, cmucl, ecl, gcl, sbcl, scl and xcl." - echo " To configure the script, you may set environment variables to point to the various lisp runtimes." - echo " Allegro CL is a special case: instead of setting environment variables for the specific runtime" - echo " locations, you may simply specify the Allegro install directories using these variables:" - echo " ALLEGRO64DIR, ALLEGRO64SDIR (64-bit Allegro and SMP Allegro, respectively), ALLEGRODIR, and" - echo " ALLEGROSDIR." - echo "OPTIONS:" - echo " -c -- clean load test." - echo " -d -- debug mode." - echo " -t -- test interactively." - echo " -h -- show this message." - echo " -u -- upgrade tests." - echo " -l -- load systems tests." - echo " -H -- extract all asdf versions to upgrade from." - echo " -u -- upgrade tests, we already told you." -} - -unset DEBUG_ASDF_TEST upgrade clean_load load_systems test_interactively extract_all - -SHELL=/bin/sh -export SHELL DEBUG_ASDF_TEST GCL_ANSI ASDF_OUTPUT_TRANSLATIONS - -if [ -n "$ALLEGRO64DIR" ] ; then - ALLEGRO_64=${ALLEGRO64DIR}/alisp - ALLEGRO8_64=${ALLEGRO64DIR}/alisp8 - ALLEGROMODERN_64=${ALLEGRO64DIR}/mlisp - ALLEGROMODERN8_64=${ALLEGRO64DIR}/mlisp8 -fi -if [ -n "$ALLEGRO64SDIR" ] ; then - ALLEGRO_64_S=${ALLEGRO64SDIR}/alisp - ALLEGRO8_64_S=${ALLEGRO64SDIR}/alisp8 - ALLEGROMODERN_64_S=${ALLEGRO64SDIR}/mlisp - ALLEGROMODERN8_64_S=${ALLEGRO64SDIR}/mlisp8 -fi -if [ -n "$ALLEGRODIR" ] ; then - ALLEGRO=${ALLEGRODIR}/alisp - ALLEGRO8=${ALLEGRODIR}/alisp8 - ALLEGROMODERN=${ALLEGRODIR}/mlisp - ALLEGROMODERN8=${ALLEGRODIR}/mlisp8 -fi -if [ -n "$ALLEGROSDIR" ] ; then - ALLEGRO_S=${ALLEGROSDIR}/alisp - ALLEGRO8_S=${ALLEGROSDIR}/alisp8 - ALLEGROMODERN_S=${ALLEGROSDIR}/mlisp - ALLEGROMODERN8_S=${ALLEGROSDIR}/mlisp8 -fi - - -while getopts "cdtHulhu" OPTION -do - case $OPTION in - c) - clean_load=t - ;; - d) - DEBUG_ASDF_TEST=t - ;; - t) - test_interactively=t - ;; - h) - usage - exit 1 - ;; - u) - upgrade=t - ;; - l) - load_systems=t - ;; - H) - extract_all=t - ;; - esac -done -shift $(($OPTIND - 1)) - -if [ x"$1" = "xhelp" ]; then - usage - exit 1 -fi -lisp=${1:-sbcl} ; shift - - -ECHO () { printf '%s\n' "$*" ;} -ECHOn () { printf '%s' "$*" ;} -DBG () { ECHO "$*" >& 2 ;} -simple_term_p () { - case "$1" in *[!a-zA-Z0-9-+_,.:=%/]*) return 1 ;; *) return 0 ;; esac -} -kwote0 () { ECHOn "$1" | sed -e "s/\([\\\\\"\$\`]\)/\\\\\\1/g" ;} -kwote1 () { if simple_term_p "$1" ; then ECHOn "$1" - else ECHOn "\"$(kwote0 "$1")\"" ; fi ;} -kwote () { ( set +x - k="" ; for i ; do ECHOn "$k" ; kwote1 "$i" ; k=" " ; done ; echo -) } -DO () { kwote "$@" ; "$@" ; } - -do_tests () { - if [ -z "$*" ]; then - scripts="*.script" - else - scripts="$*" - fi - env | grep -i asdf - ## We go through great lengths to avoid " in the command line, - ## the quoting of which many Windows implementations get wrong. - ## While we're at it, we also avoid spaces and backslashes. - ( DO $bcmd $eval '(or`,#.(load(string`|script-support.lisp|))#.(asdf-test::compile-asdf-script))' ) - if [ $? -ne 0 ] ; then - echo "Compilation FAILED" >&2 - echo "you can retry compilation with:" >&2 - echo ./test/run-tests.sh $lisp >&2 - echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 - echo "$icmd" >&2 - echo "then copy/paste:" >&2 - echo '(load "test/script-support.lisp") (asdf-test::compile-asdf-script)' >&2 - else - echo "Compiled OK" >&2 - test_count=0 - test_pass=0 - test_fail=0 - failed_list="" - for i in $scripts ; - do - echo "Testing: $i" >&2 - test_count=`expr "$test_count" + 1` - rm -f ~/.cache/common-lisp/"`pwd`"/* || true - if DO $bcmd $eval "'(#.(load(string'|script-support.lisp|))#.(asdf-test::load-asdf)#.(asdf-test::frob-packages)#.(asdf-test:run-test-script'|$i|))" ; then - echo "Using $command, $i passed" >&2 - test_pass=`expr "$test_pass" + 1` - else - echo "Using $command, $i failed" >&2 - test_fail=`expr "$test_fail" + 1` - failed_list="$failed_list $i" - echo "you can retry compilation with:" >&2 - echo ./test/run-tests.sh $lisp $i >&2 - echo "or more interactively (and maybe with rlwrap or in emacs), start with:" >&2 - echo "(cd test ; $icmd )" >&2 - echo "then copy/paste:" >&2 - echo "'(#.(load \"script-support.lisp\") #.(asdf-test::da) #.(load-asdf) #.(frob-packages) #.(asdf::with-asdf-cache () (load \"$i\")))" >&2 - fi - echo >&2 - echo >&2 - done - echo >&2 - echo "-#---------------------------------------" >&2 - echo "Using $command" >&2 - echo "Ran $test_count tests: " >&2 - echo " $test_pass passing and $test_fail failing" >&2 - if [ $test_fail -eq 0 ] ; then - echo "all tests apparently successful" >&2 - echo success > ../build/results/status - else - echo "failing test(s): $failed_list" >&2 - fi - echo "-#---------------------------------------" >&2 - echo >&2 - fi -} - -# -# not used currently but leave here for future reference. -# -case $(uname) in - CYGWIN*) os=windows ;; - Darwin) os=macos ;; - Linux) os=linux ;; - *) os=unknown ;; -esac - - - -# terminate on error -set -e - -command= flags= nodebug= eval= bcmd= icmd= -case "$lisp" in - abcl) - command="${ABCL:-abcl}" - flags="--noinit --nosystem --noinform" - eval="--eval" - ;; - allegro*) - case "$lisp" in - allegro) command="${ALLEGRO:-alisp}" ;; - allegro8) command="${ALLEGRO8:-alisp8}" ;; - allegromodern) command="${ALLEGROMODERN:-mlisp}" ;; - allegromodern8) command="${ALLEGROMODERN8:-mlisp8}" ;; - allegro_s) command="${ALLEGRO_S:-alisp_s}" ;; - allegro8_s) command="${ALLEGRO8_S:-alisp8_s}" ;; - allegromodern_s) command="${ALLEGROMODERN_S:-mlisp_s}" ;; - allegromodern8_s) command="${ALLEGROMODERN8_S:-mlisp8_s}" ;; - allegro_64) command="${ALLEGRO_64:-alisp_64}" ;; - allegro8_64) command="${ALLEGRO8_64:-alisp8_64}" ;; - allegromodern_64) command="${ALLEGROMODERN_64:-mlisp_64}" ;; - allegromodern8_64) command="${ALLEGROMODERN8_64:-mlisp8_64}" ;; - allegro_64_s) command="${ALLEGRO_64_S:-alisp_64_s}" ;; - allegro8_64_s) command="${ALLEGRO8_64_S:-alisp8_64_s}" ;; - allegromodern_64_s) command="${ALLEGROMODERN_64_S:-mlisp_64_s}" ;; - allegromodern8_64_s) command="${ALLEGROMODERN8_64_S:-mlisp8_64_s}" ;; - esac - # For the sake of the lisp-invocation library, re-export these - ALLEGRO=$command ; export ALLEGRO - flags="-q" - nodebug="-batch" - if [ "$os" = windows ] && [ -z "$ALLEGRO_NOISY" ] ; then bcmd="$command +c $flags" ; fi - eval="-e" ;; - ccl) - command="${CCL:-ccl}" - flags="--no-init --quiet" - nodebug="--batch" - eval="--eval" ;; - clisp) - command="${CLISP:-clisp}" - flags="-norc --silent -ansi -I " - nodebug="-on-error exit" - eval="-x" ;; - cmucl) - # cmucl likes to have its executable called lisp, but so does scl - # Please use a symlink or an exec ... "$@" trampoline script. - command="${CMUCL:-cmucl}" - flags="-noinit" - nodebug="-batch" - eval="-eval" ;; - ecl) - command="${ECL:-ecl}" - flags="-norc -load sys:cmp" - eval="-eval" ;; - ecl_bytecodes) - command="${ECL:-ecl}" - flags="-norc -eval (ext::install-bytecodes-compiler)" - eval="-eval" ;; - gcl) - GCL_ANSI=t - command="${GCL:-gcl}" - flags="" - nodebug="-batch" - eval="-eval" ;; - lispworks) - command="${LISPWORKS:-lispworks}" - # If you have a licensed copy of lispworks, - # you can obtain the "lispworks" binary with, e.g. - # echo '(hcl:save-image "/lispworks" :environment nil)' > /tmp/build.lisp ; - # ./lispworks-6-0-0-x86-linux -siteinit - -init - -build /tmp/build.lisp - flags="-siteinit - -init -" - eval="-eval" ;; - mkcl) - command="${MKCL:-mkcl}" - flags="-norc" - eval="-eval" ;; - sbcl) - command="${SBCL:-sbcl}" - flags="--noinform --no-userinit --no-sysinit" - nodebug="--disable-debugger" - eval="--eval" ;; - scl) - command="${SCL:-scl}" - flags="-noinit" - nodebug="-batch" - eval="-eval" ;; - xcl) - command="${XCL:-xcl}" - flags="--no-userinit --no-siteinit --noinform" - eval="--eval" ;; - *) - echo "Unsupported lisp: $1" >&2 - echo "Please add support to run-tests.sh" >&2 - exit 42 ;; -esac - -if ! type "$command" > /dev/null ; then - echo "lisp implementation not found: $command" >&2 - exit 43 -fi - -ASDFDIR="$(cd $(dirname $0)/.. ; /bin/pwd)" -: ${bcmd:=$command $flags} ${icmd:=$command $flags} # batch and interactive -if [ -z "${DEBUG_ASDF_TEST}" ] ; then - bcmd="$bcmd $nodebug" -fi - - -create_config () { - cd ${ASDFDIR} - mkdir -p build/results/ build/test-source-registry-conf.d build/test-asdf-output-translations-conf.d -} -upgrade_tags () { - if [ -n "$ASDF_UPGRADE_TEST_TAGS" ] ; then - echo $ASDF_UPGRADE_TEST_TAGS ; return - fi - # REQUIRE is a magic tag meaning whatever your implementation provides, if anything - # - # 1.85 (2004-05-16) is the last release by Daniel Barlow (not 1.37, which is the README revision!) - # 1.97 (2006-05-14) is the last release before Gary King takes over - # 1.369 (2009-10-27) is the last release by Gary King - # - # 2.000 to 2.019 and 2.20 to 2.26 are Faré's "stable" ASDF 2 releases - # 2.000 (2010-05-31) was the first ASDF 2 release - # 2.008 (2010-09-10) was a somewhat stable ASDF 2 release - # 2.011 (2010-11-28) was used by CLISP 2.49, Debian squeeze, Ubuntu 10.04 LTS - # 2.014.6 (2011-04-06) was used by Quicklisp in 2011 - # 2.019 (2011-11-27) was stable and used by LispWorks since 2012. - # 2.20 (2012-01-18) was in CCL 1.8, Ubuntu 12.04 LTS - # 2.22 (2012-06-12) was used by debian wheezy - # 2.26 (2012-10-30) was used by Quicklisp in 2013 - # - # 2.26.x is where the refactoring that begat ASDF 3 took place. - # 2.26.61 is the last single-file, single-package ASDF. - # 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases - # 2.27 (2013-02-01) is the first ASDF 3 pre-release - # 2.32 (2013-03-05) is the first really stable ASDF 3 pre-release - # - # The 3.0 series is a stable release of ASDF 3 - # with Robert Goldman taking over maintainership at 3.0.2. - # 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly - # not compatible with ASDF2 anymore, so we immediately released 3.0.1 - # 3.0.1 (2013-05-16) is the first stable ASDF 3 release - # 3.0.2 (2013-07-02) is the first ASDF 3 in SBCL - # 3.0.3 (2013-10-22) is the last in the ASDF 3.0 series - # - # The 3.1 series provides the 3.1 feature, meaning users can rely on - # all the stabilization work done in 3.0 so far, plus extra developments - # in UIOP, package-inferred-system, and more robustification. - # 3.1.2 (2014-05-06) is the first ASDF 3.1 release - # - # We return the above designated versions in order of decreasing relevance, - # which pretty much means REQUIRE and most recent first. - echo REQUIRE - echo 3.1.2 - echo 3.0.3 3.0.2 3.0.1 - echo 2.32 2.27 - echo 2.26 2.22 2.20 2.019 2.014.6 2.011 2.008 2.000 - echo 1.369 1.97 1.85 -} -upgrade_methods () { - if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then - echo $ASDF_UPGRADE_TEST_METHODS ; return - fi - cat <<EOF -'load-asdf-lisp'load-asdf-lisp-clean -'load-asdf-lisp'load-asdf-system -'load-asdf-lisp'compile-load-asdf-upgrade -'load-asdf-lisp'load-asdf-fasl -()'load-asdf-fasl -'load-asdf-lisp-and-test-uiop'load-asdf-fasl -EOF -} -extract_tagged_asdf () { - cd ${ASDFDIR} - mkdir -p build/ - tag=$1 - if [ REQUIRE = "$tag" ] ; then return 0 ; fi - file=build/asdf-${tag}.lisp ; - if [ ! -f $file ] ; then - case $tag in - 1.*|2.0*|2.2[0-6]|2.26.61) - git show ${tag}:asdf.lisp > $file ;; - 2.2[7-9]*|2.[3-9]*|3.*) - mkdir -p build/old/build - git archive ${tag} | (cd build/old/ ; tar xf -) - make -C build/old - mv build/old/build/asdf.lisp build/asdf-${tag}.lisp - rm -rf build/old ;; - *) - echo "Don't know how to extract asdf.lisp for version $tag" - exit 55 - ;; - esac - fi -} -extract_all_tagged_asdf () { - for i in `upgrade_tags` ; do - extract_tagged_asdf $i - done -} -valid_upgrade_test_p () { - case "${1}:${2}:${3}" in - # It's damn slow. Also, for some reason, we punt on anything earlier than 2.25, - # and only need to test it once, below for 2.24. - abcl:1.*|abcl:2.00[0-9]:*|abcl:201[0-9]:*|abcl:2.2[0-3]:*) : ;; - # ccl fasl numbering broke loading of old asdf 2.0 - ccl:2.0[01]*) : ;; - # My old ubuntu 10.04LTS clisp 2.44.1 came wired in - # with an antique ASDF 1.374 from CLC that can't be downgraded. - # More recent CLISPs work. - # 2.00[0-7] use UID, which fails on some old CLISPs. - # Note that for the longest time, CLISP has included 2.011 in its distribution. - # We don't punt on upgrade anymore, so we can go at it! - ### clisp:2.00[0-7]:*|clisp:1.*|clisp:2.0[01]*|clisp:2.2[0-5]:*) : ;; - # CMUCL has problems with 2.32 and earlier because of - # the redefinition of system's superclass component. - cmucl:1.*|cmucl:2.*) : ;; - # Skip many ECL tests, for various ASDF issues - ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*) : ;; - # GCL 2.7.0 from late November 2013 is required, with ASDF 3.1.2 - gcl:REQUIRE:*|gcl:1.*|gcl:2.*|gcl:3.0*) : ;; - # MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip. - mkcl:[12]*|mkcl:3.0*) : ;; - # XCL support starts with ASDF 2.014.2 - # — It also dies during upgrade trying to show the backtrace. - xcl:1.*|xcl:2.00*|xcl:2.01[0-4]:*|xcl:*) : ;; - *) return 0 ;; - esac - return 1 -} -run_upgrade_tests () { - cd ${ASDFDIR} - mkdir -p build/results/ - rm -f build/*.*f* uiop/*.*f* test/*.*f* ## Remove stale FASLs from ASDF 1.x, especially when different implementations have same name - ASDF_OUTPUT_TRANSLATIONS="(:output-translations (\"${ASDFDIR}\" (\"${ASDFDIR}/build/fasls/\" :implementation \"asdf/\")) (t (\"${ASDFDIR}/build/fasls/\" :implementation \"root/\")) :ignore-inherited-configuration)" - su=test/script-support.lisp - tags="`upgrade_tags`" - methods="`upgrade_methods`" - { - for tag in $tags ; do - for method in $methods ; do - if valid_upgrade_test_p $lisp $tag $method ; then - echo "Testing ASDF upgrade from ${tag} using method $method" - extract_tagged_asdf $tag - $bcmd $eval \ - "'(#.(load(string'|$su|))#.#.\`(in-package,:asdf-test)#.(test-upgrade$method\`|$tag|))" || - { echo "upgrade FAILED for $lisp from $tag using method $method" ; - echo "you can retry just that test with:" ; - echo ASDF_UPGRADE_TEST_TAGS=\"$tag\" ASDF_UPGRADE_TEST_METHODS=\"$method\" ./test/run-tests.sh -u $lisp ; - echo "or more interactively (and maybe with rlwrap or in emacs), start with:" - echo "$icmd" - echo "then copy/paste:" - echo "(load \"$su\") (asdf-test::da) (test-upgrade $method \"$tag\")" - exit 1 ;} - fi ; done ; done - echo "Upgrade test succeeded for ${lisp}" - } 2>&1 | tee build/results/${lisp}-upgrade.text -} -run_tests () { - create_config - cd ./test/ - echo failure > ../build/results/status - thedate=`date "+%Y-%m-%d"` - rm -f "../build/results/${lisp}-test.text" || : - do_tests "$@" 2>&1 | \ - tee "../build/results/${lisp}-test.text" "../build/results/${lisp}-test-${thedate}.save" - read a < ../build/results/status - clean_up - if [ success = "$a" ] ; then ## exit code - return 0 - else - echo "To view full results and failures, try the following command:" >&2 - echo " less -p ABORTED build/results/${lisp}-test.text" >&2 - return 1 - fi -} -clean_up () { - rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d -} -test_clean_load () { - case $lisp in - gcl|cmucl) return 0 ;; # These are hopeless - esac - cd ${ASDFDIR} - mkdir -p build/results/ - nop=build/results/${lisp}-nop.text - load=build/results/${lisp}-load.text - $bcmd $eval \ - "(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test:exit-lisp'0))" \ - > $nop 2>&1 - $bcmd $eval \ - "(or'#.(load(string'|test/script-support.lisp|):verbose():print())#.(asdf-test:verbose())#.(load(string'|build/asdf.lisp|):verbose())#.(asdf/image:quit'0))" \ - > $load 2>&1 - if diff $nop $load ; then - echo "GOOD: Loading ASDF on $lisp produces no message" >&2 ; return 0 - else - echo "BAD: Loading ASDF on $lisp produces messages" >&2 ; return 1 - fi -} -test_load_systems () { - cd ${ASDFDIR} - mkdir -p build/results/ - echo "Loading all these systems: $*" - $bcmd $eval \ - "(or #.(load(string'|test/script-support.lisp|))#.(asdf-test:with-test()(asdf-test:test-load-systems $*)))" \ - 2>&1 | tee build/results/${lisp}-systems.text -} -test_interactively () { - cd ${ASDFDIR} - mkdir -p build/results/ - rlwrap $icmd $eval "(or'#.(load(string'|test/script-support.lisp|))#.(asdf-test:interactive-test'($*)))" -} - -if [ -z "$command" ] ; then - echo "Error: cannot find or do not know how to run Lisp named $lisp" -elif [ -n "$test_interactively" ] ; then - test_interactively "$@" -elif [ -n "$clean_load" ] ; then - test_clean_load -elif [ -n "$load_systems" ] ; then - test_load_systems "$@" -elif [ -n "$upgrade" ] ; then - run_upgrade_tests -elif [ -n "$extract_all" ] ; then - extract_all_tagged_asdf -else - run_tests "$@" -fi ; exit # NB: "; exit" makes it robust wrt the script being modified while running. diff --git a/test/script-support.lisp b/test/script-support.lisp index 6b0a4069d..ee90ba76e 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -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) diff --git a/tools/asdf-tools b/tools/asdf-tools new file mode 100755 index 000000000..c61106820 --- /dev/null +++ b/tools/asdf-tools @@ -0,0 +1,19 @@ +":" ; 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) diff --git a/tools/asdf-tools.asd b/tools/asdf-tools.asd new file mode 100644 index 000000000..a1de56eb7 --- /dev/null +++ b/tools/asdf-tools.asd @@ -0,0 +1,20 @@ +(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")))) diff --git a/tools/build.lisp b/tools/build.lisp new file mode 100644 index 000000000..5a45f8b2f --- /dev/null +++ b/tools/build.lisp @@ -0,0 +1,24 @@ +(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))))) + diff --git a/tools/git.lisp b/tools/git.lisp new file mode 100644 index 000000000..0c22039a1 --- /dev/null +++ b/tools/git.lisp @@ -0,0 +1,56 @@ +(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)))) diff --git a/bin/install-asdf-as-module b/tools/install-asdf-as-module similarity index 83% rename from bin/install-asdf-as-module rename to tools/install-asdf-as-module index acf61fbd2..49bd8fcab 100644 --- a/bin/install-asdf-as-module +++ b/tools/install-asdf-as-module @@ -1,6 +1,6 @@ -":" ; 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) diff --git a/tools/invoke-lisp.lisp b/tools/invoke-lisp.lisp new file mode 100644 index 000000000..203b0372e --- /dev/null +++ b/tools/invoke-lisp.lisp @@ -0,0 +1,222 @@ +(in-package :asdf-tools) + +#| +Supported test lisp implementations include: + allegro, abcl, ccl, clisp, cmucl, ecl, gcl, lispworks, mkcl, sbcl, scl and xcl. +Non supported are: + cormancl, lispworks-personal-edition, mcl, genera + +CCL is Clozure CL; (R)MCL is not supported. +Allegro is supported in the following flavors: + allegro, allegro8, allegromodern, allegromodern8, + allegro_s, allegro8_s, allegromodern_s, allegromodern8_s (SMP variants) + allegro_64, allegro8_64, allegromodern_64, allegromodern8_64 (64-bit variants), + allegro_64_s, allegro8_64_s, allegromodern_64_s, allegromodern8_64_s, (SMP, 64-bit variants) +Allegro CL is a special case: instead of setting environment variables for the specific runtime +locations, you may simply specify the Allegro install directories using these variables: + ALLEGRO64DIR, ALLEGRO64SDIR (64-bit Allegro and SMP Allegro, respectively), + ALLEGRODIR, and ALLEGROSDIR. + +To configure the lisp implementations with which to run the tests, +you may export environment variables to override the defaults: +ASDF_TEST_LISPS and ASDF_UPGRADE_TEST_LISPS can each be a string of space-separated names +amongst the above implementation names. +You may also explicitly specify the same variables with the respective l= and u= arguments. +Individual test commands only use the first (preferred) provided implementation; +other test commands (named test-all-FOO) iterate over all implementations. + +Similarly, you can configure which scripts to tests with ASDF_TEST_SCRIPTS or t= +and which systems to test loading with ASDF_TEST_SYSTEMS or s= + +|# + +(loop + :for (smpchar smpname smpfullname) :in `(("" "" "") ("S" ,(string :_s) " (SMP)")) :do + (loop + :for (bits bitsname bitsfullname) :in '(("" "") ("64" "_64" " (64-bit words)")) + :for dirvar = (strcat "ALLEGRO" bits smpchar) + :for dir = (getenv-pathname dirvar :want-absolute t :ensure-directory t) :do + (loop :for (charbits charname) :in '(("" "") ("8" " (8-bit chars)")) :do + (loop :for (casechar casename casefullname) :in '(("a" "" "") ("m" :modern " (modern syntax)")) + :for allegro-variant = (conc-keyword :allegro casename charbits bits) + :for fullname = (strcat "Allegro CL" + casefullname charname bitsname smpname) + :for executable = (strcat casechar "lisp" charbits bits) :do + (register-lisp-implementation + allegro-variant + :fullname fullname + :name (native-namestring (subpathname dir executable)) + :feature :allegro ;; do we want a more discriminating feature expression? + :flags '("-qq") + :eval-flag "-e" + :load-flag "-L" + ;; :quit-flags ("-kill") + :arguments-end "--" + :image-flag "-I" + :image-executable-p nil + :standalone-executable nil + :argument-control t + :disable-debugger `("-batch" ; see also -#D -#C -#! + ,@(when (and (os-windows-p) (not (getenvp "ALLEGRO_NOISY"))) + '("+c"))) + :quit-format "(excl:exit ~A :quiet t)" + :dump-format "(progn (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) (excl:dumplisp :name ~A :suppress-allegro-cl-banner t))"))))) + +(loop + :for (ecl-variant extraname flags) :in + '((:ecl "" ("-load" "sys:cmp")) + (:ecl_bytecodes " (using bytecodes compiler)" ("-eval" "(ext::install-bytecodes-compiler)"))) + :for fullname = (strcat "Embeddable Common-Lisp" extraname) + :do (register-lisp-implementation + ecl-variant + :fullname fullname + :name "ecl" + :feature :ecl + :environment-variable "ECL" + :flags `("-norc" ,@flags) + :eval-flag "-eval" ; -e + :load-flag "-load" + :image-flag nil + :image-executable-p t + :arguments-end "--" + :argument-control t ;; must be fixed now, but double-checking needed. + :disable-debugger () + :quit-format "(si:quit ~A)" + :dump-format nil)) ;; Cannot dump with ECL. Link instead. + + +(defun acceptable-eval-character-p (character) + "Is this character acceptable in an eval form, even when used under Windows?" + (let ((code (char-code character))) + (and (< 32 code 127) (not (find character "'\\\""))))) + +(defun acceptable-eval-symbol-character-p (character) + "Is this character acceptable as part of a symbol in an eval form, even when used under Windows?" + (let ((code (char-code character))) ;; assumes uppercase. + ;; No "modern" syntax accepted on the test master, though it can be used on the slave. + (and (< 32 code 91) (not (find character "'\\\":;"))))) + +(defun need-escape-within-pipe-p (character) + "Does this character need to be escaped when within symbol pipe notation?" + (or (eql character #\|) (eql character #\\))) + +(defun print-string-in-pipes (string &optional s) + (with-output (s) + (princ "|" s) + (let ((string (string string))) + (if (some 'need-escape-within-pipe-p string) + (loop :for c :across string :do + (when (need-escape-within-pipe-p c) (princ #\\ s)) + (princ c s)) + (princ string s))) + (princ "|" s))) + +(defun compose-eval-string (forms &optional s) + "Given a some FORMS, compose a string suitable to be passed for evaluation +to a Lisp implementation from the shell command-line with e.g. sbcl --eval or equivalent. +Output S is as specified as per WITH-OUTPUT. +FORMS may be a preformatted string, or a list of forms, where each form is either +a preformatted string, or a LIST that specifies a program." + (etypecase forms + ;; at the toplevel, a string mean "this is pre-formatted", you know what to pass to --eval + (string + (output-string forms s)) + (list + (with-standard-io-syntax + (let ((*package* (find-package :cl))) + (with-output (s) + (labels + ((p (x) (princ x s)) ;; princ + (w (x) (write x :stream s :case :downcase)) ;; write + (c (x) ;; form that evaluates into a character + (p "(code-char`") (p (char-code x)) (p ")")) + (sym (x) ;; print a symbol + ;; check that only good characters are used in a symbol; + ;; TODO: if not, go through a string (ugh!) + (assert (every 'acceptable-eval-symbol-character-p (package-name (symbol-package x)))) + (assert (every 'acceptable-eval-symbol-character-p (symbol-name x))) + (w x)) + (s (x) ;; form that evaluates into a string + (if (every 'acceptable-eval-character-p x) + (progn ;; simple string literal + (p "(string`") (print-string-in-pipes x s) (p ")")) + (progn + (p "(format()(string`|~{~a~}|)`(") + (loop + :with end = (length x) + :for start = 0 :then (if position (1+ position) end) + :for morep = (< start end) + :for position = (and morep + (position-if-not 'acceptable-eval-character-p x + :start start)) + :while morep + :do (when (or (null position) (< start position)) + (print-string-in-pipes (subseq x start position) s)) + (when position + (p ",") (c (char x position)))) + (p "))")))) + (n (x) ;; is it the easy case where no space is needed in the list? + (loop :for (a . d) :on x :do + (cond + ((null d) (return t)) + ((atom d) (return nil)) + ((or (typep a '(or null character string cons)) + (and (typep (car d) 'list) (n (car d))))) + (t (return nil))))) + (f (x) ;; top-level function to print a form without spaces, ' " \ + (etypecase x + (null (p "()")) + (symbol (sym x)) + (real (w x)) + (character (p "#.") (c x)) + (string (progn (p "#.") (s x))) + (cons + (if (n x) + (progn (p "(") (map () #'f x) (p ")")) + (progn (p "#.`") (b x)))))) + (b (x) ;; print a form that, when inside a backquote, evaluates to the form we want + (etypecase x + (null (p "()")) + (symbol (sym x)) + (real (w x)) + (character (p ",") (c x)) + (string (progn (p ",") (s x))) + (cons + (p "(") + (loop :for (a . d) :on x :do + (b a) + (cond + ((null d)) ;; Done: d is a close paren + ((typep a '(or null character string cons))) ;; Done: a ends with ) + ((atom d) + (p ",@") ;; NB: we rely on ,@ being the same as ., in practice + (typecase d + (character (c d)) + (string (s d)) + (real (w d)) + ((or keyword (eql t)) (sym d)) + (t (p "`") (b d)))) + ((typep (car d) '(or list character string))) ;; Done: d starts with , or ( + ((typep (car d) '(or real keyword boolean)) ;; insert a , before constant + (p ",")) + ((typep (car d) 'symbol) + (p ",`")) ;; insert a ,` before variable symbol + (t (error "foo")))) + (p ")"))))) + (p "(quote(") + (loop :for form :in forms :do + (p "#.") + (etypecase form + (string (p form)) ;; forms directly under the top-level can be preformatted, too + (list (f form)))) + (p "))")))))))) + +(defun compose-copy-paste-string (forms &optional s) + (etypecase forms + (string (output-string forms s)) + (list (format s "~{~A~%~}" + (with-standard-io-syntax + (let ((*package* (find-package :cl))) + (mapcar (lambda (x) (typecase x (string x) (t (write x :stream s :case :downcase)))) + forms))))))) + diff --git a/tools/load-asdf.lisp b/tools/load-asdf.lisp new file mode 100644 index 000000000..6b29c92d2 --- /dev/null +++ b/tools/load-asdf.lisp @@ -0,0 +1,190 @@ +;;; 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. +;;; +;;; We have to play games with packages because on some implementations, +;;; an ASDF upgrade from ASDF 2 can throw away the previous package. +;;; +;;; Everything is MUCH simpler if you can assume your implementation has a recent-enough ASDF 3: +;;; see the commented out alternative below. +;;; +;;; To use the user-configured ASDF rather than a deterministic self-contained project build, +;;; see instead how cl-launch 4.0.4 loads ASDF. +;;; Actually, if you can assume that your implementation or distribution provides ASDF 3, +;;; you may simply use cl-launch, and achieve a deterministic self-contained project build +;;; by having your shell configuration or some shell wrapper script export a proper values +;;; for the CL_SOURCE_REGISTRY and ASDF_OUTPUT_TRANSLATIONS environment variables. + +(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) + (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*))) + "1.0"))) + (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) + parent)) + (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 + (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") + (configure-asdf))) + (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 + (required-asdf-version () "3.1.2") ;; In the end, we want at least ASDF 3.1.2 + (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))) + (source-registry + (or (asdf-call 'getenv "ASDF_DEVEL_SOURCE_REGISTRY") + `(:source-registry + (:tree ,source-directory) + ;; In a fully controlled build, you'd :ignore-inherited-configuration instead: + :inherit-configuration))) + (output-directory + ;; There again, you might want to use some getenv variant. + ;; Also, "fasls" might be redundant for your project. + (subpath source-directory :directory '("build" "fasls"))) + (output-translations + `(:output-translations + ;; 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. + :ignore-inherited-configuration))) + ;; 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 + (load-and-configure-asdf))) + +#| +;;; Here is the much simpler code when you can assume +;;; your implementation provides ASDF 3 (i.e. at least pre-release ASDF 2.27). +;;; No package madness. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "asdf")) + +#-asdf3 (error "Your implementation fails to provide ASDF 3") + +(in-package :asdf) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; User-configurable parts + (let* ((required-asdf-version "3.1.2") ;; In the end, we want at least ASDF 3.1.2 + (here-directory + (pathname-directory-pathname + (or *compile-file-truename* *load-truename* + (truename *default-pathname-defaults*)))) + (source-directory + ;; Here, define the top of your source code hierarchy. + ;; For your project, it could be something like + ;; (or (getenv-pathname "MY_PROJECT_ROOT" + ;; :want-absolute t :ensure-directory t) + ;; (subpathname here-directory "../../")) + (subpathname here-directory "../")) + (source-registry + ;; Here, define your source registry. + ;; For your project, it would be based solely on source-directory above, + ;; and in a fully controlled build, you'd :ignore-inherited-configuration + (or (getenvp "ASDF_DEVEL_SOURCE_REGISTRY") + `(:source-registry + (:tree ,source-directory) + :inherit-configuration))) + (output-directory + ;; There again, you might want to use some getenvp variant. + ;; Also, "fasls" might be redundant for your project. + (subpathname source-directory "build/fasls/")) + (output-translations + `(:output-translations + ;; 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. + :ignore-inherited-configuration))) + ;; No more user-configurable parts below. + ;; 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) + ;; Configure ASDF + (initialize-source-registry source-registry) + (initialize-output-translations output-translations) + ;; Upgrade to the latest configured version + (upgrade-asdf) + ;; Check that we have a satisfactorily version + (unless (version-satisfies (asdf-version) required-asdf-version) + (error "Please install an ASDF ~A or later" required-asdf-version)))) +|# diff --git a/tools/main.lisp b/tools/main.lisp new file mode 100644 index 000000000..a95255d55 --- /dev/null +++ b/tools/main.lisp @@ -0,0 +1,41 @@ +;;;; 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*))) diff --git a/tools/package.lisp b/tools/package.lisp new file mode 100644 index 000000000..e9936c65d --- /dev/null +++ b/tools/package.lisp @@ -0,0 +1,6 @@ +(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)) diff --git a/tools/pathnames.lisp b/tools/pathnames.lisp new file mode 100644 index 000000000..4f345d96d --- /dev/null +++ b/tools/pathnames.lisp @@ -0,0 +1,19 @@ +(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)) + diff --git a/tools/release.lisp b/tools/release.lisp new file mode 100644 index 000000000..74ef524d4 --- /dev/null +++ b/tools/release.lisp @@ -0,0 +1,189 @@ +(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")) + diff --git a/tools/test-all.lisp b/tools/test-all.lisp new file mode 100644 index 000000000..64cd023c3 --- /dev/null +++ b/tools/test-all.lisp @@ -0,0 +1,86 @@ +(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))) + diff --git a/tools/test-basic.lisp b/tools/test-basic.lisp new file mode 100644 index 000000000..34d9700d9 --- /dev/null +++ b/tools/test-basic.lisp @@ -0,0 +1,79 @@ +(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)) diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp new file mode 100644 index 000000000..5acee0cc6 --- /dev/null +++ b/tools/test-environment.lisp @@ -0,0 +1,206 @@ +(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) + +(defun make-target (target &rest env) + (map () 'test-definition env) + (shell-boolean-exit (main (list target)))) + +(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) + (loop :with argmap = + '((lisp ((lisp *test-lisps*)) + (setf lisp (get-lisp lisp))) + (lisps ((lisps *test-lisps*)) + (setf lisps (get-lisps lisps))) + (systems ((systems *test-systems*))) + (test-scripts ((test-scripts *test-scripts*)) + (setf test-scripts (get-test-scripts test-scripts))) + (upgrade-tags ((upgrade-tags *upgrade-test-tags*)) + (setf upgrade-tags (get-upgrade-tags upgrade-tags))) + (upgrade-methods ((upgrade-methods *upgrade-test-methods*)) + (setf upgrade-methods (get-upgrade-methods upgrade-methods)))) + :for arg :in args + :for (found larg init) = (assoc arg argmap) + :append (if found larg (list arg)) :into largs + :append (when found (list init)) :into inits + :finally + (multiple-value-bind (decl body) (decl-and-body decl-and-body) + (return + `(defun ,name (&optional ,@largs) + ,@decl + ,@inits + ,@body))))) + +(defun all-pass (&rest tests) + (every 'identity tests)) + +(defmacro defalias (name real) + `(defun ,name (&rest args) ,(format nil "alias for ~S" real) (apply ',real args))) + +(deftestcmd interactive-command (lisp) + (let* ((command (lisp-invocation-arglist :implementation-type lisp :debugger t))) + (cons "rlwrap" command))) + +(defparameter *default-test-lisps* + '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro + :lispworks :allegromodern :gcl :xcl :mkcl) + ;; NOT SUPPORTED BY OUR AUTOMATED TESTS: + ;; :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") + +(defun get-lisps (&optional (lisps *test-lisps*)) + (if (eq lisps :default) *default-test-lisps* (ensure-list-of-keywords lisps))) + +(defun get-lisp (&optional (lisp *test-lisps*)) + (if (and (keywordp lisp) (not (eq lisp :default))) lisp (first (get-lisps lisp)))) + +(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) + (declare (ignore second minute hour weekday daylight-savings-p timezone)) + (format nil "~4,'0D-~2,'0D-~2,'0D" year month date))) + +(deftestcmd newlogfile ((kind "log") lisp) + (let ((log (pn (format nil "build/results/~(~A-~A~).text" lisp kind)))) + (ensure-directories-exist log) + (if-let (date (safe-file-write-date log)) + (rename-file-overwriting-target + log (add-pathname-suffix log (strcat "-" (date-string date))))) + (with-output-file (s log)) + ;;(format t "Logging results to ~A" log) + log)) + +(defun log! (log fmt &rest args) + (let ((msg (apply 'format nil fmt args))) + (format t "~&~A~&" msg) + (when log + (with-output-file (s log :if-exists :append :if-does-not-exist :create) + ;; 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)) + +;; 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, +;; the quoting of which many Windows implementations get wrong. +;; 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-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...~%" activity) + (let* ((eval (compose-eval-string forms)) + (command (lisp-invocation-arglist :implementation-type (get-lisp lisp) + :eval eval :debugger debugger)) + (interactive (if (eq output :interactive) :interactive nil)) + (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 (out err code) + (run `(pipe ((>& 2 1) ,@(when interactive '(rlwrap)) ,@command) + ,@(when log `((tee -a ,log)))) + :input interactive :output output :error-output (or interactive :output) :on-error nil) + (unless interactive + (if (zerop code) + (log! log "SUCCEEDED at ~A." activity) + (log! log "FAILED at ~A. +You can retry ~A with: + ~A +or more interactively, start with: + ~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.) +then copy/paste: + ~A" + activity activity (print-process-spec command nil) + (interactive-command) (compose-copy-paste-string forms)))) + (values (zerop code) out err code)))) diff --git a/tools/test-scripts.lisp b/tools/test-scripts.lisp new file mode 100644 index 000000000..053c07f13 --- /dev/null +++ b/tools/test-scripts.lisp @@ -0,0 +1,84 @@ +(in-package :asdf-tools) + +(defparameter *default-test-scripts* '("*.script")) + +(defun get-test-scripts (&optional (test-scripts *test-scripts*)) + (if (eq test-scripts :default) (setf test-scripts *default-test-scripts*)) + (with-asdf-dir ("test/") + (sort + (loop :for pattern :in test-scripts + :append (loop :for file :in (directory* pattern) + :collect (enough-pathname file (pn "test/")))) + 'string< :key 'namestring))) + +#| +;; Somehow we never wrote the tests that check our configuration file infrastructure... +(defun create-config () + (dolist (x '("build/results/" "build/test-source-registry-conf.d/" + "build/test-asdf-output-translations-conf.d/")) + (ensure-directories-exist (pn x)))) + +(defun clean-config () + (flet ((rm-rf (x) + (delete-directory-tree (pn x) :validate (lambda (x) (subpathp x (pn "build/")))))) + (rm-rf "build/test-source-registry-conf.d/") + (rm-rf "build/test-asdf-output-translations-conf.d/"))) +|# + +(deftestcmd test-scripts (lisp test-scripts) + "run test scripts with the preferred lisp implementation" + (nest + (with-asdf-dir ("test/")) + (let* ((log (newlogfile "test" lisp)) + (scripts (get-test-scripts))) + (log! log "Running the following ~D ASDF test scripts on ~(~A~):~%~{ ~A~%~}" + (length scripts) lisp scripts) + (and + (run-test-lisp + "compiling ASDF" + '((load "script-support.lisp") (asdf-test::compile-asdf-script)) + :lisp lisp :log log) + (loop + :with n-tests = (length scripts) + :with test-pass = 0 + :with test-fail = 0 + :with failed-list = () + :for i :in scripts + :for ni = (native-namestring i) + :for test-count :from 0 + :do + ;; TODO: do we want to delete the output file cache? + ;; If so, we need to do it in the inferior lisp, + ;; because only it knows for sure its output configuration. + ;; Or we could do it in a more heavy handed way. + (if (run-test-lisp + (format nil "testing ~A on ~(~A~)" i lisp) + `((load "script-support.lisp") + (asdf-test::load-asdf) + (asdf-test::frob-packages) + (asdf-test::run-test-script ,ni)) + :lisp lisp :log log) + (incf test-pass) + (progn + (incf test-fail) + (push i failed-list))) + :finally + (let ((okp (zerop test-fail))) + (format t "~ +-#--------------------------------------- +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: + less -p ABORTED ~A" (enough-namestring log (pn)))) + (return okp))))))) + +(deftestcmd %test (lisp test-scripts) + "run all normal tests (excluding upgrade tests) with the preferred lisp implementation" + (all-pass (test-scripts lisp test-scripts) (doc) (test-clean-load lisp))) + +(defalias %t %test) diff --git a/tools/test-upgrade.lisp b/tools/test-upgrade.lisp new file mode 100644 index 000000000..51e0740d4 --- /dev/null +++ b/tools/test-upgrade.lisp @@ -0,0 +1,145 @@ +(in-package :asdf-tools) + +;;; 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. + '("REQUIRE" ;; a magic tag meaning whatever your implementation provides, if anything + + ;; The 3.1 series provides the asdf3.1 feature, meaning users can rely on + ;; all the stabilization work done in 3.0 so far, plus extra developments + ;; in UIOP, package-inferred-system, and more robustification. + "3.1.2" ;; (2014-05-06) the first ASDF 3.1 release + + ;; The 3.0 series is a stable release of ASDF 3 + ;; with Robert Goldman taking over maintainership at 3.0.2. + ;; 3.0.0 was just 2.33.10 promoted, but version-satisfies meant it was suddenly + ;; not compatible with ASDF2 anymore, so we immediately released 3.0.1 + "3.0.3" ;; (2013-10-22) the last in the ASDF 3.0 series + "3.0.2" ;; (2013-07-02) the first ASDF 3 in SBCL + "3.0.1" ;; (2013-05-16) the first stable ASDF 3 release + + ;; 2.27 to 2.33 are Faré's "stable" ASDF 3 pre-releases + "2.32" ;; (2013-03-05) the first really stable ASDF 3 pre-release + "2.27" ;; (2013-02-01) the first ASDF 3 pre-release + + ;; The ASDF 2 series + ;; Note that 2.26.x is where the refactoring that begat ASDF 3 took place. + ;; 2.26.61 is the last single-file, single-package ASDF. + "2.26" ;; (2012-10-30) the last stable ASDF 2 release, long used by Quicklisp, SBCL, etc. + "2.22" ;; (2012-06-12) used by debian wheezy, etc. + "2.20" ;; (2012-01-18) in CCL 1.8, Ubuntu 12.04 LTS + "2.019" ;; (2011-11-29) still included in LispWorks in 2014. + "2.014.6" ;; (2011-04-06) first included in Quicklisp, and for some time. + "2.011" ;; (2010-12-09) long used by CLISP 2.49, Debian squeeze, Ubuntu 10.04 LTS. + "2.008" ;; (2010-09-10) somewhat stable checkpoint in the ASDF 2 series. + "2.000" ;; (2010-05-31) first stable ASDF 2 release. + + ;; The original ASDF 1 series + "1.369" ;; (2009-10-27) the last release by Gary King + "1.85" ;; (2004-05-16) the last release by Daniel Barlow (not 1.37, which is the README revision!) + "1.97")) ;; (2006-05-14) the last release before Gary King takes over + +(defun get-upgrade-tags (&optional (x *upgrade-test-tags*)) + (if (eq x :default) *default-upgrade-test-tags* x)) + +(defun extract-tagged-asdf (tag) + (with-asdf-dir () + (ensure-directories-exist (pn "build/")) + (unless (string-equal tag "REQUIRE") + (let ((file (pn (strcat "build/asdf-" tag ".lisp")))) + (unless (probe-file file) + (cond + ((version<= tag "2.26.61") + (git `(show (,tag ":asdf.lisp") (> ,file)))) + (t + (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)))))))) + +(deftestcmd extract-all-tagged-asdf (upgrade-tags) + (map () 'extract-tagged-asdf upgrade-tags)) +(defalias extract extract-all-tagged-asdf) + +(defparameter *upgrade-test-methods* :default) + +(defparameter *all-upgrade-test-methods* + '((:load-asdf-lisp :load-asdf-lisp-clean) + (:load-asdf-lisp :load-asdf-system) + (:load-asdf-lisp :compile-load-asdf-upgrade) + (:load-asdf-lisp :load-asdf-fasl) + (() :load-asdf-fasl) + (:load-asdf-lisp-and-test-uiop :load-asdf-fasl))) + +(defun get-upgrade-methods (&optional (x *upgrade-test-methods*)) + (if (eq x :default) *all-upgrade-test-methods* x)) + +(defun valid-upgrade-test-p (lisp tag method) + (declare (ignore method)) + (or + (string-equal tag "REQUIRE") ;; we are hopefully always able to upgrade from REQUIRE + (ecase lisp + ;; ABCL makes it damn slow. Also, for some reason, we punt on anything earlier than 2.25, + ;; and only need to test it once, below for 2.24. + ((:abcl) (version<= "2.24" tag)) + + ;; CCL fasl numbering broke loading of old asdf 2.0 + ((:ccl) (or (version< tag "2.0") (version<= "2.20" tag))) + + ;; My old Ubuntu 10.04LTS clisp 2.44.1 came wired in + ;; with an antique ASDF 1.374 from CLC that can't be removed. + ;; More recent CLISPs work. + ;; 2.00[0-7] use UID, which fails on some old CLISPs. + ;; Note that for the longest time, CLISP has included 2.011 in its distribution. + ;; However, the was we punt or don't punt, these should all work. + ((:clisp) t) + + ;; CMUCL has problems with 2.32 and earlier because of + ;; the redefinition of system's superclass component. + ((:cmucl) (version<= "2.33" tag)) + + ;; Skip many ECL tests, for various ASDF issues + ((:ecl) (version<= "2.21" tag)) + + ;; GCL 2.7.0 from late November 2013 is required, with ASDF 3.1.2 + ((:gcl) (version<= "3.1.2" tag)) + + ;; MKCL is only supported starting with specific versions 2.24, 2.26.x, 3.0.3.0.x, so skip. + ((:mkcl) (version<= "3.1.2" tag)) + + ;; XCL support starts with ASDF 2.014.2 + ;; — It also dies during upgrade trying to show the backtrace. + ;; We recommend you replace XCL's asdf using the install-asdf-as-module script. + ((:xcl) (version<= "2.15" tag)) + + ;; all clear on these implementations + ((:allegro :lispworks :sbcl :scl) t)))) + +(deftestcmd test-upgrade (lisp upgrade-tags upgrade-methods) + "run upgrade tests with the preferred lisp implementation" + (nest + (with-asdf-dir ()) + (let ((log (newlogfile "upgrade" lisp))) + ;; Remove stale FASLs from ASDF 1.x, + ;; especially since different implementations may have the same fasl type + (dolist (pattern '("build/*.*f*" "uiop/*.*f*" "test/*.*f*")) + (map () 'delete-file (directory* pattern)))) + (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)))) + +(defalias u test-upgrade) + diff --git a/tools/version.lisp b/tools/version.lisp new file mode 100644 index 000000000..b65f3d2f2 --- /dev/null +++ b/tools/version.lisp @@ -0,0 +1,128 @@ +(in-package :asdf-tools) + +;;; Extracting version information + +(defparameter *version-tag-glob* "[0-9][.][0-9]*") + +(defun version-from-tag (&optional commit) + (git `(describe --tags --match ,*version-tag-glob* ,commit) + :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) + ver))) + +(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* :default) +(defparameter *new-version* :default) + +(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) + (when (eq v1 :default) (setf v1 (version-from-file))) + (when (eq v2 :default) (setf v2 (next-version (or v1 (version-from-file))))) + (labels ((check (old new) + (parse-version old 'error) + (parse-version new 'error) + (values old new))) + (cond + ((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)) + 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 ")")) + (replacement + (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 (&key (from *old-version*) (to *new-version*)) + (with-asdf-dir () + (multiple-value-bind (old-version new-version) + (versions-from-args from to) + (format t "Bumping ASDF version from ~A to ~A~%" old-version new-version) + (transform-files new-version) + (println "Rebuilding ASDF with bumped version") + (build-asdf) + new-version))) + +(defun bump (&key (from *old-version*) (to *new-version*)) + (let ((v (bump-version :from from :to to))) + (git `(commit -a -m ("Bump version to ",v))) + (git `(tag ,v)) + v)) + +(trace bump-version versions-from-args) -- GitLab