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

Last change on this file was 15686, checked in by Mark Evenson, 12 months ago

asdf-jar: extensive grouting of accumulated bitrot

Source ASDF systems residing in jar files may now be repackaged, as
was the usually case for JSS which prompted this rework.

We now neither package nor read fasls from jar files by default for
two reasons. First, configuring ASDF to not compile systems seems to
have changed somewhat, so the finagling of output translations no
longer seems to work. Secondly, since the Lisp compiler is always
present at runtime, fasls can always be created provided that ASDF has
writable local directory, which would probably be true in almost
all (?) deployment scenarios.

We now attempt to package non-source artifacts declared in system
definitions via asdf components that are files but not compiled
artifacts as well as those which appear in the
ASDF/COMPONENT::ADDITIONAL-INPUT-FILES slot.

We have removed use of ASDF internal symbols as much as possible, but
alas still use a couple internal interfaces where unavoidable.

We no longer use the deprecated ASDF:*CENTRAL-REGISTRY* to add systems
to the source registry.

Resolves <https://github.com/armedbear/abcl/issues/476>.

File size: 11.1 KB
Line 
1;;; This file is part of ABCL contrib
2;;;
3;;; Copyright 2011 Mark <evenson@panix.com>
4
5(in-package #:asdf-jar)
6
7(defun add-system-files-to-mapping! (system
8                                     mapping
9                                     system-base
10                                     system-name
11                                     root
12                                     &key
13                                       (fasls t)
14                                       (verbose nil))
15  "Add all the files of a SYSTEM to the MAPPING with a given
16SYSTEM-BASE and SYSTEM-NAME.
17
18This function destructively modifies MAPPING returning nil."
19  (let ((abcl-file-type "abcl"))
20    (loop
21      :for component :in (all-files system) 
22      :for source = (asdf/component:component-pathname component)
23      :for source-entry = (merge-pathnames
24                           (archive-relative-path system-base system-name source)
25                           (make-pathname :directory root))
26      :do (setf (gethash source mapping)
27                source-entry)
28      :do (format verbose "~&~A~%~T=>~A~%" source source-entry)
29      :when (and fasls
30                 (typep component 'asdf/component:source-file)
31                 (not (typep component 'asdf/component:static-file)))
32        :do (let ((output 
33                    (make-pathname
34                     :defaults (asdf:apply-output-translations source)
35                     :type abcl-file-type))
36                  (output-entry 
37                    (make-pathname :defaults source-entry 
38                                   :type abcl-file-type)))
39              (format verbose "~&~A~% => ~A~%" output output-entry)
40              (setf (gethash output mapping)
41                    output-entry)))))
42
43(defun systems->hash-table (systems root &key (fasls t) (verbose nil))
44  "Build a hash table from a list of SYSTEMS mapping absolute file
45names to of these systems into relative path names under the pathname
46directory component ROOT.
47
48This mapping will be used to zip the files of the system
49into a jar file."
50  (let ((mapping (make-hash-table :test 'equal)))
51    (dolist (system systems)
52      (let ((base (slot-value system 'asdf/component:absolute-pathname))
53            (name (slot-value system 'asdf/component:name))
54            (asdf (slot-value system 'asdf/component:source-file)))
55        ;; For the purposes of locating their ASDF file, subsystems
56        ;; use the name of their parent.
57        (let ((position (position #\/ name)))
58          (when position
59            (setf name
60                  (subseq name 0 position)))
61          (setf (gethash asdf mapping)
62                (let ((relative-path (archive-relative-path base name asdf)))
63                  (merge-pathnames
64                   relative-path
65                   (make-pathname :directory root))))
66          (let ((additional
67                  (slot-value system 'asdf/component::additional-input-files)))
68            (when additional
69              (loop
70                :for (op file) :in additional
71                :when (and
72                       op ;; TODO: tighten allowed ops?
73                       (probe-file file))
74                  :do (setf (gethash file mapping)
75                            (let ((relative-path (archive-relative-path base name file)))
76                              (merge-pathnames
77                               relative-path
78                               (make-pathname :directory root))))))
79            (add-system-files-to-mapping! system mapping base name root
80                                          :fasls fasls
81                                          :verbose verbose)))))
82    mapping))
83
84(defun package (system &key 
85                         (out #p"/var/tmp/") 
86                         (recursive t)          ; whether to package dependencies
87                         (force nil)            ; whether to force ASDF compilation
88                         (fasls nil) 
89                         (root '(:relative))
90                         (verbose nil))
91"Compile and package the asdf SYSTEM in a jar.
92
93When RECURSIVE is true (the default), recursively add all asdf
94dependencies into the same jar.
95
96Place the resulting packaged jar in the OUT directory.
97
98If FORCE is true, force asdf to recompile all the necessary fasls.
99
100VERBOSE controls how many messages will be logged to
101*standard-output*.
102
103ROOT controls if the relative pathnames will be appended to something
104before being added to the mapping. The purpose of having this option
105is to add the paths to an internal directory, such as (list :relative
106\"META-INF\" \"resources\") for generating WAR files.
107
108Returns the pathname of the packaged jar archive as the first value,
109and the hash of its members source to destination locations as the
110second.
111"
112  (when (not (typep system 'asdf:system))
113             (setf system (asdf:find-system system)))
114  (let* ((name 
115          (slot-value system 'asdf/component:name))
116         (version (let ((v (slot-value system 'asdf:version)))
117                    (when v
118                      v)))
119         (package-jar-name 
120          (format nil "~A~A~A" name (if recursive "-all" "")
121                  (if version 
122                      (format nil "-~A" version)
123                      "")))
124         (package-jar
125          (make-pathname :name package-jar-name
126                         :type "jar"
127                         :defaults out)))
128    (when verbose 
129      (format verbose "~&Packaging ASDF definition of ~A~%" system))
130    (when verbose
131      (format verbose "~&Performing ~a compilation of ~A.~%"
132              (if force
133                  "forced"
134                  "unforced")
135              package-jar))
136    (asdf:compile-system system :force force)
137    (when verbose
138      (format verbose "~&Packaging contents in '~A'.~%" package-jar))
139    (let ((hash-table
140            (systems->hash-table 
141             (append (list system) 
142                     (when recursive
143                       (let* ((dependencies
144                                (dependent-systems system))
145                              (washed-dependencies
146                                (remove-if-not
147                                 (lambda (s)
148                                   (if (asdf/component:component-pathname s)
149                                       t
150                                       (progn 
151                                         (when verbose
152                                           (format verbose
153                                                   "~&Ignoring dependency ~a without associated pathname.~%"
154                                                   s))
155                                         nil)))
156                                 dependencies)))
157                         (when (and verbose washed-dependencies) 
158                           (format verbose
159                                   "~&Packaging with recursive dependencies~{ ~A~^, ~}.~%"
160                                   washed-dependencies))
161                         (mapcar #'asdf:find-system washed-dependencies))))
162             root
163             :fasls fasls :verbose verbose)))
164      (values
165       (system:zip package-jar hash-table)
166       hash-table))))
167
168(defun all-files (component)
169  (loop
170    :for c 
171      :being :each :hash-value :of (slot-value component 'asdf/component:children-by-name)
172    :when (typep c 'asdf:module)
173      :append (all-files c)
174    :when (typep c 'asdf/component:source-file)
175      :append (list c)))
176
177(defun resolve-system-or-feature (system-or-feature)
178  "Resolve SYSTEM-OR-FEATURE to an asdf system"
179  (cond
180    ((null system-or-feature)
181     nil)
182    ((and (consp system-or-feature)
183          (= (length system-or-feature) 1))
184     (asdf:find-system (first system-or-feature)))
185    ((and (consp system-or-feature)
186          (= (length system-or-feature) 3))
187     (destructuring-bind (keyword expression system)
188         system-or-feature
189       (unless (equalp keyword :feature)
190         (error "~a is not a feature expression" system-or-feature))
191       (when (uiop/os:featurep expression)
192         (asdf:find-system system))))
193    ((typep system-or-feature 'asdf:system)
194     system-or-feature)
195    (t
196     (asdf:find-system system-or-feature))))
197
198(defun dependent-systems (system-or-feature)
199  (let ((system
200          (resolve-system-or-feature system-or-feature)))
201    (when system
202      (remove-duplicates
203       (loop :for dependency
204               :in (asdf/component:component-sideway-dependencies system)
205             :for resolved-dependency = (resolve-system-or-feature dependency)
206             :for dependents = (dependent-systems resolved-dependency)
207             :when resolved-dependency
208               :collect resolved-dependency
209             :when dependents
210               :append dependents)))))
211
212(defun archive-relative-path (base dir file) 
213  (let* ((relative 
214          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
215         (entry-dir `(:relative ,dir ,@relative)))
216    (make-pathname :device nil
217                   :directory entry-dir
218                   :defaults file)))
219
220(defun tmpdir (name)
221  "Return temporary directory."
222  (let* ((temp-file (java:jcall "getAbsolutePath" 
223                                (java:jstatic "createTempFile" "java.io.File"
224                                              (symbol-name (gensym)) "tmp")))
225         (temp-path (pathname temp-file)))
226    (make-pathname 
227     :directory (nconc (pathname-directory temp-path)
228                       (list name)))))
229
230(defun add-to-asdf (jar &key (use-jar-fasls nil) (verbose *standard-output*))
231  "Make a given JAR output by the package mechanism loadable by asdf.
232
233NOTICE: the use of fasls from the jar does not currently seem to work.
234
235The parameter passed to :USE-JAR-FASLS determines whether to instruct
236asdf to use the fasls packaged in the jar.  If this is nil, the
237default, the fasls will be compiled with respect to the usual asdf
238output translation conventions."
239  (when (not (typep jar 'pathname))
240    (setf jar (pathname jar)))
241  (when (null (pathname-device jar))
242    (setf jar (make-pathname :device (list jar))))
243  ;;; Inform ASDF of all the system definitions in the jar
244  (let ((asdf-files
245          (directory (merge-pathnames "*/*.asd" jar))))
246    (format verbose "~&Adding to ASDF: ~{~%~t<~a>~}~%" asdf-files)
247    (ext:register-asdf asdf-files))
248  ;;; Load the FASLs directly from the jar
249  (when use-jar-fasls
250    (let* ((source
251             (make-pathname :defaults jar
252                            :directory '(:ABSOLUTE :WILD-INFERIORS) :name :wild :type :wild))
253           (destination
254             source))
255      (asdf:initialize-output-translations
256       `(:output-translations (,source ,destination) :inherit-configuration)))))
257
258
259(defun prepare-for-war (system &key 
260                                 (out #p"/var/tmp/") 
261                                 (recursive nil)          ; whether to package dependencies
262                                 (force nil)            ; whether to force ASDF compilation
263                                 (root (list :relative "META-INF" "resources"))
264                                 (verbose t))
265  "Package named asdf SYSTEM for deployment in a Java Servlet container war file.
266
267c.f. PACKAGE for further options."
268
269  (package system :out out :recursive recursive :force force :verbose verbose
270           :root root))
271
272
273(provide :asdf-jar)
Note: See TracBrowser for help on using the repository browser.