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

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

Undebugged implementation of enumerating the source and fasls.

Using the SYSTEM:ZIP with a hashtable of source to fasl mappings
eliminates the need for any intermediate directory.

File size: 3.0 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 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 (lambda (c) (typep c 'asdf::source-file))
44                        (lambda (c) (input-files c )))))
45          (loop :for source :in sources
46             :do (setf (gethash (pathname-namestring source) mapping)
47                       (make-pathname :defaults source
48                                      :type "abcl"))))))
49  (system:zip package-jar mapping)))
50
51;;; This more Map than Walk at this point ...
52(defun mapwalk (system test-if callable)
53  (declare (type system asdf:system))
54  (let ((components 
55         (loop 
56            :for component :being :each :hash-value
57              :of (slot-value system 'asdf::components-by-name)
58            :when (funcall test-if component)
59            :collect component)))
60    (loop :for component :in components
61       :collecting (apply callable component))))
62
63(defun relative-path (base dir file) 
64  (let* ((relative 
65          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
66         (entry-dir `(:relative ,dir ,@(when relative relative))))
67    (make-pathname :directory entry-dir
68                   :defaults file)))
69
70(defun tmpdir (name)
71  "Return temporary directory."
72  (let* ((temp-file (java:jcall "getAbsolutePath" 
73                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
74         (temp-path (pathname temp-file)))
75    (make-pathname 
76     :directory (nconc (pathname-directory temp-path)
77                       (list name)))))
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93   
94 
95
96 
97 
Note: See TracBrowser for help on using the repository browser.