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