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

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

Incremental progress towards getting ASDF-JAR working.

Now we just need to come up with the logic for specifying the entry
within the jar for the source and the fasls.

File size: 3.3 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) 
14                     (verbose t))
15  (let* ((system 
16          (asdf:find-system system-name))
17   (name 
18          (slot-value system 'asdf::name))
19         (version 
20          (slot-value system 'asdf:version))
21         (package-jar-name 
22          (format nil "~A~A-~A.jar" name (when recursive "-all") version))
23         (package-jar
24          (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
25         (mapping (make-hash-table :test 'equal)))
26    (when verbose 
27      (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
28    (setf *systems* nil)
29    (when verbose
30      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
31    (asdf:compile-system system :force t)
32    (when verbose
33      (format verbose "~&Packaging contents in ~A." package-jar))
34    (dolist (system (append (list system) *systems*))
35      (let ((base (slot-value system 'asdf::absolute-pathname))
36            (name (slot-value system 'asdf::name))
37            (asdf (slot-value system 'asdf::source-file)))
38        (setf (gethash asdf mapping) (relative-path base name asdf))
39       
40          ;;; XXX iterate through the rest of the contents of the
41          ;;; system, adding appropiate entries
42        (let ((sources
43               (mapwalk system
44                        (lambda (c) (typep c 'asdf::source-file))
45                        (lambda (c) (slot-value c 'asdf::absolute-pathname)))))
46          (loop :for source :in sources
47             :for source-entry = (relative-pathname base source)
48             :for output = (make-pathname 
49                             :defaults (asdf:apply-output-translations source)
50                             :type "abcl")
51             :for output-entry = (relative-pathname base output)
52             :do (setf (gethash (namestring source) mapping)
53                       source-entry)
54             :do (setf (gethash (namestring output) mapping)
55                       output-entry)))))
56      (system:zip package-jar mapping)))
57
58(defun relative-pathname (base source)
59  (declare (ignore base source))
60  (error "unimplemented."))
61
62;;; This more Map than Walk at this point ...
63(defun mapwalk (system test-if callable)
64  (declare (type system asdf:system))
65  (loop 
66     :for component :being :each :hash-value
67     :of (slot-value system 'asdf::components-by-name)
68     :when 
69       (funcall test-if component)
70     :collect 
71       (funcall callable component)))
72
73(defun relative-path (base dir file) 
74  (let* ((relative 
75          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
76         (entry-dir `(:relative ,dir ,@(when relative relative))))
77    (make-pathname :directory entry-dir
78                   :defaults file)))
79
80(defun tmpdir (name)
81  "Return temporary directory."
82  (let* ((temp-file (java:jcall "getAbsolutePath" 
83                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
84         (temp-path (pathname temp-file)))
85    (make-pathname 
86     :directory (nconc (pathname-directory temp-path)
87                       (list name)))))
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103   
104 
105
106 
107 
Note: See TracBrowser for help on using the repository browser.