component.lisp 16.8 KB
Newer Older
1
2
3
;;;; -------------------------------------------------------------------------
;;;; Components

4
(uiop/package:define-package :asdf/component
5
  (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade)
7
8
9
10
  (:export
   #:component #:component-find-path
   #:component-name #:component-pathname #:component-relative-pathname
   #:component-parent #:component-system #:component-parent-pathname
11
12
   #:child-component #:parent-component #:module
   #:file-component
13
14
   #:source-file #:c-source-file #:java-source-file
   #:static-file #:doc-file #:html-file
15
16
   #:file-type
   #:source-file-type #:source-file-explicit-type ;; backward-compatibility
17
   #:component-in-order-to #:component-sideway-dependencies
18
19
20
21
22
23
   #:component-if-feature #:around-compile-hook
   #:component-description #:component-long-description
   #:component-version #:version-satisfies
   #:component-inline-methods ;; backward-compatibility only. DO NOT USE!
   #:component-operation-times ;; For internal use only.
   ;; portable ASDF encoding and implementation-specific external-format
24
   #:component-external-format #:component-encoding
25
26
27
28
   #:component-children-by-name #:component-children #:compute-children-by-name
   #:component-build-operation
   #:module-default-component-class
   #:module-components ;; backward-compatibility. DO NOT USE.
29
   #:sub-components
30

31
32
33
34
   ;; conditions
   #:system-definition-error ;; top level, moved here because this is the earliest place for it.
   #:duplicate-names

35
36
   ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes
   #:name #:version #:description #:long-description #:author #:maintainer #:licence
37
38
39
   #:components-by-name #:components #:children #:children-by-name
   #:default-component-class #:source-file
   #:defsystem-depends-on ; This symbol retained for backward compatibility.
40
   #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
41
   #:relative-pathname #:absolute-pathname #:operation-times #:around-compile
42
   #:%encoding #:properties #:component-properties #:parent))
43
44
(in-package :asdf/component)

45
46
47
48
(with-upgradability ()
  (defgeneric component-name (component)
    (:documentation "Name of the COMPONENT, unique relative to its parent"))
  (defgeneric component-system (component)
49
    (:documentation "Top-level system containing the COMPONENT"))
50
  (defgeneric component-pathname (component)
51
    (:documentation "Pathname of the COMPONENT if any, or NIL."))
52
  (defgeneric component-relative-pathname (component)
53
    ;; in ASDF4, rename that to component-specified-pathname ?
54
55
56
57
    (:documentation "Specified pathname of the COMPONENT,
intended to be merged with the pathname of that component's parent if any, using merged-pathnames*.
Despite the function's name, the return value can be an absolute pathname, in which case the merge
will leave it unmodified."))
58
59
60
61
62
63
64
  (defgeneric component-external-format (component)
    (:documentation "The external-format of the COMPONENT.
By default, deduced from the COMPONENT-ENCODING."))
  (defgeneric component-encoding (component)
    (:documentation "The encoding of the COMPONENT. By default, only :utf-8 is supported.
Use asdf-encodings to support more encodings."))
  (defgeneric version-satisfies (component version)
65
66
    (:documentation "Check whether a COMPONENT satisfies the constraint of being at least as recent
as the specified VERSION, which must be a string of dot-separated natural numbers, or NIL."))
67
68
  (defgeneric component-version (component)
    (:documentation "Return the version of a COMPONENT, which must be a string of dot-separated
69
natural numbers, or NIL."))
70
71
  (defgeneric (setf component-version) (new-version component)
    (:documentation "Updates the version of a COMPONENT, which must be a string of dot-separated
72
natural numbers, or NIL."))
73
74
75
76
  (defgeneric component-parent (component)
    (:documentation "The parent of a child COMPONENT,
or NIL for top-level components (a.k.a. systems)"))
  ;; NIL is a designator for the absence of a component, in which case the parent is also absent.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
77
  (defmethod component-parent ((component null)) nil)
78

79
  ;; Deprecated: Backward compatible way of computing the FILE-TYPE of a component.
80
  ;; TODO: find users, have them stop using that, remove it for ASDF4.
81
  (defgeneric source-file-type (component system)
82
    (:documentation "DEPRECATED. Use the FILE-TYPE of a COMPONENT instead."))
83
84
85
86
87
88
89
90

  (define-condition system-definition-error (error) ()
    ;; [this use of :report should be redundant, but unfortunately it's not.
    ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    ;; over print-object; this is always conditions::%print-condition for
    ;; condition objects, which in turn does inheritance of :report options at
    ;; run-time.  fortunately, inheritance means we only need this kludge here in
    ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
91
    #+cmucl (:report print-object))
92
93
94
95
96
97
98
99

  (define-condition duplicate-names (system-definition-error)
    ((name :initarg :name :reader duplicate-names-name))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
                       (duplicate-names-name c))))))


100
101
102
103
104
105
106
107
108
109
(with-upgradability ()
  (defclass component ()
    ((name :accessor component-name :initarg :name :type string :documentation
           "Component name: designator for a string composed of portable pathname characters")
     ;; We might want to constrain version with
     ;; :type (and string (satisfies parse-version))
     ;; but we cannot until we fix all systems that don't use it correctly!
     (version :accessor component-version :initarg :version :initform nil)
     (description :accessor component-description :initarg :description :initform nil)
     (long-description :accessor component-long-description :initarg :long-description :initform nil)
110
     (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
     (if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
     ;; In the ASDF object model, dependencies exist between *actions*,
     ;; where an action is a pair of an operation and a component.
     ;; Dependencies are represented as alists of operations
     ;; to a list where each entry is a pair of an operation and a list of component specifiers.
     ;; Up until ASDF 2.26.9, there used to be two kinds of dependencies:
     ;; in-order-to and do-first, each stored in its own slot. Now there is only in-order-to.
     ;; in-order-to used to represent things that modify the filesystem (such as compiling a fasl)
     ;; and do-first things that modify the current image (such as loading a fasl).
     ;; These are now unified because we now correctly propagate timestamps between dependencies.
     ;; Happily, no one seems to have used do-first too much (especially since until ASDF 2.017,
     ;; anything you specified was overridden by ASDF itself anyway), but the name in-order-to remains.
     ;; The names are bad, but they have been the official API since Dan Barlow's ASDF 1.52!
     ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
     ;; Maybe rename the slots in ASDF? But that's not very backward-compatible.
     ;; See our ASDF 2 paper for more complete explanations.
     (in-order-to :initform nil :initarg :in-order-to
                  :accessor component-in-order-to)
129
130
131
     ;; Methods defined using the "inline" style inside a defsystem form:
     ;; we store them here so we can delete them when the system is re-evaluated.
     (inline-methods :accessor component-inline-methods :initform nil)
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
     ;; ASDF4: rename it from relative-pathname to specified-pathname. It need not be relative.
     ;; There is no initform and no direct accessor for this specified pathname,
     ;; so we only access the information through appropriate methods, after it has been processed.
     ;; Unhappily, some braindead systems directly access the slot. Make them stop before ASDF4.
     (relative-pathname :initarg :pathname)
     ;; The absolute-pathname is computed based on relative-pathname and parent pathname.
     ;; The slot is but a cache used by component-pathname.
     (absolute-pathname)
     (operation-times :initform (make-hash-table)
                      :accessor component-operation-times)
     (around-compile :initarg :around-compile)
     ;; Properties are for backward-compatibility with ASDF2 only. DO NOT USE!
     (properties :accessor component-properties :initarg :properties
                 :initform nil)
     (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
     ;; For backward-compatibility, this slot is part of component rather than of child-component. ASDF4: stop it.
     (parent :initarg :parent :initform nil :reader component-parent)
     (build-operation
150
151
      :initarg :build-operation :initform nil :reader component-build-operation))
    (:documentation "Base class for all components of a build"))
152
153

  (defun component-find-path (component)
154
    "Return a path from a root system to the COMPONENT.
155
The return value is a list of component NAMES; a list of strings."
156
157
158
159
160
161
162
163
164
165
166
167
168
    (check-type component (or null component))
    (reverse
     (loop :for c = component :then (component-parent c)
           :while c :collect (component-name c))))

  (defmethod print-object ((c component) stream)
    (print-unreadable-object (c stream :type t :identity nil)
      (format stream "~{~S~^ ~}" (component-find-path c))))

  (defmethod component-system ((component component))
    (if-let (system (component-parent component))
      (component-system system)
      component)))
169
170


171
172
;;;; Component hierarchy within a system
;; The tree typically but not necessarily follows the filesystem hierarchy.
173
(with-upgradability ()
174
  (defclass child-component (component) ()
175
    (:documentation "A CHILD-COMPONENT is a COMPONENT that may be part of
176
a PARENT-COMPONENT."))
177
178

  (defclass file-component (child-component)
179
180
    ((type :accessor file-type :initarg :type)) ; no default
    (:documentation "a COMPONENT that represents a file"))
181
  (defclass source-file (file-component)
182
183
    ((type :accessor source-file-explicit-type ;; backward-compatibility
           :initform nil))) ;; NB: many systems have come to rely on this default.
184
185
186
187
188
  (defclass c-source-file (source-file)
    ((type :initform "c")))
  (defclass java-source-file (source-file)
    ((type :initform "java")))
  (defclass static-file (source-file)
189
    ((type :initform nil))
190
    (:documentation "Component for a file to be included as is in the build output"))
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
  (defclass doc-file (static-file) ())
  (defclass html-file (doc-file)
    ((type :initform "html")))

  (defclass parent-component (component)
    ((children
      :initform nil
      :initarg :components
      :reader module-components ; backward-compatibility
      :accessor component-children)
     (children-by-name
      :reader module-components-by-name ; backward-compatibility
      :accessor component-children-by-name)
     (default-component-class
      :initform nil
      :initarg :default-component-class
207
      :accessor module-default-component-class))
208
  (:documentation "A PARENT-COMPONENT is a component that may have children.")))
209
210

(with-upgradability ()
211
212
213
214
  ;; (Private) Function that given a PARENT component,
  ;; the list of children of which has been initialized,
  ;; compute the hash-table in slot children-by-name that allows to retrieve its children by name.
  ;; If ONLY-IF-NEEDED-P is defined, skip any (re)computation if the slot is already populated.
215
  (defun compute-children-by-name (parent &key only-if-needed-p)
216
217
218
219
220
221
222
223
224
225
    (unless (and only-if-needed-p (slot-boundp parent 'children-by-name))
      (let ((hash (make-hash-table :test 'equal)))
        (setf (component-children-by-name parent) hash)
        (loop :for c :in (component-children parent)
              :for name = (component-name c)
              :for previous = (gethash name hash)
              :do (when previous (error 'duplicate-names :name name))
                  (setf (gethash name hash) c))
        hash))))

226
227
(with-upgradability ()
  (defclass module (child-component parent-component)
228
229
230
    (#+clisp (components)) ;; backward compatibility during upgrade only
    (:documentation "A module is a intermediate component with both a parent and children,
typically but not necessarily representing the files in a subdirectory of the build source.")))
231
232


233
;;;; component pathnames
234
(with-upgradability ()
235
  (defgeneric component-parent-pathname (component)
236
    (:documentation "The pathname of the COMPONENT's parent, if any, or NIL"))
237
238
239
  (defmethod component-parent-pathname (component)
    (component-pathname (component-parent component)))

240
241
242
243
  ;; The default method for component-pathname tries to extract a cached precomputed
  ;; absolute-pathname from the relevant slot, and if not, computes it by merging the
  ;; component-relative-pathname (which should be component-specified-pathname, it can be absolute)
  ;; with the directory of the component-parent-pathname.
244
245
246
247
248
249
250
251
252
253
254
255
256
  (defmethod component-pathname ((component component))
    (if (slot-boundp component 'absolute-pathname)
        (slot-value component 'absolute-pathname)
        (let ((pathname
                (merge-pathnames*
                 (component-relative-pathname component)
                 (pathname-directory-pathname (component-parent-pathname component)))))
          (unless (or (null pathname) (absolute-pathname-p pathname))
            (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
                   pathname (component-find-path component)))
          (setf (slot-value component 'absolute-pathname) pathname)
          pathname)))

257
258
259
  ;; Default method for component-relative-pathname:
  ;; combine the contents of slot relative-pathname (from specified initarg :pathname)
  ;; with the appropriate source-file-type, which defaults to the file-type of the component.
260
  (defmethod component-relative-pathname ((component component))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
261
    ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1.
262
263
    ;; We ought to be able to extract this from the component alone with FILE-TYPE.
    ;; TODO: track who uses it in Quicklisp, and have them not use it anymore;
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
264
    ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge?
265
266
267
268
269
270
271
272
    (parse-unix-namestring
     (or (and (slot-boundp component 'relative-pathname)
              (slot-value component 'relative-pathname))
         (component-name component))
     :want-relative t
     :type (source-file-type component (component-system component))
     :defaults (component-parent-pathname component)))

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
273
  (defmethod source-file-type ((component parent-component) (system parent-component))
274
275
    :directory)

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
276
  (defmethod source-file-type ((component file-component) (system parent-component))
277
    (file-type component)))
278

279
280

;;;; Encodings
281
282
283
284
285
(with-upgradability ()
  (defmethod component-encoding ((c component))
    (or (loop :for x = c :then (component-parent x)
              :while x :thereis (%component-encoding x))
        (detect-encoding (component-pathname c))))
286

287
288
  (defmethod component-external-format ((c component))
    (encoding-external-format (component-encoding c))))
289
290
291


;;;; around-compile-hook
292
(with-upgradability ()
293
  (defgeneric around-compile-hook (component)
294
295
296
297
    (:documentation "An optional hook function that will be called with one argument, a thunk.
The hook function must call the thunk, that will compile code from the component, and may or may not
also evaluate the compiled results. The hook function may establish dynamic variable bindings around
this compilation, or check its results, etc."))
298
299
300
301
302
303
  (defmethod around-compile-hook ((c component))
    (cond
      ((slot-boundp c 'around-compile)
       (slot-value c 'around-compile))
      ((component-parent c)
       (around-compile-hook (component-parent c))))))
304
305
306


;;;; version-satisfies
307
(with-upgradability ()
308
  ;; short-circuit testing of null version specifications.
309
  ;; this is an all-pass, without warning
310
311
  (defmethod version-satisfies :around ((c t) (version null))
    t)
312
  (defmethod version-satisfies ((c component) version)
313
    (unless (and version (slot-boundp c 'version) (component-version c))
314
      (when version
315
        (warn "Requested version ~S but ~S has no version" version c))
316
      (return-from version-satisfies nil))
317
    (version-satisfies (component-version c) version))
318

319
  (defmethod version-satisfies ((cver string) version)
320
    (version<= version cver)))
321
322
323


;;; all sub-components (of a given type)
324
325
(with-upgradability ()
  (defun sub-components (component &key (type t))
326
    "Compute the transitive sub-components of given COMPONENT that are of given TYPE"
327
328
329
330
331
332
333
334
    (while-collecting (c)
      (labels ((recurse (x)
                 (when (if-let (it (component-if-feature x)) (featurep it) t)
                   (when (typep x type)
                     (c x))
                   (when (typep x 'parent-component)
                     (map () #'recurse (component-children x))))))
        (recurse component)))))
335