Commit 61c470b1 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Add help, flesh out release function.

parent 80096b73
......@@ -3,18 +3,19 @@
: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"))
(:version "lisp-invocation" "1.0.2")
(:feature :sbcl "sb-introspect"))
((: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 "release" :depends-on ("version" "test-environment"))
(:file "main" :depends-on ("package"))))
......@@ -4,13 +4,18 @@
;; Note that the debian git at git:// is stale,
;; as we currently build directly from upstream at git://
(defun git (cmd &rest args)
(defun run* (cmd &rest keys)
(multiple-value-bind (out err code)
(apply 'run cmd keys)
(values (eql 0 code) out err code)))
(defun git (cmd &rest keys)
(with-asdf-dir ()
(apply 'run (cons "git" cmd) args)))
(apply 'run* (cons "git" cmd) keys)))
(defun clean ()
(git '(clean -xfd))
(defun %push ()
"Push git branches master and release to and master"
......@@ -3,20 +3,69 @@
(in-package :asdf-tools)
(defun re (arg)
;;; Read-Eval function (the RE of REPL; the Print and Loop parts are not here)
"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"
"Find the function for an asdf-tools 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
(when (and sym foundp (fboundp sym))
(return sym)))))
(try (strcat "%" (string x))) ;; so that you may use load, t, etc., as targets
(try x))))
(defun command-name (x)
(let ((c (find-command x)))
(when c
(let ((s (string-downcase c)))
(if (eql (first-char s) #\%) (subseq s 1) s)))))
(defun short-function-description (x)
"Short function description for x"
(when (stringp x) (setf x (find-command x)))
(if-let ((doc (and x (documentation x 'function))))
(let* ((first-line (with-input (s doc) (read-line s)))
(len (length first-line)))
(if (>= len 50) (strcat (subseq first-line 0 49) "…") first-line))))
(defun find-commands ()
;;(loop :for x :being :the :external-symbols :of :asdf-tools
;; :when (and (eq x (find-command x)) (documentation x 'function)) :collect x)
'(build-asdf doc website wc ;; build
clean %push merge-master-into-release fix-local-git-tags fix-remote-git-tags ;; git
bump-version bump ;; version
test-load-systems test-clean-load test-basic %load install-asdf ;; test-basic
%test %t test-scripts ;; test-scripts
test-upgrade u extract-tagged-asdf extract-all-tagged-asdf extract ;; test-upgrade
test-all-clean-load test-all-lisp test-all-no-upgrade test-all-upgrade ;; test-all
test-all-scripts test-all test-all-scripts-no-stop test-all-upgrade-no-stop
test-all-no-upgrade-no-stop test-all-no-stop
check-all-scripts-results check-all-upgrade-results check-all-results
driver-files asdf-defsystem-files ;; release
make-archive publish-archive link-archive archive install
debian-package debian-architecture publish-debian-package
re help)) ;; main
(defun help (&optional x)
"List available commands, or the docstring of a given command"
((null x)
(loop :for x :in (sort (find-commands) 'string< :key 'find-command)
:do (format t "~(~27A~)~@[ ~A~]~%"
(command-name x) (short-function-description x))))
(let ((x (find-command x)))
(when x
(format t "~A~@[ ~A~]~%~@[~A~]~&"
(command-name x)
(or ()) ;; TODO: remember the arguments to deftestcmd, translate to v=, etc
(documentation x 'function)))))))
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
(defun main (args)
(defpackage :asdf-tools
(:use :common-lisp :uiop :asdf :fare-utils :inferior-shell :lisp-invocation :cl-ppcre))
(:use :common-lisp :uiop :asdf
:fare-utils :inferior-shell :lisp-invocation :cl-ppcre)
(:export)) ;; TODO: export stuff
;; Just so we can use the name in our test scripts...
(defpackage :asdf-test
......@@ -88,7 +88,7 @@
(with-asdf-dir ()
(run `(tar zcf ("build/" ,(asdf-git-name) ".tar.gz") build/asdf.lisp ,@(run/lines '(git ls-files))
(asdf-git-name)) :show t))
(defun asdf-lisp-name ()
(format nil "asdf-~A.lisp" *version*))
......@@ -103,7 +103,7 @@
;;; Publishing tarballs onto the public repository
......@@ -119,7 +119,7 @@
(format t "~&To download the tarballs, point your browser at:~%
(defun link-archive ()
(run (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
......@@ -132,7 +132,7 @@
(public-path "archives/asdf.lisp"))
:show t :host *clnet*)
(defun make-and-publish-archive ()
......@@ -147,10 +147,7 @@
(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))
(unless (equal version (parse-debian-version debian-version))
(error "Debian version ~A doesn't match asdf version ~A" debian-version version))
(format t "building package version ~A~%" (debian-version-from-file))
......@@ -166,24 +163,42 @@
: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"))
(defun debian-architecture ()
(run/ss `(dpkg --print-architecture)))
(defun publish-debian-package (&optional release)
(let ((changes (strcat "cl-asdf_" (debian-version-from-file release)
"_" (debian-architecture) ".changes")))
(run* `(dput mentors ,(pn "../" changes)))))
(deftestcmd release (new-version lisps scripts systems)
"Release the code (not implemented)"
(break) ;; for each function, offer to do it or not (?)
(with-asdf-dir ()
(let ((log (newlogfile "release" "all"))
(releasep (= (length (parse-version new-version)) 3)))
(when releasep
(let ((debian-version (debian-version-from-file)))
(unless (equal new-version (parse-debian-version debian-version))
(error "You're trying to release version ~A but the debian/changelog wasn't properly updated"
(when (nth-value 1 (run '(parse-changelog debian/changelog) :output nil :error-output :lines))
(error "Malformed debian/changelog entry")))
(and ;; need a better combinator, that tells us about progress, etc.
(test-all-no-stop) ;; NEED ARGUMENTS!
(test-load-systems lisps systems)
(bump new-version)
(when releasep
;; SUCCESS! now publish more widely
(when releasep
(log! log t "Don't forget to send a debian mentors request!"))
(log! log "Don't forget to send announcement to asdf-announce, asdf-devel, etc.")
(log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad")))))
......@@ -24,12 +24,12 @@
"test that all lisp implementations pass all asdf upgrade tests"
(with-all-lisps (*upgrade-test-lisps*) (test-upgrade)))
(deftestcmd test-all-lisps ()
(deftestcmd test-all-scripts ()
"test that all lisp implementations pass all asdf tests"
(all-pass (test-all-no-upgrade) (test-all-upgrade)))
(defalias test-all test-all-lisps)
(defalias test-all test-all-scripts)
(deftestcmd test-all-lisp-no-stop ()
(deftestcmd test-all-scripts-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))))
......@@ -44,19 +44,19 @@
(deftestcmd test-all-no-stop ()
(deftestcmd test-all-no-stop () ;; TODO: pass arguments!
"test that all lisp implementations pass all asdf tests (including upgrade), but don't stop on error."
(deftestcmd check-all-test-results ()
(deftestcmd check-all-scripts-results ()
"were there errors in test scripts?"
(with-asdf-dir ()
(let ((a (run/lines
......@@ -82,5 +82,5 @@
(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)))
(all-pass (check-all-scripts-results) (check-all-upgrade-results)))
......@@ -107,7 +107,9 @@
(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))))
(setf upgrade-methods (get-upgrade-methods upgrade-methods)))
(new-version (new-version)
(setf new-version (or new-version (next-version (version-from-file))))))
:for arg :in args
:for (found larg init) = (assoc arg argmap)
:append (if found larg (list arg)) :into largs
......@@ -157,7 +159,7 @@
(if-let (date (safe-file-write-date log))
log (add-pathname-suffix log (strcat "-" (date-string date)))))
(with-output-file (s log))
(with-output-file (s log)) ;; create the file
;;(format t "Logging results to ~A" log)
......@@ -187,20 +189,20 @@
(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)
(multiple-value-bind (okp 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.
(log! log (if okp
"FAILED at ~A.
You can retry ~A with:
or more interactively, start with:
~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.)
then copy/paste:
activity activity (print-process-spec command nil)
(interactive-command) (compose-copy-paste-string forms))))
(values (zerop code) out err code))))
activity activity (print-process-spec command nil)
(interactive-command) (compose-copy-paste-string forms)))
(values okp out err code))))
......@@ -48,6 +48,7 @@
(if (eq x :default) *default-upgrade-test-tags* x))
(defun extract-tagged-asdf (tag)
"Extract an ASDF version at a given tag from git under build/asdf-${tag}.lisp"
(with-asdf-dir ()
(ensure-directories-exist (pn "build/"))
(unless (string-equal tag "REQUIRE")
......@@ -21,6 +21,14 @@
(cl-ppcre:register-groups-bind (ver) ("^cl-asdf [(]([0-9.:-]+)[)] " line)
(defun parse-debian-version (&optional (debian-version (debian-version-from-file)))
(cl-ppcre:register-groups-bind (epoch ver rel)
("^(?:([0-9]+):)?([0-9.]+)(?:-([0-9]+))$" debian-version)
;; NB: (A) we return version first, not epoch, because it's the primary result!
;; (B) epoch = nil is semantically same as epoch = 0
;; (C) rel = nil is for debian-native packages, e.g. base-passwd or cowbuilder
(values ver epoch rel)))
(defparameter *version* (version-from-file))
;;; Bumping the version of ASDF
......@@ -44,8 +52,6 @@
(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)
......@@ -53,6 +59,7 @@
((and v1 v2) (check v1 v2))
(v1 (check (version-from-file) v1))
((not (eq *new-version* :default)) *new-version*) ;; Ugly passing of argument from Makefile.
(t (let ((old (version-from-file)))
(check old (next-version old)))))))
......@@ -109,20 +116,20 @@
(defun test-transform (new-version)
(apply 'test-transform-file new-version (first *versioned-files*)))
(defun bump-version (&key (from *old-version*) (to *new-version*))
(defun bump-version (&optional v1 v2)
"bump version of ASDF to specified version or next development version (do not commit)."
(with-asdf-dir ()
(multiple-value-bind (old-version new-version)
(versions-from-args from to)
(versions-from-args v1 v2)
(format t "Bumping ASDF version from ~A to ~A~%" old-version new-version)
(transform-files new-version)
(println "Rebuilding ASDF with bumped version")
(defun bump (&key (from *old-version*) (to *new-version*))
(let ((v (bump-version :from from :to to)))
(defun bump (&optional v1 v2)
"bump version of ASDF to specified version or next development version, then commit and tag."
(let ((v (bump-version v1 v2)))
(git `(commit -a -m ("Bump version to ",v)))
(git `(tag ,v))
(trace bump-version versions-from-args)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment