Changeset 13344

Timestamp:

06/17/11 11:57:33 (12 years ago)

Author:

Mark Evenson

Message:

Undebugged implementation of enumerating the source and fasls.

Using the SYSTEM:ZIP with a hashtable of source to fasl mappings
eliminates the need for any intermediate directory.

File:

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

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

@@ -1 @@
-(defpackage :asdf-jar
+(defpackage #:asdf-jar
   (:use :cl)
   (:export #:package))
 
 (in-package :asdf-jar)
-
 
 (defvar *systems*)
@@ -28 +27 @@
       (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
     (setf *systems* nil)
+    (when verbose
+      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
     (asdf:compile-system system :force t)
-    (let* ((dir (asdf:component-pathname system))
-     (wild-contents (merge-pathnames "**/*" dir))
-     (contents (directory wild-contents))
-     (topdir (truename (merge-pathnames "../" dir))))
-      (when verbose
-  (format verbose "~&Packaging contents in ~A." package-jar))
-      (dolist (system (append (list system) *systems*))
-        (let ((base (slot-value system 'asdf:absolute-pathname))
-              (name (slot-value system 'asdf:name))
-              (asdf (slot-value system source-file)))
-          (setf (gethash asdf mapping) (relative-path base name asdf))))
+    (when verbose
+      (format verbose "~&Packaging contents in ~A." package-jar))
+    (dolist (system (append (list system) *systems*))
+      (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))
+        
           ;;; XXX iterate through the rest of the contents of the
           ;;; system, adding appropiate entries
-      (system:zip package-jar mapping))))
+        (let ((sources
+               (mapwalk (lambda (c) (typep c 'asdf::source-file))
+                        (lambda (c) (input-files c )))))
+          (loop :for source :in sources
+             :do (setf (gethash (pathname-namestring source) mapping)
+                       (make-pathname :defaults source
+                                      :type "abcl"))))))
+  (system:zip package-jar mapping)))
+
+;;; This more Map than Walk at this point ...
+(defun mapwalk (system test-if callable)
+  (declare (type system asdf:system))
+  (let ((components 
+         (loop 
+            :for component :being :each :hash-value
+              :of (slot-value system 'asdf::components-by-name)
+            :when (funcall test-if component)
+            :collect component)))
+    (loop :for component :in components
+       :collecting (apply callable component))))
 
 (defun relative-path (base dir file)