Changeset 14717


Ignore:
Timestamp:
08/17/14 17:55:43 (7 years ago)
Author:
Mark Evenson
Message:

Fix #364: ASDF-JAR:PACKAGE breaks with simple usage.

Thanks to Eduardo Bellani.

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

File:
1 edited

Legend:

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

    r14695 r14717  
    1313
    1414(defvar *debug* nil)
     15
     16(defun add-system-files-to-mapping! (system
     17                                     mapping
     18                                     system-base
     19                                     system-name
     20                                     &optional root verbose)
     21  "Auxiliary procedure that adds all the files of a SYSTEM to the
     22MAPPING with a given SYSTEM-BASE and SYSTEM-NAME. The whole idea of
     23this procedure is to modify MAPPING, so a NIL is returned."
     24  (let ((abcl-file-type "abcl"))
     25    (loop :for component :in (all-files system)
     26       :for source = (slot-value component 'asdf::absolute-pathname)
     27       :for source-entry = (archive-relative-path system-base system-name source)
     28       :do (setf (gethash source mapping)
     29                 (if root
     30                     (merge-pathnames source-entry (make-pathname :directory root))
     31                     source-entry))
     32       :do (format verbose "~&~A~& => ~A" source source-entry)
     33       :when (and (typep component 'asdf::source-file)
     34                  (not (typep component 'asdf::static-file)))
     35       :do (let ((output
     36                  (make-pathname
     37                   :defaults (asdf:apply-output-translations source)
     38                   :type abcl-file-type))
     39                 (output-entry
     40                  (make-pathname :defaults source-entry
     41                                 :type abcl-file-type
     42                                 :directory
     43                                 (append root
     44                                         (cadr (pathname-directory source-entry))))))
     45             (format verbose "~&~A~& => ~A" output output-entry)
     46             (setf (gethash output mapping)
     47                   output-entry)))))
     48
     49(defun systems->hash-table (systems &optional root verbose)
     50  "Auxiliary function that, given a list of SYSTEMS, builds a hash
     51table mapping absolute file names to of these systems into relative
     52path names. This mapping will be used to zip the files of the system
     53into a JAR file."
     54  (let ((mapping (make-hash-table :test 'equal)))
     55    (dolist (system systems)
     56      (let ((base (slot-value system 'asdf::absolute-pathname))
     57            (name (slot-value system 'asdf::name))
     58            (asdf (slot-value system 'asdf::source-file)))
     59        (setf (gethash asdf mapping)
     60              (let ((relative-path (archive-relative-path base name asdf)))
     61                (if root
     62                    (merge-pathnames
     63                     relative-path
     64                     (make-pathname :directory root))
     65                    relative-path)))
     66        (add-system-files-to-mapping! system mapping base name root verbose)))
     67    mapping))
    1568
    1669(defun package (system &key
     
    2881
    2982If FORCE is true, force asdf to recompile all the necessary fasls.
     83
     84VERBOSE controls how many messages will be logged to
     85*standard-output*.
     86
     87ROOT controls if the relative pathnames will be appended to something
     88before being added to the mapping. The purpose of having this option
     89is to add the paths to an internal directory, such as (list :relative
     90\"META-INF\" \"resources\") for generating WAR files.
    3091
    3192Returns the pathname of the packaged jar archive.
     
    39100                      v)))
    40101         (package-jar-name
    41           (format nil "~A~A~A" name (if recursive "-all" "") (if version
    42                                                                  (format nil "-~A" version)
    43                                                                  "")))
     102          (format nil "~A~A~A" name (if recursive "-all" "")
     103                  (if version
     104                      (format nil "-~A" version)
     105                      "")))
    44106         (package-jar
    45107          (make-pathname :name package-jar-name
    46108                         :type "jar"
    47                          :defaults out))
    48          (mapping (make-hash-table :test 'equal))
    49          (dependencies (dependent-systems system)))
     109                         :defaults out)))
    50110    (when verbose
    51111      (format verbose "~&Packaging ASDF definition of ~A" system))
     
    55115    (when verbose
    56116      (format verbose "~&Packaging contents in ~A" package-jar))
    57     (when (and verbose recursive dependencies)
    58       (format verbose "~&  with recursive dependencies~{ ~A~^, ~}." dependencies))
    59     (dolist (system (append (list system)
    60                             (when recursive
    61                               (mapcar #'asdf:find-system dependencies))))
    62       (let ((base (slot-value system 'asdf::absolute-pathname))
    63             (name (slot-value system 'asdf::name))
    64             (asdf (slot-value system 'asdf::source-file)))
    65         (setf (gethash asdf mapping) (let ((relative-path (archive-relative-path
    66                                                            base name asdf)))
    67                                        (if root
    68                                          (merge-pathnames
    69                                           relative-path
    70                                           (make-pathname :directory root))
    71                                          relative-path)))
    72         (loop :for component :in (all-files system)
    73            :for source = (slot-value component 'asdf::absolute-pathname)
    74            :for source-entry = (archive-relative-path base name source)
    75            :do (setf (gethash source mapping)
    76                      (if root
    77                          (merge-pathnames source-entry (make-pathname :directory root))
    78                          source-entry))
    79            :do (when *debug*
    80                  (format verbose "~&~A~& => ~A" source source-entry))
    81            :when (and (typep component 'asdf::source-file)
    82                       (not (typep component 'asdf::static-file)))
    83            :do (let ((output
    84                       (make-pathname
    85                        :defaults (asdf:apply-output-translations source)
    86                        :type "abcl"))
    87                      (output-entry
    88                       (make-pathname :defaults source-entry
    89                                      :type "abcl"
    90                                      :directory (append root
    91                                                         (rest (pathname-directory source-entry))))))
    92                  (when *debug*
    93                    (format verbose "~&~A~& => ~A" output output-entry))
    94                  (setf (gethash output mapping)
    95                        output-entry)))))
    96     (system:zip package-jar mapping)))
     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))))
    97129
    98130(defun all-files (component)
Note: See TracChangeset for help on using the changeset viewer.