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