find-component.lisp 6.92 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;;; Finding components

4
(uiop/package:define-package :asdf/find-component
5
  (:recycle :asdf/find-component :asdf/find-system :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session
7
   :asdf/component :asdf/system :asdf/system-registry)
8 9 10 11 12
  (:export
   #:find-component
   #:resolve-dependency-name #:resolve-dependency-spec
   #:resolve-dependency-combination
   ;; Conditions
13
   #:missing-component #:missing-requires #:missing-parent #:missing-component-of-version #:retry
14 15
   #:missing-dependency #:missing-dependency-of-version
   #:missing-requires #:missing-parent
16
   #:missing-required-by #:missing-version))
17 18 19 20
(in-package :asdf/find-component)

;;;; Missing component conditions

21
(with-upgradability ()
22 23 24 25
  (define-condition missing-component (system-definition-error)
    ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
     (parent :initform nil :reader missing-parent :initarg :parent)))

26 27
  (define-condition missing-component-of-version (missing-component)
    ((version :initform nil :reader missing-version :initarg :version)))
28

29 30
  (define-condition missing-dependency (missing-component)
    ((required-by :initarg :required-by :reader missing-required-by)))
31

32 33 34
  (defmethod print-object ((c missing-dependency) s)
    (format s (compatfmt "~@<~A, required by ~A~@:>")
            (call-next-method c nil) (missing-required-by c)))
35

36 37 38
  (define-condition missing-dependency-of-version (missing-dependency
                                                   missing-component-of-version)
    ())
39

40 41 42 43 44
  (defmethod print-object ((c missing-component) s)
    (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
            (missing-requires c)
            (when (missing-parent c)
              (coerce-name (missing-parent c)))))
45

46 47 48 49 50 51
  (defmethod print-object ((c missing-component-of-version) s)
    (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
            (missing-requires c)
            (missing-version c)
            (when (missing-parent c)
              (coerce-name (missing-parent c))))))
52 53 54 55


;;;; Finding components

56
(with-upgradability ()
57
  (defgeneric resolve-dependency-combination (component combinator arguments)
58 59
    (:documentation "Return a component satisfying the dependency specification (COMBINATOR . ARGUMENTS)
in the context of COMPONENT"))
60

61 62 63
  ;; Methods for find-component

  ;; If the base component is a string, resolve it as a system, then if not nil follow the path.
64 65 66 67 68
  (defmethod find-component ((base string) path &key registered)
    (if-let ((s (if registered
                    (registered-system base)
                    (find-system base nil))))
      (find-component s path :registered registered)))
69

70 71
  ;; If the base component is a symbol, coerce it to a name if not nil, and resolve that.
  ;; If nil, use the path as base if not nil, or else return nil.
72
  (defmethod find-component ((base symbol) path &key registered)
73
    (cond
74 75
      (base (find-component (coerce-name base) path :registered registered))
      (path (find-component path nil :registered registered))
76 77
      (t    nil)))

78
  ;; If the base component is a cons cell, resolve its car, and add its cdr to the path.
79 80
  (defmethod find-component ((base cons) path &key registered)
    (find-component (car base) (cons (cdr base) path) :registered registered))
81

82
  ;; If the base component is a parent-component and the path a string, find the named child.
83 84 85
  (defmethod find-component ((parent parent-component) (name string) &key registered)
    (declare (ignorable registered))
    (compute-children-by-name parent :only-if-needed-p t)
86 87
    (values (gethash name (component-children-by-name parent))))

88
  ;; If the path is a symbol, coerce it to a name if non-nil, or else just return the base.
89
  (defmethod find-component (base (name symbol) &key registered)
90
    (if name
91
        (find-component base (coerce-name name) :registered registered)
92 93
        base))

94
  ;; If the path is a cons, first resolve its car as path, then its cdr.
95 96 97
  (defmethod find-component ((c component) (name cons) &key registered)
    (find-component (find-component c (car name) :registered registered)
                    (cdr name) :registered registered))
98

99
  ;; If the path is a component, return it, disregarding the base.
100 101
  (defmethod find-component ((base t) (actual component) &key registered)
    (declare (ignorable registered))
102 103
    actual)

104 105
  ;; Resolve dependency NAME in the context of a COMPONENT, with given optional VERSION constraint.
  ;; This (private) function is used below by RESOLVE-DEPENDENCY-SPEC and by the :VERSION spec.
106 107 108 109 110 111 112
  (defun resolve-dependency-name (component name &optional version)
    (loop
      (restart-case
          (return
            (let ((comp (find-component (component-parent component) name)))
              (unless comp
                (error 'missing-dependency
113
                       :required-by component
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
                       :requires name))
              (when version
                (unless (version-satisfies comp version)
                  (error 'missing-dependency-of-version
                         :required-by component
                         :version version
                         :requires name)))
              comp))
        (retry ()
          :report (lambda (s)
                    (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
          :test
          (lambda (c)
            (or (null c)
                (and (typep c 'missing-dependency)
                     (eq (missing-required-by c) component)
130
                     (equal (missing-requires c) name))))
131 132
          (unless (component-parent component)
            (let ((name (coerce-name name)))
133
              (unset-asdf-cache-entry `(find-system ,name))))))))
134

135 136 137
  ;; Resolve dependency specification DEP-SPEC in the context of COMPONENT.
  ;; This is notably used by MAP-DIRECT-DEPENDENCIES to process the results of COMPONENT-DEPENDS-ON
  ;; and by PARSE-DEFSYSTEM to process DEFSYSTEM-DEPENDS-ON.
138 139 140 141 142 143
  (defun resolve-dependency-spec (component dep-spec)
    (let ((component (find-component () component)))
      (if (atom dep-spec)
          (resolve-dependency-name component dep-spec)
          (resolve-dependency-combination component (car dep-spec) (cdr dep-spec)))))

144
  ;; Methods for RESOLVE-DEPENDENCY-COMBINATION to parse lists as dependency specifications.
145
  (defmethod resolve-dependency-combination (component combinator arguments)
146 147
    (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S~@:>")
                     'resolve-dependency-combination (cons combinator arguments) component))
148 149 150 151 152 153

  (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
    (when (featurep (first arguments))
      (resolve-dependency-spec component (second arguments))))

  (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
154
    (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788
155