[Armedbear-cvs] r14717 - trunk/abcl/contrib/asdf-jar
mevenson at common-lisp.net
mevenson at common-lisp.net
Sun Aug 17 17:55:44 UTC 2014
Author: mevenson
Date: Sun Aug 17 17:55:43 2014
New Revision: 14717
Log:
Fix #364: ASDF-JAR:PACKAGE breaks with simple usage.
Thanks to 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 Tue Aug 5 17:49:43 2014 (r14716)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sun Aug 17 17:55:43 2014 (r14717)
@@ -13,6 +13,59 @@
(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
@@ -28,6 +81,14 @@
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,15 +99,14 @@
(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,46 +114,18 @@
(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
More information about the armedbear-cvs
mailing list