Commit 3574f2a5 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Tweak the debian release script...

parent 7f154f4a
......@@ -200,13 +200,11 @@ extract-all-tagged-asdf: build/asdf.lisp
# Note that the debian git at git:// is stale,
# as we currently build directly from upstream at git://
debian-package: mrproper
: $${RELEASE:="$$(git tag -l '3.[0-9].[0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \
git-buildpackage --git-debian-branch=release --git-upstream-branch=release --git-upstream-tag=$$RELEASE --git-tag --git-retag --git-ignore-branch
./bin/asdf-builder debian-package release
debian-package-from-master: mrproper
: $${RELEASE:="$$(git tag -l '3.[0-9].[0-9]' | tail -n 1)"} ; echo building package version $$RELEASE ; \
git-buildpackage --git-debian-branch=master --git-upstream-branch=master --git-upstream-tag=$$RELEASE --git-tag --git-retag --git-ignore-branch
./bin/asdf-builder debian-package master
# Replace SBCL's ASDF with the current one. -- NOT recommended now that SBCL has ASDF2.
......@@ -8,7 +8,7 @@
;;; 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,
;;; so that you may use asdf: and uiop: prefix.
;;; 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.
......@@ -146,29 +146,23 @@
(ensure-pathname (system-relative-pathname :asdf/defsystem ())
:want-physical t :want-absolute t
:want-existing t :truename t))
(defparameter /asdf-dir/
(native-namestring *asdf-dir*))
(defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys))
(defun pn (&rest x)
(subpathname *asdf-dir* (and x (uiop:resolve-relative-location x))))
(defun nn (&rest x)
(native-namestring (apply 'pn x)))
;;; UIOP directory
(defvar *uiop-dir* (subpathname *asdf-dir* "uiop/"))
(defparameter /uiop-dir/ (native-namestring *uiop-dir*))
(defun upath (x &rest keys) (apply 'subpathname *uiop-dir* x keys))
(defvar *uiop-dir* (pn "uiop/"))
;;; build directory
(defparameter *build-dir*
"build/" :defaults *asdf-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t))
(defparameter /build-dir/
(native-namestring *build-dir*))
(defparameter *build-dir* (pn "build/"))
(defparameter /build-dir/ (nn "build/"))
(defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys))
(defparameter *version*
(subpathname *asdf-dir* "version.lisp-expr")))
(defparameter *version-file*
(pn "version.lisp-expr"))
(defparameter *version* (safe-read-file-form *version-file*))
(defun enough-namestring! (base pathname)
(let ((e (enough-namestring base pathname)))
......@@ -201,40 +195,32 @@
(ensure-pathname base :want-absolute t :want-existing t :want-directory t)
(dolist (f files)
(check-type f string))
(let* ((/base/
:want-absolute t :want-directory t
:want-existing t :truename t)))
(let* ((base
:want-absolute t :want-directory t
:want-existing t :truename t))
:defaults *build-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t :ensure-directory t))
(native-namestring destination))
(tarname name)
:defaults *build-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t :want-file t
:ensure-directories-exist t)))
(mapcar 'native-namestring files)))
(tarname name)
:defaults *build-dir*
:want-relative t :ensure-absolute t
:ensure-subpath t :want-file t
:ensure-directories-exist t)))
(assert (< 6 (length (pathname-directory destination))))
(when (probe-file* destination)
(error "Destination ~S already exists, not taking chances - you can delete it yourself."
(ensure-directories-exist destination)
(run (format nil "cd ~S && cp -pHux --parents ~{~S ~} ~S"
/base/ /files/ /destination/) :show t)
(run (format nil "tar zcfC ~S ~S ~S/"
/tarball/ /build-dir/ name) :show t)
(delete-directory-tree destination :validate (lambda (x) (equal (native-namestring x) /destination/)))
(run `(cp "-pHux" --parents ,@files ,destination) :directory base :show t)
(run `(tar "zcfC" ,tarball ,*build-dir* (,name /)) :show t)
(delete-directory-tree destination :validate (lambda (x) (equal x destination)))
(defun driver-files ()
......@@ -254,11 +240,12 @@
(make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files)))
(defun asdf-git-name ()
(format nil "asdf-~A" *version*))
(strcat "asdf-" *version*))
(defun make-git-tarball ()
(run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ (asdf-git-name)) :show t)
(with-current-directory ((pn))
(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 ()
......@@ -266,8 +253,8 @@
(defun make-asdf-lisp ()
(concatenate-files (list (apath "build/asdf.lisp"))
(bpath (asdf-lisp-name))))
(concatenate-files (list (pn "build/asdf.lisp"))
(pn "build/" (asdf-lisp-name))))
(defun make-archive ()
......@@ -278,6 +265,7 @@
(defvar *clnet* "")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")
(defun public-path (x) (strcat *clnet-asdf-public* x))
(defun publish-archive ()
(let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
......@@ -291,13 +279,13 @@
(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))
(strcat *clnet-asdf-public* "archives/uiop.tar.gz")
(public-path "archives/uiop.tar.gz")
(tarname (asdf-defsystem-name))
(strcat *clnet-asdf-public* "archives/asdf-defsystem.tar.gz")
(public-path "archives/asdf-defsystem.tar.gz")
(tarname (asdf-git-name))
(strcat *clnet-asdf-public* "archives/asdf.tar.gz")
(public-path "archives/asdf.tar.gz")
(strcat *clnet-asdf-public* "archives/asdf.lisp"))
(public-path "archives/asdf.lisp"))
:show t :host *clnet*)
......@@ -312,9 +300,6 @@
("header.lisp" "This is ASDF " ": Another System Definition Facility.")
("upgrade.lisp" " (asdf-version \"" "\")")))
(defparameter *version-file*
(apath "version.lisp-expr"))
(defparameter *old-version* nil)
(defparameter *new-version* nil)
......@@ -376,13 +361,13 @@
(values new-text foundp)))))
(defun transform-file (new-version file prefix suffix)
(maybe-replace-file (apath file) (version-transformer 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 (apath file))))
(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)
......@@ -402,9 +387,53 @@
(a "Rebuilding ASDF with bumped version")
(defun git-version ()
(first (run/lines '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :show t)))
(defparameter *version-tag-glob* "[0-9][.][0-9]*")
(defun version-from-tag (&optional commit)
(first (run/lines `("git" "describe" "--tags" "--match" ,*version-tag-glob*) :show t)))
(defun version-from-file (&optional commit)
(if commit
(run `("git" "show" (,commit":version.lisp-expr")) :output :form)
(read-file-form *version-file*)))
(defun debian-version-from-file (&optional commit)
(let ((line
(if commit
(run `("git" "show" (,commit":debian/changelog")) :output :line)
(read-file-line "debian/changelog"))))
(cl-ppcre:register-groups-bind (ver) ("^cl-asdf [(]([0-9.:-]+)[)] " line)
(defun clean ()
(with-current-directory ((pn))
(run '(git clean -xfd)))
(defun debian-package (&optional (release "release"))
(let* ((debian-version (debian-version-from-file release))
(version (version-from-file release)))
(unless (cl-ppcre:register-groups-bind (x epoch ver rel)
("^(([0-9]+):)?([0-9.]+)-([0-9]+)$" debian-version)
(declare (ignorable x epoch rel))
(equal ver version))
(error "Debian version ~A doesn't match asdf version ~A" debian-version version))
(format t "building package version ~A~%" (debian-version-from-file))
(run `(git-buildpackage
;; --git-ignore-new ;; for testing purpose
(--git-debian-branch= ,release)
;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
--git-tag --git-retag
;; --git-no-pristine-tar
:directory (pn) :show t)))
(defun re (arg)
(eval (read-from-string arg)))
;;;; Main entry point
(defun main (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