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

Last change on this file since 13351 was 13351, checked in by Mark Evenson, 11 years ago

asdf-jar-0.2.1 corrects load-time errors.

File size: 5.5 KB
Line 
1;;; This file is part of ABCL contrib
2;;;
3;;; Copyright 2011 Mark <evenson@panix.com>
4
5(defpackage #:asdf-jar
6  (:use :cl)
7  (:export #:package 
8           #:add-to-asdf))
9
10(in-package :asdf-jar)
11
12(defvar *debug* nil)
13
14(defun package (system
15          &key (out #p"/var/tmp/") 
16               (recursive t)          ; whether to package dependencies
17               (force nil)            ; whether to force ASDF compilation
18               (verbose t))
19"Compile and package the asdf SYSTEM in a jar.
20
21When RECURSIVE is true (the default), recursively add all asdf
22dependencies into the same jar.
23
24Place the resulting packaged jar in the OUT directory.
25
26If FORCE is true, force asdf to recompile all the necessary fasls.
27
28Returns the pathname of the packaged jar archive.
29"
30  (when (not (typep system 'asdf:system))
31             (setf system (asdf:find-system system)))
32  (let* ((name 
33          (slot-value system 'asdf::name))
34         (version 
35          (handler-case (slot-value system 'asdf:version)
36            (unbound-slot () "unknown")))
37         (package-jar-name 
38          (format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
39         (package-jar
40          (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
41         (mapping (make-hash-table :test 'equal))
42         (dependencies (dependent-systems system)))
43    (when verbose 
44      (format verbose "~&Packaging ASDF definition of ~A" system))
45    (when (and verbose force)
46      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
47    (asdf:compile-system system :force force)
48    (when verbose
49      (format verbose "~&Packaging contents in ~A" package-jar))
50    (when (and verbose recursive dependencies) 
51      (format verbose "~&  with recursive dependencies~{ ~A~^, ~}." dependencies))
52    (dolist (system (append (list system) 
53                            (when recursive 
54                              (mapcar #'asdf:find-system dependencies))))
55      (let ((base (slot-value system 'asdf::absolute-pathname))
56            (name (slot-value system 'asdf::name))
57            (asdf (slot-value system 'asdf::source-file)))
58        (setf (gethash asdf mapping) (relative-path base name asdf))
59        (loop :for component :in (all-files system) 
60           :for source = (slot-value component 'asdf::absolute-pathname)
61           :for source-entry = (relative-path base name source)
62           :do (setf (gethash source mapping)
63                     source-entry)
64           :do (when *debug*
65                 (format verbose "~&~A~& => ~A" source source-entry))
66           :when (and (typep component 'asdf::source-file)
67                      (not (typep component 'asdf::static-file)))
68           :do (let ((output 
69                      (make-pathname
70                       :defaults (asdf:apply-output-translations source)
71                       :type "abcl"))
72                     (output-entry 
73                      (make-pathname :defaults source-entry
74                                     :type "abcl")))
75                 (when *debug*
76                   (format verbose "~&~A~& => ~A" output output-entry))
77                 (setf (gethash output mapping)
78                       output-entry)))))
79    (system:zip package-jar mapping)))
80
81(defun all-files (component)
82  (loop :for c 
83     :being :each :hash-value :of (slot-value component 'asdf::components-by-name)
84     :when (typep c 'asdf:module)
85     :append (all-files c)
86     :when (typep c 'asdf:source-file)
87     :append (list c)))
88
89(defun dependent-systems (system)
90  (when (not (typep system 'asdf:system))
91             (setf system (asdf:find-system system)))
92  (let* ((dependencies (asdf::component-load-dependencies system))
93         (sub-depends
94          (loop :for dependency :in dependencies
95             :for sub = (dependent-systems dependency)
96             :when sub :append sub)))
97    (remove-duplicates `(,@dependencies ,@sub-depends))))
98
99(defun relative-path (base dir file) 
100  (let* ((relative 
101          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
102         (entry-dir `(:relative ,dir ,@(when relative relative))))
103    (make-pathname :directory entry-dir
104                   :defaults file)))
105
106(defun tmpdir (name)
107  "Return temporary directory."
108  (let* ((temp-file (java:jcall "getAbsolutePath" 
109                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
110         (temp-path (pathname temp-file)))
111    (make-pathname 
112     :directory (nconc (pathname-directory temp-path)
113                       (list name)))))
114
115(defun add-to-asdf (jar &key (use-jar-fasls t))
116  "Make a given JAR output by the package mechanism loadable by asdf.
117
118The parameter passed to :USE-JAR-FASLS determines whether to instruct
119asdf to use the fasls packaged in the jar.  If this is nil, the fasls
120will be compiled with respect to the ususual asdf output translation
121conventions."
122  (when (not (typep jar 'pathname))
123    (setf jar (pathname jar)))
124  (when (null (pathname-device jar))
125    (setf jar (make-pathname :device (list jar))))
126
127  ;;; Inform ASDF of all the system definitions in the jar
128  (loop :for asd 
129     :in (directory (merge-pathnames "*/*.asd" jar))
130     :do (pushnew (make-pathname :defaults asd
131                                 :name nil :type nil)
132                  asdf:*central-registry*))
133
134  ;;; Load the FASLs directly from the jar
135  (when use-jar-fasls                   
136    (asdf:initialize-output-translations
137     `(:output-translations (,(merge-pathnames "/**/*.*" jar)) 
138                            :inherit-configuration))))
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154   
155 
156
157 
158 
Note: See TracBrowser for help on using the repository browser.