Skip to content
find-component.lisp 4.7 KiB
Newer Older
;;;; -------------------------------------------------------------------------
;;;; Finding components

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

(defgeneric* find-component (base path)
  (: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)
  (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)))