Newer
Older
(in-package :cclan)
;;;; This file contains functions, classes etc that are not part of
;;;; asdf itself, but extend it in various ways useful for maintainers
;;;; of new-style cCLan packages
;;;; The public interface consists of the functions whose symbols are
;;;; exported from the package
;;;; This file does not contain references to asdf internals - or
;;;; shouldn't, anyway. Send bug reports
(defun mapappend (function list)
(let ((f (coerce function 'function)))
(loop for i in list append (funcall f i))))
(defgeneric all-components (component))
(defmethod all-components ((source-file source-file))
(list source-file))
(defmethod all-components ((module module))
(cons module (mapappend #'all-components (module-components module))))
(defmethod all-components ((module symbol))
(all-components (find-system module)))
(defun cvs-tag (system)
(let* ((system (find-system system))
(directory (component-pathname system))
(version (component-version system)))
(run-shell-command "cd ~A && cvs tag -F cclan_version_~A"
(namestring directory)
(substitute #\_ #\. version))))
Christophe Rhodes
committed
(defun write-readme-file (stream suggested-registry system-name)
"Write a README.install file detailing a possible sequence of commands to use the newly-untarred system."
(format stream "~
1. Make a symlink in ~W[*] pointing to the .asd file
2. Start your asdf-enabled lisp
2a. Ensure that ~W[*] is in asdf:*central-registry*
3. At the lisp prompt, type '(asdf:oos 'asdf:load-op ~W)'. This
will compile and load the system into your running lisp.
[*] This path (~W) is only a suggestion; the important
thing is that asdf know where to find the .asd file. asdf uses the
Christophe Rhodes
committed
contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system
definitions.
These instructions were automatically generated by cCLan software. Use
at your own peril.~%" suggested-registry suggested-registry system-name suggested-registry))
(defun make-tar-file (system)
"Make a tar file named SYSTEM-NAME_VERSION.tar containing all the files in SYSTEM. The file is created in the directory containing the system directory. Returns T on success"
(let* ((system (find-system system))
(sys-path (component-pathname system))
(base-path (make-pathname
:directory (butlast (pathname-directory sys-path))
:defaults sys-path))
Christophe Rhodes
committed
(readme-path (make-pathname
:directory (pathname-directory sys-path)
:name "README"
:type "cCLan-install"))
(files
(mapcar (lambda (x) (enough-namestring x base-path))
Christophe Rhodes
committed
(list*
readme-path
(truename (system-definition-pathname system))
(mapcar #'component-pathname (all-components system))))))
Christophe Rhodes
committed
(with-open-file (s readme-path :direction :output :if-exists :supersede)
(write-readme-file s "~/lisp-systems/" (component-name system)))
(= 0
(run-shell-command "cd ~A && tar cf ~A_~A.tar ~{~D ~}"
(namestring base-path)
(component-name system)
(component-version system)
(remove-if-not #'pathname-name files)))))
Christophe Rhodes
committed
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
(defun class-name-of (x)
(class-name (class-of x)))
(defun write-debian-rules (stream system)
(let ((changelog-file-name (enough-namestring
(component-pathname (find 'changelog-source-file (all-components system) :key #'class-name-of :test #'string=))
(component-pathname system))))
(format stream "#!/usr/bin/make -f
# debian/rules generated by cCLan tools
# This is the debhelper compatibility version to use.
export DH_COMPAT=3
configure: configure-stamp
configure-stamp:
dh_testdir
touch configure-stamp
build: build-stamp
build-stamp:
dh_testdir
touch build-stamp
clean:
dh_testdir
dh_testroot
rm -f build-stamp configure-stamp
dh_clean
install: build
dh_testdir
dh_testroot
dh_clean -k
dh_installdirs
$(MAKE) -f Makefile.cCLan-deb install DESTDIR=$(CURDIR)/debian/~A
Christophe Rhodes
committed
binary-indep: build install
binary-arch: build install
dh_testdir
dh_testroot
dh_installdocs
dh_installexamples
dh_installman
dh_installinfo
dh_installchangelogs ~A
dh_link
dh_strip
dh_compress
dh_fixperms
dh_installdeb
dh_shlibdeps
dh_gencontrol
dh_md5sums
dh_builddeb
binary: binary-indep binary-arch
.PHONY: build clean binary-indep binary-arch binary install configure
" (component-name system) changelog-file-name)))
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
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
(defun write-debian-control (stream system)
(format stream "Source: ~A
Section: devel
Priority: optional
Maintainer: ~A
Build-Depends: debhelper (>> 3.0.0)
Standards-Version: 3.5.2
Package: ~A
Architecture: all
Depends: common-lisp-controller~{~^, ~A~}
Description: ~A
~{~<~% ~1:;~A ~>~}
"
;; FIXME: Clearly this argument list is not
;; sustainable. Also the split should be split-sequence,
;; clearly.
(component-name system) (infix-system::debian-maintainer system) (component-name system) (infix-system::debian-dependencies system) (infix-system::short-description system) (asdf::split (infix-system::long-description system))))
(defun write-debian-prerm (stream system)
(format stream "#! /bin/sh
# prerm script for ~A.
set -e
case \"$1\" in
remove|upgrade|deconfigure)
unregister-common-lisp-source ~A
;;
failed-upgrade)
;;
*)
echo \"prerm called with unknown argument \\`$1'\" >&2
exit 1
;;
esac
# dh_installdeb will replace this with shell code automatically
# generated by other debhelper scripts.
#DEBHELPER#
exit 0
"
(component-name system) (component-name system)))
(defun write-debian-postrm (stream system)
(format stream "#! /bin/sh
# postrm for ~A.
set -e
case \"$1\" in
purge|remove|upgrade|failed-upgrade|abort-install|abort-upgrade|disappear)
rm -f /usr/share/common-lisp/source/~A
;;
*)
echo \"postrm called with unknown argument \\`$1'\" >&2
exit 1
esac
# dh_installdeb will replace this with shell code automatically
# generated by other debhelper scripts.
#DEBHELPER#
exit 0
" (component-name system) (component-name system)))
(defun write-debian-postinst (stream system)
(format stream "#! /bin/sh
# postinst script for ~A.
set -e
case \"$1\" in
configure)
ln -sf /usr/share/common-lisp/repositories/~:*~A \\
/usr/share/common-lisp/source/~:*~A
register-common-lisp-source ~:*~A
;;
abort-upgrade|abort-remove|abort-deconfigure)
unregister-common-lisp-source ~:*~A
rm -f /usr/share/common-lisp/source/~:*~A
;;
*)
echo \"postinst called with unknown argument \\`$1'\" >&2
exit 1
;;
esac
#DEBHELPER#
exit 0
" (component-name system)))
(defun print-debian-date (stream arg colonp atsignp &rest params)
(declare (ignore colonp atsignp params))
(multiple-value-bind (sec min hr day mon year dow dst tz)
(decode-universal-time arg)
(format stream "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~
~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~
~2,'0d:~2,'0d:~2,'0d ~:[+~;-~]~4,'0d"
dow
day
(1- mon)
year
hr min sec
(minusp tz)
;; FIXME: I'm sure this is wrong
(+ (* (truncate tz) 100) (mod (* tz 60) 60)))))
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
(defun write-debian-changelog (stream system)
(format stream "~A (~A-1) cclan; urgency=low
* Package generated by cCLan scripts
-- ~A ~/cclan:print-debian-date/
" (component-name system) (component-version system) (infix-system::debian-maintainer system) (get-universal-time)))
(defun write-debian-dirs (stream system)
(format stream "~
/usr/share/doc/~A
/usr/share/common-lisp/systems
/usr/share/common-lisp/repositories/~:*~A
" (component-name system)))
(defun write-deb-install-makefile (stream system)
(let ((components (all-components system))
(*default-pathname-defaults* (component-pathname system)))
(format stream "install:
install -m 644 ~A $(DESTDIR)/usr/share/common-lisp/systems/
~{ install -m 644 ~A $(DESTDIR)/usr/share/common-lisp/repositories/~A~%~}"
(enough-namestring (component-pathname (find 'mk-defsystem-source-file components :key #'class-name-of :test #'string=)))
(loop for x in components
when (typep x 'cl-source-file)
collect (enough-namestring (component-pathname x))
and collect (format nil "~A/~A" (component-name system) (enough-namestring (component-pathname x)))))))
Christophe Rhodes
committed
(defun make-debian-package (system)
"Make a Debian package, compliant with Debian policy in as much as
that is possible, containing the system named in SYSTEM. The file will be produced in the directory containing the system directory."
(let* ((system (find-system system))
(components (all-components system))
(path (component-pathname system))
(debian-directory (merge-pathnames (make-pathname :directory '(:relative "debian"))
path)))
(ensure-directories-exist debian-directory)
(with-open-file (s (merge-pathnames "rules" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-rules s system))
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
(with-open-file (s (merge-pathnames "control" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-control s system))
(with-open-file (s (merge-pathnames "postinst" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-postinst s system))
(with-open-file (s (merge-pathnames "prerm" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-prerm s system))
(with-open-file (s (merge-pathnames "postrm" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-postrm s system))
(with-open-file (s (merge-pathnames "changelog" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-changelog s system))
(with-open-file (s (merge-pathnames "dirs" debian-directory)
:direction :output
:if-exists :supersede)
(write-debian-dirs s system))
(with-open-file (s (merge-pathnames "Makefile.cCLan-deb" path)
:direction :output
:if-exists :supersede)
(write-deb-install-makefile s system))
(run-shell-command "cd ~A && chmod +x rules"
(directory-namestring debian-directory))
(run-shell-command "cd ~A && ln -s ~A copyright"
(directory-namestring debian-directory)
(namestring (component-pathname (find 'licence-source-file components :key #'class-name-of :test #'string=))))
(run-shell-command "cd ~A && dpkg-buildpackage -us -uc -rfakeroot -b"
(directory-namestring path))