Newer
Older
;;;; -------------------------------------------------------------------------
;;;; Finding components
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/find-component
(:recycle :asdf/find-component :asdf)
(:use :common-lisp :asdf/driver :asdf/upgrade :asdf/component :asdf/system :asdf/find-system)
(:export
#:find-component
#:resolve-dependency-name #:resolve-dependency-spec
#:resolve-dependency-combination
;; Conditions
#:missing-component #:missing-component-of-version #:retry
#:missing-dependency #:missing-dependency-of-version
#:missing-requires #:missing-parent
Francois-Rene Rideau
committed
#:missing-required-by #:missing-version))
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
(in-package :asdf/find-component)
;;;; Missing component conditions
(define-condition missing-component-of-version (missing-component)
((version :initform nil :reader missing-version :initarg :version)))
(define-condition missing-dependency (missing-component)
((required-by :initarg :required-by :reader missing-required-by)))
(defmethod print-object ((c missing-dependency) s)
(format s (compatfmt "~@<~A, required by ~A~@:>")
(call-next-method c nil) (missing-required-by c)))
(define-condition missing-dependency-of-version (missing-dependency
missing-component-of-version)
())
(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)))))
(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)))))
;;;; Finding components
Francois-Rene Rideau
committed
(defgeneric* (find-component) (base path)
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
(:documentation "Find a component by resolving the PATH starting from BASE parent"))
(defgeneric* resolve-dependency-combination (component combinator arguments))
(defmethod find-component ((base string) path)
(let ((s (find-system base nil)))
(and s (find-component s path))))
(defmethod find-component ((base symbol) path)
(cond
(base (find-component (coerce-name base) path))
(path (find-component path nil))
(t nil)))
(defmethod find-component ((base cons) path)
(find-component (car base) (cons (cdr base) path)))
(defmethod find-component ((parent parent-component) (name string))
(compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!!
(values (gethash name (component-children-by-name parent))))
(defmethod find-component (base (name symbol))
(if name
(find-component base (coerce-name name))
base))
(defmethod find-component ((c component) (name cons))
(find-component (find-component c (car name)) (cdr name)))
(defmethod find-component (base (actual component))
(declare (ignorable base))
actual)
(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
:required-by component
: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)
(equal (missing-requires c) name))))))))
(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)))))
(defmethod resolve-dependency-combination (component combinator arguments)
(error (compatfmt "~@<Bad dependency ~S for ~S~@:>")
(cons combinator arguments) component))
(defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments)
(declare (ignorable combinator))
(when (featurep (first arguments))
(resolve-dependency-spec component (second arguments))))
(defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments)
(declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788
(resolve-dependency-name component (first arguments) (second arguments)))