root/trunk/thirdparty/asdf/cclan.lisp

(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-name (system)
  (let* ((system (find-system system))
         (version (component-version system)))
    (format nil "release_~A"  (substitute #\_ #\. version))))
  
(defun cvs-tag (system)
  (let* ((system (find-system system))
         (directory (component-pathname system)))
    (run-shell-command "cd ~A && cvs tag -F ~A"
                       (namestring directory)  (cvs-tag-name system))))


(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:operate '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 write-package (system)
  (let* ((parent-dir
          (parse-namestring
           (format nil "/tmp/~A.~A/"
                   #+sbcl (sb-unix:unix-getpid)
                   #-sbcl (random 1000000)
                   (get-internal-run-time))))
         (system (find-system system))
         (sub-dir-name
          (format nil "~A_~A"
                  (component-name system) (component-version system)))
         (cvsroot-file
          (merge-pathnames "CVS/Root" (component-pathname system)))
         (old-pwd *default-pathname-defaults*)
         (*default-pathname-defaults* parent-dir))
    (ensure-directories-exist parent-dir)
    (cvs-tag system)
    (and
     (zerop (asdf:run-shell-command
             "cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A"
             (namestring parent-dir)
             (namestring cvsroot-file)
             sub-dir-name
             (cvs-tag-name system)
             (component-name system)))
     (with-open-file (o (format nil "~A/INSTALL.asdf" sub-dir-name)
                        :direction :output)
       (write-readme-file o "$HOME/lisp/systems/" (component-name system))
       t)
     (zerop (asdf:run-shell-command "cd ~A && tar cf ~A~A.tar ~A"
                                    (namestring parent-dir)
                                    (namestring old-pwd) sub-dir-name
                                    sub-dir-name))
     (zerop (asdf:run-shell-command
             "gzip -f9  ~A~A.tar"
             (namestring old-pwd) sub-dir-name))
     (format t "Now run~%  gpg -b -a  ~A~A.tar.gz~%in a shell with a tty"
             (namestring old-pwd) sub-dir-name))))

(defun class-name-of (x)
  (class-name (class-of x)))