[armedbear-cvs] r13348 - trunk/abcl/contrib/asdf-jar
mevenson at common-lisp.net
mevenson at common-lisp.net
Sat Jun 18 14:26:18 UTC 2011
Author: mevenson
Date: Sat Jun 18 07:26:16 2011
New Revision: 13348
Log:
ASDF-JAR:PACKAGE now handles recursive dependencies.
Rewrote the dependency walking logic to actually work and to only
include output files for component types that have them.
Modified:
trunk/abcl/contrib/asdf-jar/asdf-jar.asd
trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.asd
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.asd Fri Jun 17 23:39:58 2011 (r13347)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.asd Sat Jun 18 07:26:16 2011 (r13348)
@@ -1,9 +1,9 @@
;;;; -*- Mode: LISP -*-
-(in-package :Asdf)
+(in-package :asdf)
(defsystem :asdf-jar
:author "Mark Evenson"
- :version "0.1.0"
+ :version "0.2.0"
:components
((:module base :pathname "" :components
((:file "asdf-jar")))))
\ No newline at end of file
Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Fri Jun 17 23:39:58 2011 (r13347)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp Sat Jun 18 07:26:16 2011 (r13348)
@@ -4,73 +4,91 @@
(in-package :asdf-jar)
-(defvar *systems*)
-(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
- (push c *systems*))
+(defvar *debug* nil)
(defun package (system-name
&key (out #p"/var/tmp/")
(recursive t) ; whether to package dependencies
- (force t) ; whether to force ASDF compilation
+ (force nil) ; whether to force ASDF compilation
(verbose t))
"Compile and package the asdf SYSTEM-NAME in a jar.
-Place the resulting packaging in the OUT directory."
+When RECURSIVE is true (the default), recursively add all asdf
+dependencies into the same jar.
+
+Place the resulting packaging in the OUT directory.
+
+Returns the pathname of the created jar archive.
+"
(let* ((system
(asdf:find-system system-name))
(name
(slot-value system 'asdf::name))
(version
- (slot-value system 'asdf:version))
+ (handler-case (slot-value system 'asdf:version)
+ (unbound-slot () "unknown")))
+
(package-jar-name
(format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
(package-jar
(make-pathname :directory (pathname-directory out) :defaults package-jar-name))
- (mapping (make-hash-table :test 'equal)))
+ (mapping (make-hash-table :test 'equal))
+ (dependencies (dependent-systems system)))
(when verbose
(format verbose "~&Packaging ASDF definition of ~A~& as ~A." system package-jar))
- (setf *systems* nil)
- (when verbose
+ (when (and verbose force)
(format verbose "~&Forcing recursive compilation of ~A." package-jar))
(asdf:compile-system system :force force)
(when verbose
- (format verbose "~&Packaging contents in ~A." package-jar))
- (dolist (system (append (list system) *systems*))
+ (format verbose "~&Packaging contents in ~A" package-jar))
+ (when (and verbose recursive)
+ (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) (relative-path base name asdf))
- (let ((sources
- (mapwalk system
- (lambda (c) (typep c 'asdf::source-file))
- (lambda (c) (slot-value c 'asdf::absolute-pathname)))))
- (loop :for source :in sources
- :for source-entry = (relative-path base name source)
- :for output = (make-pathname
- :defaults (asdf:apply-output-translations source)
- :type "abcl")
- :for output-entry = (make-pathname
- :defaults source-entry
- :type "abcl")
- :do (setf (gethash (namestring source) mapping)
- source-entry)
- :do (setf (gethash (namestring output) mapping)
+ (loop :for component :in (all-files system)
+ :for source = (slot-value component 'asdf::absolute-pathname)
+ :for source-entry = (relative-path base name source)
+ :do (setf (gethash source mapping)
+ 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")))
+ (when *debug*
+ (format verbose "~&~A~& => ~A" output output-entry))
+ (setf (gethash output mapping)
output-entry)))))
- (system:zip package-jar mapping)))
+ (system:zip package-jar mapping)))
-;;; This more Map than Walk at this point ...
-(defun mapwalk (system test-if callable)
- "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF.
-
-Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument."
- (declare (type system asdf:system))
- (loop
- :for component :being :each :hash-value
- :of (slot-value system 'asdf::components-by-name)
- :when
- (funcall test-if component)
- :collect
- (funcall callable component)))
+(defun all-files (component)
+ (loop :for c
+ :being :each :hash-value :of (slot-value component 'asdf::components-by-name)
+ :when (typep c 'asdf:module)
+ :append (all-files c)
+ :when (typep c 'asdf:source-file)
+ :append (list c)))
+
+(defun dependent-systems (system)
+ (when (not (typep system 'asdf:system))
+ (setf system (asdf:find-system system)))
+ (let* ((dependencies (asdf::component-load-dependencies system))
+ (sub-depends
+ (loop :for dependency :in dependencies
+ :for sub = (dependent-systems dependency)
+ :when sub :append sub)))
+ (remove-duplicates `(, at dependencies , at sub-depends))))
(defun relative-path (base dir file)
(let* ((relative
More information about the armedbear-cvs
mailing list