asdf-builder 9.74 KB
Newer Older
1 2 3 4 5 6
":" ; exec sbcl --script "$0" "$@" ; exit # -*- Lisp -*-
;;;;; Really runs on any decent Common Lisp implementation

(load (make-pathname :name "prelude" :type "lisp" :defaults *load-pathname*)
  :verbose nil :print nil)

7
(defpackage :asdf-builder (:use :cl :asdf/driver :asdf/operate :asdf :fare-utils :inferior-shell))
8 9 10 11 12
(in-package :asdf-builder)

(asdf-debug)

(defun build-asdf ()
13
  "Make sure asdf.lisp is built"
14 15
  (load-system :asdf)
  (values))
16 17 18 19 20 21


;;; ASDF directory
(defvar *asdf-dir*
  (ensure-pathname (system-relative-pathname :asdf ())
                   :want-physical t :want-absolute t
22
                   :want-existing t :truename t))
23 24 25 26 27 28 29 30 31 32 33 34 35
(defparameter /asdf-dir/
  (native-namestring *asdf-dir*))
(defun apath (x &rest keys) (apply 'subpathname *asdf-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*))
36
(defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys))
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57

(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 base)))

(defun system-source-files (system)
  (let* ((sys (find-system system))
         (dir (ensure-pathname
               (system-source-directory sys)
               :want-absolute t :want-directory t))
         (components
58
           (asdf::required-components
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
            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
78
             :want-existing t :truename t)))
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101
         (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)
102 103 104 105 106 107
    (run (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
                 /base/ /files/ /destination/) :show t)
    (run (format nil "tar zcfC ~S ~S ~S/"
                 /tarball/ /build-dir/ name) :show t)
    (run `("rm" "-rf" ,/destination/) :show t)
    (values)))
108 109 110 111 112 113 114 115 116

(defun driver-files ()
  (list* "asdf-driver.asd" "version.lisp-expr"
         (system-source-files :asdf-driver)))
(defun driver-name ()
  (format nil "asdf-driver-~A" *version*))
(defun make-driver-tarball ()
  (make-tarball-under-build (driver-name) *asdf-dir* (driver-files)))

117
(defun asdf-defsystem-files ()
118
  (list* "asdf.asd" "build/asdf.lisp" "version.lisp-expr" "header.lisp"
119 120
         (system-source-files :asdf/defsystem)))
(defun asdf-defsystem-name ()
121
  (format nil "asdf-defsystem-~A" *version*))
122
(defun make-asdf-defsystem-tarball ()
123
  (build-asdf)
124
  (make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files)))
125

126 127
(defun asdf-git-name ()
  (format nil "asdf-~A" *version*))
128
(defun make-git-tarball ()
129
  (build-asdf)
130 131
  (run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)"
               /asdf-dir/ (asdf-git-name)) :show t)
132
  (values))
133

134 135 136 137 138 139 140 141 142
(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 ()
143
  (make-driver-tarball)
144
  (make-asdf-defsystem-tarball)
145
  (make-git-tarball)
146
  (make-asdf-lisp)
147 148
  (values))

149 150 151 152
(defvar *clnet* "clnet")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")

(defun publish-archive ()
153
  (let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
154 155
    (run (format nil "cd ~S && rsync ~{~S ~}~S clnet:/project/asdf/public_html/archives/"
                 /build-dir/ tarballs (asdf-lisp-name)) :show t))
156 157 158 159 160
  (format t "~&To download the tarballs, point your browser at:~%
        http://common-lisp.net/project/asdf/archives/
~%")
  (values))

161 162 163 164 165 166 167 168 169 170
(defun link-archive ()
  (run `(ln -sf ,(tarname (driver-name))
            (,*clnet-asdf-public* "archives/asdf-driver.tar.gz"))
       :show t :host *clnet*)
  (values))

(defun make-and-publish-archive ()
  (make-archive)
  (publish-archive)
  (link-archive))
171 172 173

(defparameter *versioned-files*
  '(("version.lisp-expr" "\"" "\"")
174
    ("asdf.asd" "  :version \"" "\" ;; to be automatically updated by make bump-version")
175 176 177 178 179 180 181 182 183 184 185
    ("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)))
186 187 188
    (assert (first pv))
    (assert (second pv))
    (unless (third pv) (appendf pv '(0)))
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267
    (incf (third 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 ()
268 269
  (first (run '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines
              :show t)))
270 271 272 273 274 275 276 277 278 279 280 281 282 283 284


;;;; 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*)