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

4 5
(asdf/package:define-package :asdf/find-component
  (:recycle :asdf/find-component :asdf)
6
  (:use :common-lisp :asdf/driver :asdf/upgrade :asdf/component :asdf/system :asdf/find-system)
7 8 9 10 11 12 13 14
  (: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
15
   #: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

50
(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)
110 111 112 113
  (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)))))
114 115 116 117 118 119 120 121 122 123 124 125 126 127

(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)))