Commit 7f6e4fac authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Fix component-loaded-p to not load asd files

Add find-component keyword argument registered to not load asd files.
Use it in component-loaded-p so we query what's registered but don't load asds.

Many thanks to Daniel Kochmanski for identifying and helping solve the problem.
parent d33ab0bc
......@@ -50,36 +50,41 @@
;;;; Finding components
(with-upgradability ()
(defgeneric* (find-component) (base path)
(defgeneric* (find-component) (base path &key registered)
(: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 string) path &key registered)
(if-let ((s (if registered
(registered-system base)
(find-system base nil))))
(find-component s path :registered registered)))
(defmethod find-component ((base symbol) path)
(defmethod find-component ((base symbol) path &key registered)
(base (find-component (coerce-name base) path))
(path (find-component path nil))
(base (find-component (coerce-name base) path :registered registered))
(path (find-component path nil :registered registered))
(t nil)))
(defmethod find-component ((base cons) path)
(find-component (car base) (cons (cdr base) path)))
(defmethod find-component ((base cons) path &key registered)
(find-component (car base) (cons (cdr base) path) :registered registered))
(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!!!
(defmethod find-component ((parent parent-component) (name string) &key registered)
(declare (ignorable registered))
(compute-children-by-name parent :only-if-needed-p t)
(values (gethash name (component-children-by-name parent))))
(defmethod find-component (base (name symbol))
(defmethod find-component (base (name symbol) &key registered)
(if name
(find-component base (coerce-name name))
(find-component base (coerce-name name) :registered registered)
(defmethod find-component ((c component) (name cons))
(find-component (find-component c (car name)) (cdr name)))
(defmethod find-component ((c component) (name cons) &key registered)
(find-component (find-component c (car name) :registered registered)
(cdr name) :registered registered))
(defmethod find-component ((base t) (actual component))
(defmethod find-component ((base t) (actual component) &key registered)
(declare (ignorable registered))
(defun resolve-dependency-name (component name &optional version)
......@@ -167,7 +167,8 @@ to load it in current image."
(defun component-loaded-p (component)
"Has given COMPONENT been successfully loaded in the current image (yet)?
Note that this returns true even if the component is not up to date."
(action-already-done-p nil (make-instance 'load-op) (find-component component ())))
(if-let ((component (find-component component () :registered t)))
(action-already-done-p nil (make-instance 'load-op) component)))
(defun already-loaded-systems ()
"return a list of the names of the systems that have been successfully loaded so far"
......@@ -176,7 +177,8 @@ Note that this returns true even if the component is not up to date."
(defun require-system (system &rest keys &key &allow-other-keys)
"Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
system or its dependencies if they have already been loaded."
(apply 'load-system system :force-not (already-loaded-systems) keys)))
(unless (component-loaded-p system)
(apply 'load-system system :force-not (already-loaded-systems) keys))))
;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
......@@ -87,19 +87,17 @@
(setf test-package::*file3* :reset)
(DBG "Check that require-system of touched .asd will reload the asdf.")
(DBG "(That's what it does now, but if it could be fixed that'd be nice.)")
(DBG "Check that require-system called with touched .asd won't reload the asdf.")
(unset-asdf-cache-entry '(find-system "test-asdf"))
(unset-asdf-cache-entry '(find-system "test-asdf/force"))
(touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1)))
(require-system 'test-asdf/force)
(assert-equal (asymval :*times-loaded* :test-asdf-system) 2)
(assert-equal (asymval :*times-loaded* :test-asdf-system) 1)
(assert-equal test-package::*file3* :reset)
(DBG "Check that require-system of untouched .asd won't reload the asdf.")
(DBG "Check that require-system called with untouched .asd won't reload the asdf.")
(require-system 'test-asdf/force)
;;; Somehow, it loads the system...
(with-expected-failure (t)
(assert-equal (asymval :*times-loaded* :test-asdf-system) 2)
(assert-equal test-package::*file3* :reset))
(assert-equal (asymval :*times-loaded* :test-asdf-system) 1)
(assert-equal test-package::*file3* :reset)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment