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

Last change on this file since 14695 was 14695, checked in by Mark Evenson, 8 years ago

Enable PACKAGE-FOR-WAR to work by reading the servlet spec and disabling WARN.

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