":" ; 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" "$@" ;;; 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, ;;; so that you may 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's 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 `(: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)))) (in-package :asdf) (eval-when (:compile-toplevel :load-toplevel :execute) (load-systems :cl-ppcre :fare-utils :inferior-shell)) (unless (featurep :cl-launch) (restore-image)) (defpackage :asdf-builder (:use :cl :uiop :asdf/operate :asdf :fare-utils :inferior-shell) (:shadow #:DBG)) (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)) (defparameter /asdf-dir/ (native-namestring *asdf-dir*)) (defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys)) ;;; 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)) ;;; build directory (defparameter *build-dir* (ensure-pathname "build/" :defaults *asdf-dir* :want-relative t :ensure-absolute t :ensure-subpath t)) (defparameter /build-dir/ (native-namestring *build-dir*)) (defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys)) (defparameter *version* (safe-read-file-form (subpathname *asdf-dir* "version.lisp-expr"))) (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) (let* ((sys (find-system system)) (dir (ensure-pathname (system-source-directory sys) :want-absolute t :want-directory t)) (components (required-components sys :other-systems nil :goal-operation 'load-op :keep-operation 'load-op :keep-component 'file-component)) (pathnames (mapcar 'component-pathname components))) (enough-namestrings dir pathnames))) (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/ (native-namestring (ensure-pathname base :want-absolute t :want-directory t :want-existing t :truename t))) (destination (ensure-pathname name :defaults *build-dir* :want-relative t :ensure-absolute t :ensure-subpath t :ensure-directory t)) (/destination/ (native-namestring destination)) (/tarball/ (native-namestring (ensure-pathname (tarname name) :defaults *build-dir* :want-relative t :ensure-absolute t :ensure-subpath t :want-file t :ensure-directories-exist t))) (/files/ (mapcar 'native-namestring files))) (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 (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/))) (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) *uiop-dir* (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) *asdf-dir* (asdf-defsystem-files))) (defun asdf-git-name () (format nil "asdf-~A" *version*)) (defun make-git-tarball () (build-asdf) (run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)" /asdf-dir/ (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 (apath "build/asdf.lisp")) (bpath (asdf-lisp-name)))) (defun make-archive () (make-driver-tarball) (make-asdf-defsystem-tarball) (make-git-tarball) (make-asdf-lisp) (values)) (defvar *clnet* "common-lisp.net") (defvar *clnet-asdf-public* "/project/asdf/public_html/") (defun publish-archive () (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name))))) (run (format nil "cd ~S && rsync ~{~S ~}~S common-lisp.net:/project/asdf/public_html/archives/" /build-dir/ tarballs (asdf-lisp-name)) :show t)) (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)) (strcat *clnet-asdf-public* "archives/uiop.tar.gz") (tarname (asdf-defsystem-name)) (strcat *clnet-asdf-public* "archives/asdf-defsystem.tar.gz") (tarname (asdf-git-name)) (strcat *clnet-asdf-public* "archives/asdf.tar.gz") (asdf-lisp-name) (strcat *clnet-asdf-public* "archives/asdf.lisp")) :show t :host *clnet*) (values)) (defun make-and-publish-archive () (make-archive) (publish-archive) (link-archive)) (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 *version-file* (apath "version.lisp-expr")) (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 version-from-file () (safe-read-file-form *version-file*)) (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 (apath 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)))) (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) (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))) (defun git-version () (first (run/lines '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :show t))) ;;;; Main entry point (defun main (args) (block nil (unless args (format t "No command provided~%") (return)) (if-let (sym (find-symbol* (string-upcase (first args)) :asdf-builder nil)) (let ((results (multiple-value-list (apply sym (rest args))))) (when results (format t "~&Results:~%~{ ~S~%~}" results))) (format t "Command ~A not found~%" (first args))))) (main *command-line-arguments*)