Changeset 13348 for trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

Timestamp:

06/18/11 14:26:16 (12 years ago)

Author:

Mark Evenson

Message:

ASDF-JAR:PACKAGE now handles recursive dependencies.

Rewrote the dependency walking logic to actually work and to only
include output files for component types that have them.

File:

• trunk/abcl/contrib/asdf-jar/asdf-jar.lisp (modified) (2 diffs)

trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

@@ -5 +5 @@
 (in-package :asdf-jar)
 
-(defvar *systems*)
-(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
-  (push c *systems*))
+(defvar *debug* nil)
 
 (defun package (system-name 
                 &key (out #p"/var/tmp/") 
                      (recursive t)          ; whether to package dependencies
-                     (force t)              ; whether to force ASDF compilation
+                     (force nil)              ; whether to force ASDF compilation
                      (verbose t))
 "Compile and package the asdf SYSTEM-NAME in a jar.
 
-Place the resulting packaging in the OUT directory."
+When RECURSIVE is true (the default), recursively add all asdf
+dependencies into the same jar.
+
+Place the resulting packaging in the OUT directory.
+
+Returns the pathname of the created jar archive.
+"
   (let* ((system 
           (asdf:find-system system-name))
@@ -22 +26 @@
           (slot-value system 'asdf::name))
          (version 
-          (slot-value system 'asdf:version))
+          (handler-case (slot-value system 'asdf:version)
+            (unbound-slot () "unknown")))
+
          (package-jar-name 
           (format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
          (package-jar
           (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
-         (mapping (make-hash-table :test 'equal)))
+         (mapping (make-hash-table :test 'equal))
+         (dependencies (dependent-systems system)))
     (when verbose 
       (format verbose "~&Packaging ASDF definition of ~A~&  as ~A." system package-jar))
-    (setf *systems* nil)
-    (when verbose
+    (when (and verbose force)
       (format verbose "~&Forcing recursive compilation of ~A." package-jar))
     (asdf:compile-system system :force force)
     (when verbose
-      (format verbose "~&Packaging contents in ~A." package-jar))
-    (dolist (system (append (list system) *systems*))
+      (format verbose "~&Packaging contents in ~A" package-jar))
+    (when (and verbose recursive) 
+      (format verbose "~&  with recursive dependencies~{ ~A~^, ~}." dependencies))
+    (dolist (system (append (list system) 
+                            (when recursive 
+                              (mapcar #'asdf:find-system dependencies))))
       (let ((base (slot-value system 'asdf::absolute-pathname))
             (name (slot-value system 'asdf::name))
             (asdf (slot-value system 'asdf::source-file)))
         (setf (gethash asdf mapping) (relative-path base name asdf))
-        (let ((sources
-               (mapwalk system
-                        (lambda (c) (typep c 'asdf::source-file))
-                        (lambda (c) (slot-value c 'asdf::absolute-pathname)))))
-          (loop :for source :in sources
-             :for source-entry = (relative-path base name source)
-             :for output = (make-pathname 
-                             :defaults (asdf:apply-output-translations source)
-                             :type "abcl")
-             :for output-entry = (make-pathname
-                                  :defaults source-entry
-                                  :type "abcl")
-             :do (setf (gethash (namestring source) mapping)
-                       source-entry)
-             :do (setf (gethash (namestring output) mapping)
+        (loop :for component :in (all-files system) 
+           :for source = (slot-value component 'asdf::absolute-pathname)
+           :for source-entry = (relative-path base name source)
+           :do (setf (gethash source mapping)
+                     source-entry)
+           :do (when *debug*
+                 (format verbose "~&~A~& => ~A" source source-entry))
+           :when (and (typep component 'asdf::source-file)
+                      (not (typep component 'asdf::static-file)))
+           :do (let ((output 
+                      (make-pathname
+                       :defaults (asdf:apply-output-translations source)
+                       :type "abcl"))
+                     (output-entry 
+                      (make-pathname :defaults source-entry
+                                     :type "abcl")))
+                 (when *debug*
+                   (format verbose "~&~A~& => ~A" output output-entry))
+                 (setf (gethash output mapping)
                        output-entry)))))
-      (system:zip package-jar mapping)))
+    (system:zip package-jar mapping)))
 
-;;; This more Map than Walk at this point ...
-(defun mapwalk (system test-if callable)
-  "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF.
+(defun all-files (component)
+  (loop :for c 
+     :being :each :hash-value :of (slot-value component 'asdf::components-by-name)
+     :when (typep c 'asdf:module)
+     :append (all-files c)
+     :when (typep c 'asdf:source-file)
+     :append (list c)))
 
-Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument."
-  (declare (type system asdf:system))
-  (loop 
-     :for component :being :each :hash-value
-     :of (slot-value system 'asdf::components-by-name)
-     :when 
-       (funcall test-if component)
-     :collect 
-       (funcall callable component)))
+(defun dependent-systems (system)
+  (when (not (typep system 'asdf:system))
+             (setf system (asdf:find-system system)))
+  (let* ((dependencies (asdf::component-load-dependencies system))
+         (sub-depends
+          (loop :for dependency :in dependencies
+             :for sub = (dependent-systems dependency)
+             :when sub :append sub)))
+    (remove-duplicates `(,@dependencies ,@sub-depends))))
 
 (defun relative-path (base dir file)