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

Last change on this file since 13795 was 13795, checked in by Mark Evenson, 11 years ago

Yong patches asdf-jar for MSFT.

See http://article.gmane.org/gmane.lisp.armedbear.devel/2190

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