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

Last change on this file since 14717 was 14717, checked in by Mark Evenson, 7 years ago

Fix #364: ASDF-JAR:PACKAGE breaks with simple usage.

Thanks to Eduardo Bellani.

<http://abcl.org/trac/ticket/364>

File size: 8.2 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                                     &optional root verbose)
21  "Auxiliary procedure that adds all the files of a SYSTEM to the
22MAPPING with a given SYSTEM-BASE and SYSTEM-NAME. The whole idea of
23this procedure is to modify MAPPING, so a NIL is returned."
24  (let ((abcl-file-type "abcl"))
25    (loop :for component :in (all-files system) 
26       :for source = (slot-value component 'asdf::absolute-pathname)
27       :for source-entry = (archive-relative-path system-base system-name source)
28       :do (setf (gethash source mapping)
29                 (if root 
30                     (merge-pathnames source-entry (make-pathname :directory root))
31                     source-entry))
32       :do (format verbose "~&~A~& => ~A" source source-entry)
33       :when (and (typep component 'asdf::source-file)
34                  (not (typep component 'asdf::static-file)))
35       :do (let ((output 
36                  (make-pathname
37                   :defaults (asdf:apply-output-translations source)
38                   :type abcl-file-type))
39                 (output-entry 
40                  (make-pathname :defaults source-entry 
41                                 :type abcl-file-type
42                                 :directory
43                                 (append root
44                                         (cadr (pathname-directory source-entry))))))
45             (format verbose "~&~A~& => ~A" output output-entry)
46             (setf (gethash output mapping)
47                   output-entry)))))
48
49(defun systems->hash-table (systems &optional root verbose)
50  "Auxiliary function that, given a list of SYSTEMS, builds a hash
51table mapping absolute file names to of these systems into relative
52path names. This mapping will be used to zip the files of the system
53into a JAR file."
54  (let ((mapping (make-hash-table :test 'equal)))
55    (dolist (system systems)
56      (let ((base (slot-value system 'asdf::absolute-pathname))
57            (name (slot-value system 'asdf::name))
58            (asdf (slot-value system 'asdf::source-file)))
59        (setf (gethash asdf mapping)
60              (let ((relative-path (archive-relative-path base name asdf)))
61                (if root
62                    (merge-pathnames
63                     relative-path
64                     (make-pathname :directory root))
65                    relative-path)))
66        (add-system-files-to-mapping! system mapping base name root 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 nil)
74                         (verbose t))
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))))
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.