;;;; ------------------------------------------------------------------------- ;;;; 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 #:missing-required-by #:missing-version)) (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 "~@") (missing-requires c) (when (missing-parent c) (coerce-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) (format s (compatfmt "~@") (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 "~@") 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 "~@") (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)))