Changeset 14720


Ignore:
Timestamp:
08/17/14 19:32:05 (7 years ago)
Author:
Mark Evenson
Message:

asdf-jar: Stablize recent fixes across more cases. (Eduardo Bellani)

<http://abcl.org/trac/ticket/364>

File:
1 edited

Legend:

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

    r14717 r14720  
    6767    mapping))
    6868
     69(defun add-system-files-to-mapping! (system
     70                                     mapping
     71                                     system-base
     72                                     system-name
     73                                     &optional root verbose)
     74  "Auxiliary procedure that adds all the files of a SYSTEM to the
     75MAPPING with a given SYSTEM-BASE and SYSTEM-NAME. The whole idea of
     76this procedure is to modify MAPPING, so a NIL is returned."
     77  (let ((abcl-file-type "abcl"))
     78    (loop :for component :in (all-files system)
     79       :for source = (slot-value component 'asdf::absolute-pathname)
     80       :for source-entry = (archive-relative-path system-base system-name source)
     81       :do (setf (gethash source mapping)
     82                 (if root
     83                     (merge-pathnames source-entry (make-pathname :directory root))
     84                     source-entry))
     85       :do (format verbose "~&~A~& => ~A" source source-entry)
     86       :when (and (typep component 'asdf::source-file)
     87                  (not (typep component 'asdf::static-file)))
     88       :do (let ((output
     89                  (make-pathname
     90                   :defaults (asdf:apply-output-translations source)
     91                   :type abcl-file-type))
     92                 (output-entry
     93                  (make-pathname :defaults source-entry
     94                                 :type abcl-file-type
     95                                 :directory
     96                                 (append root
     97                                         (cadr (pathname-directory source-entry))))))
     98             (format verbose "~&~A~& => ~A" output output-entry)
     99             (setf (gethash output mapping)
     100                   output-entry)))))
     101
     102(defun systems->hash-table (systems &optional root verbose)
     103  "Auxiliary function that, given a list of SYSTEMS, builds a hash
     104table mapping absolute file names to of these systems into relative
     105path names. This mapping will be used to zip the files of the system
     106into a JAR file."
     107  (let ((mapping (make-hash-table :test 'equal)))
     108    (dolist (system systems)
     109      (let ((base (slot-value system 'asdf::absolute-pathname))
     110            (name (slot-value system 'asdf::name))
     111            (asdf (slot-value system 'asdf::source-file)))
     112        (setf (gethash asdf mapping)
     113              (let ((relative-path (archive-relative-path base name asdf)))
     114                (if root
     115                    (merge-pathnames
     116                     relative-path
     117                     (make-pathname :directory root))
     118                    relative-path)))
     119        (add-system-files-to-mapping! system mapping base name root verbose)))
     120    mapping))
     121
    69122(defun package (system &key
    70123                         (out #p"/var/tmp/")
    71124                         (recursive t)          ; whether to package dependencies
    72125                         (force nil)            ; whether to force ASDF compilation
    73                          (root nil)
    74                          (verbose t))
     126                         (root '(:relative))
     127                         (verbose nil))
    75128"Compile and package the asdf SYSTEM in a jar.
    76129
     
    81134
    82135If FORCE is true, force asdf to recompile all the necessary fasls.
     136
     137VERBOSE controls how many messages will be logged to
     138*standard-output*.
     139
     140ROOT controls if the relative pathnames will be appended to something
     141before being added to the mapping. The purpose of having this option
     142is to add the paths to an internal directory, such as (list :relative
     143\"META-INF\" \"resources\") for generating WAR files.
    83144
    84145VERBOSE controls how many messages will be logged to
     
    100161                      v)))
    101162         (package-jar-name
    102           (format nil "~A~A~A" name (if recursive "-all" "")
    103                   (if version
    104                       (format nil "-~A" version)
    105                       "")))
     163           (format nil "~A~A~A" name (if recursive "-all" "")
     164                   (if version
     165                       (format nil "-~A" version)
     166                       "")))
    106167         (package-jar
    107168          (make-pathname :name package-jar-name
     
    115176    (when verbose
    116177      (format verbose "~&Packaging contents in ~A" package-jar))
    117     (system:zip package-jar
    118                 (systems->hash-table
    119                  (append (list system)
    120                          (when recursive
    121                            (let ((dependencies (dependent-systems system)))
    122                              (when (and verbose dependencies)
    123                                (format verbose
    124                                        "~&  with recursive dependencies~{ ~A~^, ~}."
    125                                        dependencies)
    126                                (mapcar #'asdf:find-system dependencies)))))
    127                  root
    128                  verbose))))
     178     (system:zip package-jar
     179                 (systems->hash-table
     180                  (append (list system)
     181                          (when recursive
     182                            (let ((dependencies (dependent-systems system)))
     183                              (when (and verbose dependencies)
     184                                (format verbose
     185                                        "~&  with recursive dependencies~{ ~A~^, ~}."
     186                                        dependencies)
     187                                (mapcar #'asdf:find-system dependencies)))))
     188                  root
     189                  verbose))))
    129190
    130191(defun all-files (component)
Note: See TracChangeset for help on using the changeset viewer.