Changeset 13337
- Timestamp:
- 06/16/11 15:02:11 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/contrib/asdf-jar/asdf-jar.lisp
r13336 r13337 8 8 (defvar *systems*) 9 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")) 10 (push c *systems*)) 18 11 19 12 (defun package (system-name … … 21 14 (recursive t) 22 15 (verbose t)) 23 (asdf:disable-output-translations)24 16 (let* ((system 25 17 (asdf:find-system system-name)) … … 32 24 (package-jar 33 25 (make-pathname :directory out :defaults package-jar-name)) 34 ( tmpdir (tmpdir (pathname-name (pathname package-jar-name)))))26 (mapping (make-hash-table :test 'equal))) 35 27 (when verbose 36 28 (format verbose "~&Packaging ASDF definition of ~A~&as ~A." system package-jar)) … … 44 36 (format verbose "~&Packaging contents in ~A." package-jar)) 45 37 (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)))) 49 45 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))) 71 52 72 53 (defun tmpdir (name) 73 "Return a the namedtemporary directory."54 "Return temporary directory." 74 55 (let* ((temp-file (java:jcall "getAbsolutePath" 75 56 (java:jstatic "createTempFile" "java.io.File" "foo" "tmp")))
Note: See TracChangeset
for help on using the changeset viewer.