[Armedbear-cvs] r14720 - trunk/abcl/contrib/asdf-jar

[mevenson at common-lisp.net]

Author: mevenson
Date: Sun Aug 17 19:32:05 2014
New Revision: 14720

Log:
asdf-jar:  Stablize recent fixes across more cases. (Eduardo Bellani)

<http://abcl.org/trac/ticket/364>

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

Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Sun Aug 17 18:30:33 2014	(r14719)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Sun Aug 17 19:32:05 2014	(r14720)
@@ -66,12 +66,65 @@
         (add-system-files-to-mapping! system mapping base name root verbose)))
     mapping))
 
+(defun add-system-files-to-mapping! (system
+                                     mapping
+                                     system-base
+                                     system-name
+                                     &optional root verbose)
+  "Auxiliary procedure that adds all the files of a SYSTEM to the
+MAPPING with a given SYSTEM-BASE and SYSTEM-NAME. The whole idea of
+this procedure is to modify MAPPING, so a NIL is returned."
+  (let ((abcl-file-type "abcl"))
+    (loop :for component :in (all-files system) 
+       :for source = (slot-value component 'asdf::absolute-pathname)
+       :for source-entry = (archive-relative-path system-base system-name source)
+       :do (setf (gethash source mapping)
+                 (if root 
+                     (merge-pathnames source-entry (make-pathname :directory root))
+                     source-entry))
+       :do (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-file-type))
+                 (output-entry 
+                  (make-pathname :defaults source-entry 
+                                 :type abcl-file-type
+                                 :directory
+                                 (append root
+                                         (cadr (pathname-directory source-entry))))))
+             (format verbose "~&~A~& => ~A" output output-entry)
+             (setf (gethash output mapping)
+                   output-entry)))))
+
+(defun systems->hash-table (systems &optional root verbose)
+  "Auxiliary function that, given a list of SYSTEMS, builds a hash
+table mapping absolute file names to of these systems into relative
+path names. This mapping will be used to zip the files of the system
+into a JAR file."
+  (let ((mapping (make-hash-table :test 'equal)))
+    (dolist (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)
+              (let ((relative-path (archive-relative-path base name asdf)))
+                (if root
+                    (merge-pathnames
+                     relative-path
+                     (make-pathname :directory root))
+                    relative-path)))
+        (add-system-files-to-mapping! system mapping base name root verbose)))
+    mapping))
+
 (defun package (system &key 
                          (out #p"/var/tmp/") 
                          (recursive t)          ; whether to package dependencies
                          (force nil)            ; whether to force ASDF compilation
-                         (root nil)
-                         (verbose t))
+                         (root '(:relative))
+                         (verbose nil))
 "Compile and package the asdf SYSTEM in a jar.
 
 When RECURSIVE is true (the default), recursively add all asdf
@@ -89,6 +142,14 @@
 is to add the paths to an internal directory, such as (list :relative
 \"META-INF\" \"resources\") for generating WAR files.
 
+VERBOSE controls how many messages will be logged to
+*standard-output*.
+
+ROOT controls if the relative pathnames will be appended to something
+before being added to the mapping. The purpose of having this option
+is to add the paths to an internal directory, such as (list :relative
+\"META-INF\" \"resources\") for generating WAR files.
+
 Returns the pathname of the packaged jar archive.
 "
   (when (not (typep system 'asdf:system))
@@ -99,10 +160,10 @@
                     (when v
                       v)))
          (package-jar-name 
-          (format nil "~A~A~A" name (if recursive "-all" "")
-                  (if version 
-                      (format nil "-~A" version)
-                      "")))
+           (format nil "~A~A~A" name (if recursive "-all" "")
+                   (if version 
+                       (format nil "-~A" version)
+                       "")))
          (package-jar
           (make-pathname :name package-jar-name
                          :type "jar"
@@ -114,18 +175,18 @@
     (asdf:compile-system system :force force)
     (when verbose
       (format verbose "~&Packaging contents in ~A" package-jar))
-    (system:zip package-jar
-                (systems->hash-table 
-                 (append (list system) 
-                         (when recursive
-                           (let ((dependencies (dependent-systems system)))
-                             (when (and verbose dependencies) 
-                               (format verbose
-                                       "~&  with recursive dependencies~{ ~A~^, ~}."
-                                       dependencies)
-                               (mapcar #'asdf:find-system dependencies)))))
-                 root
-                 verbose))))
+     (system:zip package-jar
+                 (systems->hash-table 
+                  (append (list system) 
+                          (when recursive
+                            (let ((dependencies (dependent-systems system)))
+                              (when (and verbose dependencies) 
+                                (format verbose
+                                        "~&  with recursive dependencies~{ ~A~^, ~}."
+                                        dependencies)
+                                (mapcar #'asdf:find-system dependencies)))))
+                  root
+                  verbose))))
 
 (defun all-files (component)
   (loop :for c