Ticket #364: asdf-jar:package.patch

asdf-jar.lisp

@@ -13 +13 @@
 
 (defvar *debug* nil)
 
+(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
@@ -28 +81 @@
 
 If FORCE is true, force asdf to recompile all the necessary fasls.
 
+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))
@@ -38 +99 @@
                     (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"
-                         :defaults out))
-         (mapping (make-hash-table :test 'equal))
-         (dependencies (dependent-systems system)))
+                         :defaults out)))
     (when verbose 
       (format verbose "~&Packaging ASDF definition of ~A" system))
     (when (and verbose force)
@@ -54 +114 @@
     (asdf:compile-system system :force force)
     (when verbose
       (format verbose "~&Packaging contents in ~A" package-jar))
-    (when (and verbose recursive dependencies) 
-      (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) (let ((relative-path (archive-relative-path 
-                                                           base name asdf)))
-                                       (if root
-                                         (merge-pathnames
-                                          relative-path
-                                          (make-pathname :directory root))
-                                         relative-path)))
-        (loop :for component :in (all-files system) 
-           :for source = (slot-value component 'asdf::absolute-pathname)
-           :for source-entry = (archive-relative-path base name source)
-           :do (setf (gethash source mapping)
-                     (if root 
-                         (merge-pathnames source-entry (make-pathname :directory root))
-                         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"
-                                     :directory (append root
-                                                        (rest (pathname-directory source-entry))))))
-                 (when *debug*
-                   (format verbose "~&~A~& => ~A" output output-entry))
-                 (setf (gethash output mapping)
-                       output-entry)))))
-    (system:zip package-jar mapping)))
+    (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