Changeset 13348


Ignore:
Timestamp:
06/18/11 14:26:16 (10 years ago)
Author:
Mark Evenson
Message:

ASDF-JAR:PACKAGE now handles recursive dependencies.

Rewrote the dependency walking logic to actually work and to only
include output files for component types that have them.

Location:
trunk/abcl/contrib/asdf-jar
Files:
2 edited

Legend:

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

    r13308 r13348  
    11;;;; -*- Mode: LISP -*-
    2 (in-package :Asdf)
     2(in-package :asdf)                     
    33
    44(defsystem :asdf-jar
    55  :author "Mark Evenson"
    6   :version "0.1.0"
     6  :version "0.2.0"
    77  :components
    88  ((:module base :pathname "" :components
  • trunk/abcl/contrib/asdf-jar/asdf-jar.lisp

    r13347 r13348  
    55(in-package :asdf-jar)
    66
    7 (defvar *systems*)
    8 (defmethod asdf:perform :before ((op asdf:compile-op) (c asdf:system))
    9   (push c *systems*))
     7(defvar *debug* nil)
    108
    119(defun package (system-name
    1210                &key (out #p"/var/tmp/")
    1311                     (recursive t)          ; whether to package dependencies
    14                      (force t)              ; whether to force ASDF compilation
     12                     (force nil)              ; whether to force ASDF compilation
    1513                     (verbose t))
    1614"Compile and package the asdf SYSTEM-NAME in a jar.
    1715
    18 Place the resulting packaging in the OUT directory."
     16When RECURSIVE is true (the default), recursively add all asdf
     17dependencies into the same jar.
     18
     19Place the resulting packaging in the OUT directory.
     20
     21Returns the pathname of the created jar archive.
     22"
    1923  (let* ((system
    2024          (asdf:find-system system-name))
     
    2226          (slot-value system 'asdf::name))
    2327         (version
    24           (slot-value system 'asdf:version))
     28          (handler-case (slot-value system 'asdf:version)
     29            (unbound-slot () "unknown")))
     30
    2531         (package-jar-name
    2632          (format nil "~A~A-~A.jar" name (if recursive "-all" "") version))
    2733         (package-jar
    2834          (make-pathname :directory (pathname-directory out) :defaults package-jar-name))
    29          (mapping (make-hash-table :test 'equal)))
     35         (mapping (make-hash-table :test 'equal))
     36         (dependencies (dependent-systems system)))
    3037    (when verbose
    3138      (format verbose "~&Packaging ASDF definition of ~A~&  as ~A." system package-jar))
    32     (setf *systems* nil)
    33     (when verbose
     39    (when (and verbose force)
    3440      (format verbose "~&Forcing recursive compilation of ~A." package-jar))
    3541    (asdf:compile-system system :force force)
    3642    (when verbose
    37       (format verbose "~&Packaging contents in ~A." package-jar))
    38     (dolist (system (append (list system) *systems*))
     43      (format verbose "~&Packaging contents in ~A" package-jar))
     44    (when (and verbose recursive)
     45      (format verbose "~&  with recursive dependencies~{ ~A~^, ~}." dependencies))
     46    (dolist (system (append (list system)
     47                            (when recursive
     48                              (mapcar #'asdf:find-system dependencies))))
    3949      (let ((base (slot-value system 'asdf::absolute-pathname))
    4050            (name (slot-value system 'asdf::name))
    4151            (asdf (slot-value system 'asdf::source-file)))
    4252        (setf (gethash asdf mapping) (relative-path base name asdf))
    43         (let ((sources
    44                (mapwalk system
    45                         (lambda (c) (typep c 'asdf::source-file))
    46                         (lambda (c) (slot-value c 'asdf::absolute-pathname)))))
    47           (loop :for source :in sources
    48              :for source-entry = (relative-path base name source)
    49              :for output = (make-pathname
    50                              :defaults (asdf:apply-output-translations source)
    51                              :type "abcl")
    52              :for output-entry = (make-pathname
    53                                   :defaults source-entry
    54                                   :type "abcl")
    55              :do (setf (gethash (namestring source) mapping)
    56                        source-entry)
    57              :do (setf (gethash (namestring output) mapping)
     53        (loop :for component :in (all-files system)
     54           :for source = (slot-value component 'asdf::absolute-pathname)
     55           :for source-entry = (relative-path base name source)
     56           :do (setf (gethash source mapping)
     57                     source-entry)
     58           :do (when *debug*
     59                 (format verbose "~&~A~& => ~A" source source-entry))
     60           :when (and (typep component 'asdf::source-file)
     61                      (not (typep component 'asdf::static-file)))
     62           :do (let ((output
     63                      (make-pathname
     64                       :defaults (asdf:apply-output-translations source)
     65                       :type "abcl"))
     66                     (output-entry
     67                      (make-pathname :defaults source-entry
     68                                     :type "abcl")))
     69                 (when *debug*
     70                   (format verbose "~&~A~& => ~A" output output-entry))
     71                 (setf (gethash output mapping)
    5872                       output-entry)))))
    59       (system:zip package-jar mapping)))
     73    (system:zip package-jar mapping)))
    6074
    61 ;;; This more Map than Walk at this point ...
    62 (defun mapwalk (system test-if callable)
    63   "Apply CALLABLE to all components of asdf SYSTEM which satisfy TEST-IF.
     75(defun all-files (component)
     76  (loop :for c
     77     :being :each :hash-value :of (slot-value component 'asdf::components-by-name)
     78     :when (typep c 'asdf:module)
     79     :append (all-files c)
     80     :when (typep c 'asdf:source-file)
     81     :append (list c)))
    6482
    65 Both CALLABLE and TEST-IF are functions taking an asdf:component as their argument."
    66   (declare (type system asdf:system))
    67   (loop
    68      :for component :being :each :hash-value
    69      :of (slot-value system 'asdf::components-by-name)
    70      :when
    71        (funcall test-if component)
    72      :collect
    73        (funcall callable component)))
     83(defun dependent-systems (system)
     84  (when (not (typep system 'asdf:system))
     85             (setf system (asdf:find-system system)))
     86  (let* ((dependencies (asdf::component-load-dependencies system))
     87         (sub-depends
     88          (loop :for dependency :in dependencies
     89             :for sub = (dependent-systems dependency)
     90             :when sub :append sub)))
     91    (remove-duplicates `(,@dependencies ,@sub-depends))))
    7492
    7593(defun relative-path (base dir file)
Note: See TracChangeset for help on using the changeset viewer.