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

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

HEADS-UP breaks package.

Intermediate checkpoint on the road to fully working with the new
interface for SYSTEM:ZIP that shouldn't require any temporary
directory.

File size: 2.3 KB
Line 
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 
Note: See TracBrowser for help on using the repository browser.