[armedbear-cvs] r13337 - trunk/abcl/contrib/asdf-jar

[mevenson at common-lisp.net]

Author: mevenson
Date: Thu Jun 16 08:02:11 2011
New Revision: 13337

Log:
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.

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

Modified: trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
==============================================================================
--- trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Thu Jun 16 07:56:53 2011	(r13336)
+++ trunk/abcl/contrib/asdf-jar/asdf-jar.lisp	Thu Jun 16 08:02:11 2011	(r13337)
@@ -7,20 +7,12 @@
 
 (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 
                 &key (out #p"/var/tmp/") 
                      (recursive t) 
                      (verbose t))
-  (asdf:disable-output-translations)
   (let* ((system 
           (asdf:find-system system-name))
 	 (name 
@@ -31,7 +23,7 @@
           (format nil "~A~A-~A.jar" name (when recursive "-all") version))
          (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))
     (setf *systems* nil)
@@ -43,34 +35,23 @@
       (when verbose
 	(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))
-
-(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))))))
-                          
+        (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 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")))
          (temp-path (pathname temp-file)))