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

<http://abcl.org/trac/ticket/364>
parent 0badf1b1
......@@ -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 add-system-files-to-mapping! (system
mapping
system-base
......@@ -70,8 +123,8 @@ into a JAR file."
(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 @@ 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.
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 @@ Returns the pathname of the packaged jar archive.
(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 @@ Returns the pathname of the packaged jar archive.
(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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment