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

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

Create form of SYSTEM:ZIP that uses a hashtable to map files to entries.

SYSTEM:ZIP PATH HASHTABLE now creates entries in a zipfile at PATH
whose entries are the contents of for each (KEY VALUE) in HASHTABLE
for which KEY refers to an object on the filesystem and VALUE is the
location in the zip archive.

Introduce Java interfaces in org.armedbear.lisp.protocol to start
encapsulating behavior of Java system. By retroactively adding
markers to the object hierarchy rooted on LispObject we gain the
ability to have our JVM code optionally work with interfaces but we
leave the core dispatch functions alone for speed.

File size: 3.1 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;; (defvar *sources*)
13;; (defmethod asdf:perform :before ((op asdf:compile-op) (s asdf:source-file))
14;;        (push c *sources*))
15
16(eval-when (:compile-toplevel :execute)
17  (ql:quickload "cl-fad"))
18
19(defun package (system-name 
20                &key (out #p"/var/tmp/") 
21                     (recursive t) 
22                     (verbose t))
23  (asdf:disable-output-translations)
24  (let* ((system 
25          (asdf:find-system system-name))
26   (name 
27          (slot-value system 'asdf::name))
28         (version 
29          (slot-value system 'asdf:version))
30         (package-jar-name 
31          (format nil "~A~A-~A.jar" name (when recursive "-all") version))
32         (package-jar
33          (make-pathname :directory out :defaults package-jar-name))
34         (tmpdir (tmpdir (pathname-name (pathname package-jar-name)))))
35    (when verbose 
36      (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
37    (setf *systems* nil)
38    (asdf:compile-system system :force t)
39    (let* ((dir (asdf:component-pathname system))
40     (wild-contents (merge-pathnames "**/*" dir))
41     (contents (directory wild-contents))
42     (topdir (truename (merge-pathnames "../" dir))))
43      (when verbose
44  (format verbose "~&Packaging contents in ~A." package-jar))
45      (dolist (system (append (list system) *systems*))
46        (copy-recursively system tmpdir))
47      (system:zip package-jar contents topdir)))
48  (asdf:initialize-output-translations))
49
50(defun copy-recursively (source destination)
51  (let* ((source (truename source))
52         (source-directories (1- (length (pathname-directory source))))
53         (destination (truename destination)))
54    (cl-fad:walk-directory 
55     source
56   (lambda (p) 
57     (let* ((relative-depth (- (length (pathname-directory p))
58                               (length (pathname-directory source))))
59            (subdir '(nthcdr (+ source-directories relative-depth)
60                      (pathname-directory source)))
61            (orig (merge-pathnames p
62                                   (make-pathname :directory (append (pathname-directory
63                                                                      source)
64                                                                     subdir))))
65            (dest (merge-pathnames p
66                                  (make-pathname :directory (append (pathname-directory
67                                                                     destination)
68                                                                    subdir)))))
69       (format t "~&Would copy ~A~&to ~A." orig dest))))))
70                         
71
72(defun tmpdir (name)
73  "Return a the named temporary directory."
74  (let* ((temp-file (java:jcall "getAbsolutePath" 
75                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
76         (temp-path (pathname temp-file)))
77    (make-pathname 
78     :directory (nconc (pathname-directory temp-path)
79                       (list name)))))
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95   
96 
97
98 
99 
Note: See TracBrowser for help on using the repository browser.