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

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

ASDF-JAR:PACKAGE will compile and package asdf systems into jar files.

In order to load the fasls from these files, one has to disable ASDF's
output translations so that it searches the jar archive.

The packaing of recursive dependencies currently doesn't work.

File size: 3.6 KB
Line 
1(defpackage #:asdf-jar
2  (:use :cl)
3  (:export #:package))
4
5(in-package :asdf-jar)
6
7(defvar *systems*)
8(defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
9  (push c *systems*))
10
11(defun package (system-name 
12                &key (out #p"/var/tmp/") 
13                     (recursive t)          ; whether to package dependencies
14                     (force t)              ; whether to force ASDF compilation
15                     (verbose t))
16"Compile and package the asdf SYSTEM-NAME in a jar.
17
18Place the resulting packaging in the OUT directory."
19  (let* ((system 
20          (asdf:find-system system-name))
21   (name 
22          (slot-value system 'asdf::name))
23         (version 
24          (slot-value system 'asdf:version))
25         (package-jar-name 
26          (format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
27         (package-jar
28          (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
29         (mapping (make-hash-table :test 'equal)))
30    (when verbose 
31      (format verbose "~&Packaging ASDF definition of ~A~&  as ~A." system package-jar))
32    (setf *systems* nil)
33    (when verbose
34      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
35    (asdf:compile-system system :force force)
36    (when verbose
37      (format verbose "~&Packaging contents in ~A." package-jar))
38    (dolist (system (append (list system) *systems*))
39      (let ((base (slot-value system 'asdf::absolute-pathname))
40            (name (slot-value system 'asdf::name))
41            (asdf (slot-value system 'asdf::source-file)))
42        (setf (gethash asdf mapping) (relative-path base name asdf))
43        (let ((sources
44               (mapwalk system
45                        (lambda (c) (typep c 'asdf::source-file))
46                        (lambda (c) (slot-value c 'asdf::absolute-pathname)))))
47          (loop :for source :in sources
48             :for source-entry = (relative-path base name source)
49             :for output = (make-pathname 
50                             :defaults (asdf:apply-output-translations source)
51                             :type "abcl")
52             :for output-entry = (make-pathname
53                                  :defaults source-entry
54                                  :type "abcl")
55             :do (setf (gethash (namestring source) mapping)
56                       source-entry)
57             :do (setf (gethash (namestring output) mapping)
58                       output-entry)))))
59      (system:zip package-jar mapping)))
60
61;;; This more Map than Walk at this point ...
62(defun mapwalk (system test-if callable)
63  "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF.
64
65Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument."
66  (declare (type system asdf:system))
67  (loop 
68     :for component :being :each :hash-value
69     :of (slot-value system 'asdf::components-by-name)
70     :when 
71       (funcall test-if component)
72     :collect 
73       (funcall callable component)))
74
75(defun relative-path (base dir file) 
76  (let* ((relative 
77          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
78         (entry-dir `(:relative ,dir ,@(when relative relative))))
79    (make-pathname :directory entry-dir
80                   :defaults file)))
81
82(defun tmpdir (name)
83  "Return temporary directory."
84  (let* ((temp-file (java:jcall "getAbsolutePath" 
85                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
86         (temp-path (pathname temp-file)))
87    (make-pathname 
88     :directory (nconc (pathname-directory temp-path)
89                       (list name)))))
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106   
107 
108
109 
110 
Note: See TracBrowser for help on using the repository browser.