Changeset 13337

Timestamp:

06/16/11 15:02:11 (12 years ago)

Author:

Mark Evenson

Message:

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:

• trunk/abcl/contrib/asdf-jar/asdf-jar.lisp (modified) (4 diffs)

trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

@@ -8 +8 @@
 (defvar *systems*)
 (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
-       (push c *systems*))
-
-;; (defvar *sources*)
-;; (defmethod asdf:perform :before ((op asdf:compile-op) (s asdf:source-file))
-;;        (push c *sources*))
-
-(eval-when (:compile-toplevel :execute)
-  (ql:quickload "cl-fad"))
+  (push c *systems*))
 
 (defun package (system-name 
@@ -21 +14 @@
                      (recursive t) 
                      (verbose t))
-  (asdf:disable-output-translations)
   (let* ((system 
           (asdf:find-system system-name))
@@ -32 +24 @@
          (package-jar
           (make-pathname :directory out :defaults package-jar-name))
-         (tmpdir (tmpdir (pathname-name (pathname package-jar-name)))))
+         (mapping (make-hash-table :test 'equal)))
     (when verbose 
       (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
@@ -44 +36 @@
   (format verbose "~&Packaging contents in ~A." package-jar))
       (dolist (system (append (list system) *systems*))
-        (copy-recursively system tmpdir))
-      (system:zip package-jar contents topdir)))
-  (asdf:initialize-output-translations))
+        (let ((base (slot-value system 'asdf:absolute-pathname))
+              (name (slot-value system 'asdf:name))
+              (asdf (slot-value system source-file)))
+          (setf (gethash asdf mapping) (relative-path base name asdf))))
+          ;;; XXX iterate through the rest of the contents of the
+          ;;; system, adding appropiate entries
+      (system:zip package-jar mapping))))
 
-(defun copy-recursively (source destination)
-  (let* ((source (truename source))
-         (source-directories (1- (length (pathname-directory source))))
-         (destination (truename destination)))
-    (cl-fad:walk-directory 
-     source
-   (lambda (p) 
-     (let* ((relative-depth (- (length (pathname-directory p))
-                               (length (pathname-directory source))))
-            (subdir '(nthcdr (+ source-directories relative-depth)
-                      (pathname-directory source)))
-            (orig (merge-pathnames p
-                                   (make-pathname :directory (append (pathname-directory
-                                                                      source)
-                                                                     subdir))))
-            (dest (merge-pathnames p
-                                  (make-pathname :directory (append (pathname-directory
-                                                                     destination)
-                                                                    subdir)))))
-       (format t "~&Would copy ~A~&to ~A." orig dest))))))
-                          
+(defun relative-path (base dir file) 
+  (let* ((relative 
+          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
+         (entry-dir `(:relative ,dir ,@(when relative relative))))
+    (make-pathname :directory entry-dir
+                   :defaults file)))
 
 (defun tmpdir (name)
-  "Return a the named temporary directory."
+  "Return temporary directory."
   (let* ((temp-file (java:jcall "getAbsolutePath" 
                                (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))