Changeset 13337


Ignore:
Timestamp:
06/16/11 15:02:11 (10 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:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

    r13336 r13337  
    88(defvar *systems*)
    99(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"))
     10  (push c *systems*))
    1811
    1912(defun package (system-name
     
    2114                     (recursive t)
    2215                     (verbose t))
    23   (asdf:disable-output-translations)
    2416  (let* ((system
    2517          (asdf:find-system system-name))
     
    3224         (package-jar
    3325          (make-pathname :directory out :defaults package-jar-name))
    34          (tmpdir (tmpdir (pathname-name (pathname package-jar-name)))))
     26         (mapping (make-hash-table :test 'equal)))
    3527    (when verbose
    3628      (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar))
     
    4436  (format verbose "~&Packaging contents in ~A." package-jar))
    4537      (dolist (system (append (list system) *systems*))
    46         (copy-recursively system tmpdir))
    47       (system:zip package-jar contents topdir)))
    48   (asdf:initialize-output-translations))
     38        (let ((base (slot-value system 'asdf:absolute-pathname))
     39              (name (slot-value system 'asdf:name))
     40              (asdf (slot-value system source-file)))
     41          (setf (gethash asdf mapping) (relative-path base name asdf))))
     42          ;;; XXX iterate through the rest of the contents of the
     43          ;;; system, adding appropiate entries
     44      (system:zip package-jar mapping))))
    4945
    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                          
     46(defun relative-path (base dir file)
     47  (let* ((relative
     48          (nthcdr (length (pathname-directory base)) (pathname-directory file)))
     49         (entry-dir `(:relative ,dir ,@(when relative relative))))
     50    (make-pathname :directory entry-dir
     51                   :defaults file)))
    7152
    7253(defun tmpdir (name)
    73   "Return a the named temporary directory."
     54  "Return temporary directory."
    7455  (let* ((temp-file (java:jcall "getAbsolutePath"
    7556                               (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
Note: See TracChangeset for help on using the changeset viewer.