(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)))) (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 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)) (readme-path (make-pathname :directory (pathname-directory sys-path) :name "README" :type "cCLan-install")) (files (mapcar (lambda (x) (enough-namestring x base-path)) (list* readme-path (truename (system-definition-pathname system)) (mapcar #'component-pathname (all-components system)))))) (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))))) (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 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))) #+infix (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))))) #+infix (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))))))) (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)) (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)) ))