1 | (defpackage :asdf-jar |
---|
2 | (:use :cl) |
---|
3 | (:export #:package)) |
---|
4 | |
---|
5 | (in-package :asdf-jar) |
---|
6 | |
---|
7 | |
---|
8 | (defvar *systems*) |
---|
9 | (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system)) |
---|
10 | (push c *systems*)) |
---|
11 | |
---|
12 | (defun package (system-name |
---|
13 | &key (out #p"/var/tmp/") |
---|
14 | (recursive t) |
---|
15 | (verbose t)) |
---|
16 | (let* ((system |
---|
17 | (asdf:find-system system-name)) |
---|
18 | (name |
---|
19 | (slot-value system 'asdf::name)) |
---|
20 | (version |
---|
21 | (slot-value system 'asdf:version)) |
---|
22 | (package-jar-name |
---|
23 | (format nil "~A~A-~A.jar" name (when recursive "-all") version)) |
---|
24 | (package-jar |
---|
25 | (make-pathname :directory out :defaults package-jar-name)) |
---|
26 | (mapping (make-hash-table :test 'equal))) |
---|
27 | (when verbose |
---|
28 | (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) |
---|
29 | (setf *systems* nil) |
---|
30 | (asdf:compile-system system :force t) |
---|
31 | (let* ((dir (asdf:component-pathname system)) |
---|
32 | (wild-contents (merge-pathnames "**/*" dir)) |
---|
33 | (contents (directory wild-contents)) |
---|
34 | (topdir (truename (merge-pathnames "../" dir)))) |
---|
35 | (when verbose |
---|
36 | (format verbose "~&Packaging contents in ~A." package-jar)) |
---|
37 | (dolist (system (append (list system) *systems*)) |
---|
38 | (let ((base (slot-value system 'asdf:absolute-pathname)) |
---|
39 | (name (slot-value system 'asdf:name)) |
---|
40 | (asdf (slot-value system source-file))) |
---|
41 | (setf (gethash asdf mapping) (relative-path base name asdf)))) |
---|
42 | ;;; XXX iterate through the rest of the contents of the |
---|
43 | ;;; system, adding appropiate entries |
---|
44 | (system:zip package-jar mapping)))) |
---|
45 | |
---|
46 | (defun relative-path (base dir file) |
---|
47 | (let* ((relative |
---|
48 | (nthcdr (length (pathname-directory base)) (pathname-directory file))) |
---|
49 | (entry-dir `(:relative ,dir ,@(when relative relative)))) |
---|
50 | (make-pathname :directory entry-dir |
---|
51 | :defaults file))) |
---|
52 | |
---|
53 | (defun tmpdir (name) |
---|
54 | "Return temporary directory." |
---|
55 | (let* ((temp-file (java:jcall "getAbsolutePath" |
---|
56 | (java:jstatic "createTempFile" "java.io.File" "foo" "tmp"))) |
---|
57 | (temp-path (pathname temp-file))) |
---|
58 | (make-pathname |
---|
59 | :directory (nconc (pathname-directory temp-path) |
---|
60 | (list name))))) |
---|
61 | |
---|
62 | |
---|
63 | |
---|
64 | |
---|
65 | |
---|
66 | |
---|
67 | |
---|
68 | |
---|
69 | |
---|
70 | |
---|
71 | |
---|
72 | |
---|
73 | |
---|
74 | |
---|
75 | |
---|
76 | |
---|
77 | |
---|
78 | |
---|
79 | |
---|
80 | |
---|