source: branches/streams/abcl/contrib/asdf-jar/asdf-jar.lisp

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

asdf-jar: fix PACKAGE to work again.

Addresses <http://abcl.org/trac/ticket/376>.

File size: 8.1 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           ;; "Si vis pacem, para bellum" -- Publius Flavius Vegetius Renatus
9           #:prepare-for-war 
10           #:add-to-asdf))
11
12(in-package #:asdf-jar)
13
14(defvar *debug* nil)
15
16(defun add-system-files-to-mapping! (system
17                                     mapping
18                                     system-base
19                                     system-name
20                                     root
21                                     &key (verbose nil))
22  "Add all the files of a SYSTEM to the MAPPING with a given
23SYSTEM-BASE and SYSTEM-NAME.
24
25This function destructively modifies MAPPING returning nil."
26  (let ((abcl-file-type "abcl"))
27    (loop :for component :in (all-files system) 
28       :for source = (slot-value component 'asdf::absolute-pathname)
29       :for source-entry = (merge-pathnames
30                            (archive-relative-path system-base system-name source)
31                            (make-pathname :directory root))
32       :do (setf (gethash source mapping)
33                 source-entry)
34       :do (format verbose "~&~A~& => ~A" source source-entry)
35       :when (and (typep component 'asdf::source-file)
36                  (not (typep component 'asdf::static-file)))
37       :do (let ((output 
38                  (make-pathname
39                   :defaults (asdf:apply-output-translations source)
40                   :type abcl-file-type))
41                 (output-entry 
42                  (make-pathname :defaults source-entry 
43                                 :type abcl-file-type)))
44             (format verbose "~&~A~& => ~A" output output-entry)
45             (setf (gethash output mapping)
46                   output-entry)))))
47
48(defun systems->hash-table (systems root &key (verbose nil))
49  "Build a hash table from a list of SYSTEMS mapping absolute file
50names to of these systems into relative path names under the pathname
51directory component ROOT.
52
53This mapping will be used to zip the files of the system
54into a jar file."
55  (let ((mapping (make-hash-table :test 'equal)))
56    (dolist (system systems)
57      (let ((base (slot-value system 'asdf::absolute-pathname))
58            (name (slot-value system 'asdf::name))
59            (asdf (slot-value system 'asdf::source-file)))
60        (setf (gethash asdf mapping)
61              (let ((relative-path (archive-relative-path base name asdf)))
62                (merge-pathnames
63                 relative-path
64                 (make-pathname :directory root))))
65        (add-system-files-to-mapping! system mapping base name root
66                                      :verbose verbose)))
67    mapping))
68
69(defun package (system &key 
70                         (out #p"/var/tmp/") 
71                         (recursive t)          ; whether to package dependencies
72                         (force nil)            ; whether to force ASDF compilation
73                         (root '(:relative))
74                         (verbose nil))
75"Compile and package the asdf SYSTEM in a jar.
76
77When RECURSIVE is true (the default), recursively add all asdf
78dependencies into the same jar.
79
80Place the resulting packaged jar in the OUT directory.
81
82If FORCE is true, force asdf to recompile all the necessary fasls.
83
84VERBOSE controls how many messages will be logged to
85*standard-output*.
86
87ROOT controls if the relative pathnames will be appended to something
88before being added to the mapping. The purpose of having this option
89is to add the paths to an internal directory, such as (list :relative
90\"META-INF\" \"resources\") for generating WAR files.
91
92Returns the pathname of the packaged jar archive.
93"
94  (when (not (typep system 'asdf:system))
95             (setf system (asdf:find-system system)))
96  (let* ((name 
97          (slot-value system 'asdf::name))
98         (version (let ((v (slot-value system 'asdf:version)))
99                    (when v
100                      v)))
101         (package-jar-name 
102          (format nil "~A~A~A" name (if recursive "-all" "")
103                  (if version 
104                      (format nil "-~A" version)
105                      "")))
106         (package-jar
107          (make-pathname :name package-jar-name
108                         :type "jar"
109                         :defaults out)))
110    (when verbose 
111      (format verbose "~&Packaging ASDF definition of ~A" system))
112    (when (and verbose force)
113      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
114    (asdf:compile-system system :force force)
115    (when verbose
116      (format verbose "~&Packaging contents in ~A" package-jar))
117    (system:zip package-jar
118                (systems->hash-table 
119                 (append (list system) 
120                         (when recursive
121                           (let ((dependencies (dependent-systems system)))
122                             (when (and verbose dependencies) 
123                               (format verbose
124                                       "~&  with recursive dependencies~{ ~A~^, ~}."
125                                       dependencies))
126                             (mapcar #'asdf:find-system dependencies))))
127                 root
128                 :verbose verbose))))
129
130(defun all-files (component)
131  (loop :for c 
132     :being :each :hash-value :of (slot-value component 'asdf::children-by-name)
133     :when (typep c 'asdf:module)
134     :append (all-files c)
135     :when (typep c 'asdf:source-file)
136     :append (list c)))
137
138(defun dependent-systems (system)
139  (when (not (typep system 'asdf:system))
140             (setf system (asdf:find-system system)))
141  (let* ((dependencies (asdf::component-load-dependencies system))
142         (sub-depends
143          (loop :for dependency :in dependencies
144             :for sub = (dependent-systems dependency)
145             :when sub :append sub)))
146    (remove-duplicates `(,@dependencies ,@sub-depends))))
147
148(defun archive-relative-path (base dir file) 
149  (let* ((relative 
150          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
151         (entry-dir `(:relative ,dir ,@relative)))
152    (make-pathname :device nil
153                   :directory entry-dir
154                   :defaults file)))
155
156(defun tmpdir (name)
157  "Return temporary directory."
158  (let* ((temp-file (java:jcall "getAbsolutePath" 
159                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
160         (temp-path (pathname temp-file)))
161    (make-pathname 
162     :directory (nconc (pathname-directory temp-path)
163                       (list name)))))
164
165(defun add-to-asdf (jar &key (use-jar-fasls t))
166  "Make a given JAR output by the package mechanism loadable by asdf.
167
168The parameter passed to :USE-JAR-FASLS determines whether to instruct
169asdf to use the fasls packaged in the jar.  If this is nil, the fasls
170will be compiled with respect to the usual asdf output translation
171conventions."
172  (when (not (typep jar 'pathname))
173    (setf jar (pathname jar)))
174  (when (null (pathname-device jar))
175    (setf jar (make-pathname :device (list jar))))
176
177  ;;; Inform ASDF of all the system definitions in the jar
178  (loop :for asd 
179     :in (directory (merge-pathnames "*/*.asd" jar))
180     :do (pushnew (make-pathname :defaults asd
181                                 :name nil :type nil)
182                  asdf:*central-registry*))
183
184  ;;; Load the FASLs directly from the jar
185  (when use-jar-fasls                   
186    (asdf:initialize-output-translations
187     `(:output-translations (,(merge-pathnames "/**/*.*" jar)) 
188                            :inherit-configuration))))
189
190(defun prepare-for-war (system &key 
191                                 (out #p"/var/tmp/") 
192                                 (recursive nil)          ; whether to package dependencies
193                                 (force nil)            ; whether to force ASDF compilation
194                                 (root (list :relative "META-INF" "resources"))
195                                 (verbose t))
196  "Package named asdf SYSTEM for deployment in a Java Servlet container war file.
197
198c.f. PACKAGE for further options."
199
200  (package system :out out :recursive recursive :force force :verbose verbose
201           :root root))
202
203
204(provide :asdf-jar)
Note: See TracBrowser for help on using the repository browser.