3rdparties/software/babel-20200218-git/scripts/release.lisp (9849 bytes)
1 #!/usr/bin/env clisp 2 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 3 4 (defpackage :release-script (:use #:cl #:regexp)) 5 (in-package :release-script) 6 7 ;;;; Configuration ------------------------------------------------------------ 8 9 (defparameter *project-name* "babel") 10 (defparameter *asdf-file* (format nil "~A.asd" *project-name*)) 11 12 (defparameter *host* "common-lisp.net") 13 (defparameter *release-dir* 14 (format nil "/project/~A/public_html/releases" *project-name*)) 15 16 (defparameter *version-file* "VERSION") 17 (defparameter *version-file-dir* 18 (format nil "/project/~A/public_html" *project-name*)) 19 20 ;;;; -------------------------------------------------------------------------- 21 22 ;;;; Utilities 23 24 (defun ensure-list (x) 25 (if (listp x) x (list x))) 26 27 (defmacro string-case (expression &body clauses) 28 `(let ((it ,expression)) ; yes, anaphoric, deal with it. 29 (cond 30 ,@(loop for clause in clauses collect 31 `((or ,@(loop for alternative in (ensure-list (first clause)) 32 collect (or (eq t alternative) 33 `(string= it ,alternative)))) 34 ,@(rest clause)))))) 35 36 (defparameter *development-mode* nil) 37 38 (defun die (format-control &rest format-args) 39 (format *error-output* "~?" format-control format-args) 40 (if *development-mode* 41 (cerror "continue" "die") 42 (ext:quit 1))) 43 44 (defun numeric-split (string) 45 (if (digit-char-p (char string 0)) 46 (multiple-value-bind (number next-position) 47 (parse-integer string :junk-allowed t) 48 (cons number (when (< next-position (length string)) 49 (numeric-split (subseq string next-position))))) 50 (let ((next-digit-position (position-if #'digit-char-p string))) 51 (if next-digit-position 52 (cons (subseq string 0 next-digit-position) 53 (numeric-split (subseq string next-digit-position))) 54 (list string))))) 55 56 (defun natural-string-< (s1 s2) 57 (labels ((aux< (l1 l2) 58 (cond ((null l1) (not (null l2))) 59 ((null l2) nil) 60 (t (destructuring-bind (x . xs) l1 61 (destructuring-bind (y . ys) l2 62 (cond ((and (numberp x) (stringp y)) 63 t) 64 ((and (numberp y) (stringp x)) 65 nil) 66 ((and (numberp x) (numberp y)) 67 (or (< x y) (and (= x y) (aux< xs ys)))) 68 (t 69 (or (string-lessp x y) 70 (and (string-equal x y) 71 (aux< xs ys))))))))))) 72 (aux< (numeric-split s1) 73 (numeric-split s2)))) 74 75 ;;;; Running commands 76 77 (defparameter *dry-run* nil) 78 79 (defun cmd? (format-control &rest format-args) 80 (let ((cmd (format nil "~?" format-control format-args))) 81 (with-open-stream (s1 (ext:run-shell-command cmd :output :stream)) 82 (loop for line = (read-line s1 nil nil) 83 while line 84 collect line)))) 85 86 ;; XXX: quote arguments. 87 (defun cmd (format-control &rest format-args) 88 (when *development-mode* 89 (format *debug-io* "CMD: ~?~%" format-control format-args)) 90 (let ((ret (ext:run-shell-command (format nil "~?" format-control format-args)))) 91 (or (null ret) 92 (zerop ret)))) 93 94 (defun cmd! (format-control &rest format-args) 95 (or (apply #'cmd format-control format-args) 96 (die "cmd '~?' failed." format-control format-args))) 97 98 (defun maybe-cmd! (format-control &rest format-args) 99 (if *dry-run* 100 (format t "SUPPRESSING: ~?~%" format-control format-args) 101 (apply #'cmd! format-control format-args))) 102 103 ;;;; 104 105 (defun find-current-version () 106 (subseq (reduce (lambda (x y) (if (natural-string-< x y) y x)) 107 (or (cmd? "git tag -l v\\*") 108 (die "no version tags found. Please specify initial version."))) 109 1)) 110 111 (defun parse-version (string) 112 (mapcar (lambda (x) 113 (parse-integer x :junk-allowed t)) 114 (loop repeat 3 ; XXX: parameterize 115 for el in (regexp-split "\\." (find-current-version)) 116 collect el))) 117 118 (defun check-for-unrecorded-changes (&optional force) 119 (unless (cmd "git diff --exit-code") 120 (write-line "Unrecorded changes.") 121 (if force 122 (write-line "Continuing anyway.") 123 (die "Aborting.~@ 124 Use -f or --force if you want to make a release anyway.")))) 125 126 (defun new-version-number-candidates (current-version) 127 (let ((current-version (parse-version current-version))) 128 (labels ((alternatives (before after) 129 (when after 130 (cons (append before (list (1+ (first after))) 131 (mapcar (constantly 0) (rest after))) 132 (alternatives (append before (list (first after))) 133 (rest after)))))) 134 (loop for alt in (alternatives nil current-version) 135 collect (reduce (lambda (acc next) 136 (format nil "~a.~a" acc next)) 137 alt))))) 138 139 (defun ask-user-for-version (current-version next-versions) 140 (format *query-io* "Current version is ~A. Which will be the next one?~%" 141 current-version) 142 (loop for i from 1 and version in next-versions 143 do (format *query-io* "~T~A) ~A~%" i version)) 144 (format *query-io* "? ") 145 (finish-output *query-io*) 146 (nth (1- (parse-integer (read-line) :junk-allowed t)) 147 next-versions)) 148 149 (defun git-tag-tree (version) 150 (write-line "Tagging the tree...") 151 (maybe-cmd! "git tag \"v~A\"" version)) 152 153 (defun add-version-to-system-file (version path-in path-out) 154 (with-open-file (in path-in :direction :input) 155 (with-open-file (out path-out :direction :output) 156 (loop for line = (read-line in nil nil) while line 157 do (write-line line out) 158 when (string= #1="(defsystem " line 159 :end2 (min (length #1#) (length line))) 160 do (format out " :version ~s~%" version))))) 161 162 (defun create-dist (version distname) 163 (write-line "Creating distribution...") 164 (cmd! "mkdir \"~a\"" distname) 165 (cmd! "git archive master | tar xC \"~A\"" distname) 166 (format t "Updating ~A with new version: ~A~%" *asdf-file* version) 167 (let* ((asdf-file-path (format nil "~A/~A" distname *asdf-file*)) 168 (tmp-asdf-file-path (format nil "~a.tmp" asdf-file-path))) 169 (add-version-to-system-file version asdf-file-path tmp-asdf-file-path) 170 (cmd! "mv \"~a\" \"~a\"" tmp-asdf-file-path asdf-file-path))) 171 172 (defun tar-and-sign (distname tarball) 173 (write-line "Creating and signing tarball...") 174 (cmd! "tar czf \"~a\" \"~a\"" tarball distname) 175 (cmd! "gpg -b -a \"~a\"" tarball)) 176 177 (defparameter *remote-directory* (format nil "~A:~A" *host* *release-dir*)) 178 179 (defun upload-tarball (tarball signature remote-directory) 180 (write-line "Copying tarball to web server...") 181 (maybe-cmd! "scp \"~A\" \"~A\" \"~A\"" tarball signature remote-directory) 182 (format t "Uploaded ~A and ~A.~%" tarball signature)) 183 184 (defun update-remote-links (tarball signature host release-dir project-name) 185 (format t "Updating ~A_latest links...~%" project-name) 186 (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz\"" 187 host tarball release-dir project-name) 188 (maybe-cmd! "ssh \"~A\" ln -sf \"~A\" \"~A/~A_latest.tar.gz.asc\"" 189 host signature release-dir project-name)) 190 191 (defun upload-version-file (version version-file host version-file-dir) 192 (format t "Uploading ~A...~%" version-file) 193 (with-open-file (out version-file :direction :output) 194 (write-string version out)) 195 (maybe-cmd! "scp \"~A\" \"~A\":\"~A\"" version-file host version-file-dir) 196 (maybe-cmd! "rm \"~A\"" version-file)) 197 198 (defun maybe-clean-things-up (tarball signature) 199 (when (y-or-n-p "Clean local tarball and signature?") 200 (cmd! "rm \"~A\" \"~A\"" tarball signature))) 201 202 (defun run (force version) 203 (check-for-unrecorded-changes force) 204 ;; figure out what version we'll be preparing. 205 (unless version 206 (let* ((current-version (find-current-version)) 207 (next-versions (new-version-number-candidates current-version))) 208 (setf version (or (ask-user-for-version current-version next-versions) 209 (die "invalid selection."))))) 210 (git-tag-tree version) 211 (let* ((distname (format nil "~A_~A" *project-name* version)) 212 (tarball (format nil "~A.tar.gz" distname)) 213 (signature (format nil "~A.asc" tarball))) 214 ;; package things up. 215 (create-dist version distname) 216 (tar-and-sign distname tarball) 217 ;; upload. 218 (upload-tarball tarball signature *remote-directory*) 219 (update-remote-links tarball signature *host* *release-dir* *project-name*) 220 (when *version-file* 221 (upload-version-file version *version-file* *host* *version-file-dir*)) 222 ;; clean up. 223 (maybe-clean-things-up tarball signature) 224 ;; documentation. 225 ;; (write-line "Building and uploading documentation...") 226 ;; (maybe-cmd! "make -C doc upload-docs") 227 ;; push tags and any outstanding changes. 228 (write-line "Pushing tags and changes...") 229 (maybe-cmd! "git push --tags origin master"))) 230 231 232 ;;;; Do it to it 233 234 (let ((force nil) 235 (version nil) 236 (args ext:*args*)) 237 (loop while args 238 do (string-case (pop args) 239 (("-h" "--help") 240 (write-line "No help, sorry. Read the source.") 241 (ext:quit 0)) 242 (("-f" "--force") 243 (setf force t)) 244 (("-v" "--version") 245 (setf version (pop args))) 246 (("-n" "--dry-run") 247 (setf *dry-run* t)) 248 (t 249 (die "Unrecognized argument '~a'" it)))) 250 (run force version))