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

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

Document the use of the ASDF-JAR contrib.

ASDF:ADD-TO-ASDF provides a mechanism to add the contents of a
pathname specifying an jar package to be subequently loaded by ASDF.

Generalize mechanism to specifiy contrib contents while including
"README.markdown" files.

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