1 files changed, 99 insertions, 0 deletions
diff --git a/Lisp/asdf/cclan.lisp b/Lisp/asdf/cclan.lisp
new file mode 100644
index 0000000..7d08307
--- /dev/null
+++ b/Lisp/asdf/cclan.lisp
@@ -0,0 +1,99 @@
+(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)))
+
+