source: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp @ 13348

Last change on this file since 13348 was 13348, checked in by Mark Evenson, 10 years ago

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.

File size: 4.3 KB
Line 
1(defpackage #:asdf-jar
2  (:use :cl)
3  (:export #:package))
4
5(in-package :asdf-jar)
6
7(defvar *debug* nil)
8
9(defun package (system-name 
10                &key (out #p"/var/tmp/") 
11                     (recursive t)          ; whether to package dependencies
12                     (force nil)              ; whether to force ASDF compilation
13                     (verbose t))
14"Compile and package the asdf SYSTEM-NAME in a jar.
15
16When RECURSIVE is true (the default), recursively add all asdf
17dependencies into the same jar.
18
19Place the resulting packaging in the OUT directory.
20
21Returns the pathname of the created jar archive.
22"
23  (let* ((system 
24          (asdf:find-system system-name))
25   (name 
26          (slot-value system 'asdf::name))
27         (version 
28          (handler-case (slot-value system 'asdf:version)
29            (unbound-slot () "unknown")))
30
31         (package-jar-name 
32          (format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
33         (package-jar
34          (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
35         (mapping (make-hash-table :test 'equal))
36         (dependencies (dependent-systems system)))
37    (when verbose 
38      (format verbose "~&Packaging ASDF definition of ~A~&  as ~A." system package-jar))
39    (when (and verbose force)
40      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
41    (asdf:compile-system system :force force)
42    (when verbose
43      (format verbose "~&Packaging contents in ~A" package-jar))
44    (when (and verbose recursive) 
45      (format verbose "~&  with recursive dependencies~{ ~A~^, ~}." dependencies))
46    (dolist (system (append (list system) 
47                            (when recursive 
48                              (mapcar #'asdf:find-system dependencies))))
49      (let ((base (slot-value system 'asdf::absolute-pathname))
50            (name (slot-value system 'asdf::name))
51            (asdf (slot-value system 'asdf::source-file)))
52        (setf (gethash asdf mapping) (relative-path base name asdf))
53        (loop :for component :in (all-files system) 
54           :for source = (slot-value component 'asdf::absolute-pathname)
55           :for source-entry = (relative-path base name source)
56           :do (setf (gethash source mapping)
57                     source-entry)
58           :do (when *debug*
59                 (format verbose "~&~A~& => ~A" source source-entry))
60           :when (and (typep component 'asdf::source-file)
61                      (not (typep component 'asdf::static-file)))
62           :do (let ((output 
63                      (make-pathname
64                       :defaults (asdf:apply-output-translations source)
65                       :type "abcl"))
66                     (output-entry 
67                      (make-pathname :defaults source-entry
68                                     :type "abcl")))
69                 (when *debug*
70                   (format verbose "~&~A~& => ~A" output output-entry))
71                 (setf (gethash output mapping)
72                       output-entry)))))
73    (system:zip package-jar mapping)))
74
75(defun all-files (component)
76  (loop :for c 
77     :being :each :hash-value :of (slot-value component 'asdf::components-by-name)
78     :when (typep c 'asdf:module)
79     :append (all-files c)
80     :when (typep c 'asdf:source-file)
81     :append (list c)))
82
83(defun dependent-systems (system)
84  (when (not (typep system 'asdf:system))
85             (setf system (asdf:find-system system)))
86  (let* ((dependencies (asdf::component-load-dependencies system))
87         (sub-depends
88          (loop :for dependency :in dependencies
89             :for sub = (dependent-systems dependency)
90             :when sub :append sub)))
91    (remove-duplicates `(,@dependencies ,@sub-depends))))
92
93(defun relative-path (base dir file) 
94  (let* ((relative 
95          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
96         (entry-dir `(:relative ,dir ,@(when relative relative))))
97    (make-pathname :directory entry-dir
98                   :defaults file)))
99
100(defun tmpdir (name)
101  "Return temporary directory."
102  (let* ((temp-file (java:jcall "getAbsolutePath" 
103                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
104         (temp-path (pathname temp-file)))
105    (make-pathname 
106     :directory (nconc (pathname-directory temp-path)
107                       (list name)))))
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124   
125 
126
127 
128 
Note: See TracBrowser for help on using the repository browser.