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

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 @@ ...@@ -50,36 +50,41 @@
;;;; Finding components ;;;; Finding components
(with-upgradability () (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")) (:documentation "Find a component by resolving the PATH starting from BASE parent"))
(defgeneric resolve-dependency-combination (component combinator arguments)) (defgeneric resolve-dependency-combination (component combinator arguments))
(defmethod find-component ((base string) path) (defmethod find-component ((base string) path &key registered)
(let ((s (find-system base nil))) (if-let ((s (if registered
(and s (find-component s path)))) (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)
(cond (cond
(base (find-component (coerce-name base) path)) (base (find-component (coerce-name base) path :registered registered))
(path (find-component path nil)) (path (find-component path nil :registered registered))
(t nil))) (t nil)))
(defmethod find-component ((base cons) path) (defmethod find-component ((base cons) path &key registered)
(find-component (car base) (cons (cdr base) path))) (find-component (car base) (cons (cdr base) path) :registered registered))
(defmethod find-component ((parent parent-component) (name string)) (defmethod find-component ((parent parent-component) (name string) &key registered)
(compute-children-by-name parent :only-if-needed-p t) ;; SBCL may miss the u-i-f-r-c method!!! (declare (ignorable registered))
(compute-children-by-name parent :only-if-needed-p t)
(values (gethash name (component-children-by-name parent)))) (values (gethash name (component-children-by-name parent))))
(defmethod find-component (base (name symbol)) (defmethod find-component (base (name symbol) &key registered)
(if name (if name
(find-component base (coerce-name name)) (find-component base (coerce-name name) :registered registered)
base)) base))
(defmethod find-component ((c component) (name cons)) (defmethod find-component ((c component) (name cons) &key registered)
(find-component (find-component c (car name)) (cdr name))) (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))
actual) actual)
(defun resolve-dependency-name (component name &optional version) (defun resolve-dependency-name (component name &optional version)
......
...@@ -167,7 +167,8 @@ to load it in current image." ...@@ -167,7 +167,8 @@ to load it in current image."
(defun component-loaded-p (component) (defun component-loaded-p (component)
"Has given COMPONENT been successfully loaded in the current image (yet)? "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." 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 () (defun already-loaded-systems ()
"return a list of the names of the systems that have been successfully loaded so far" "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." ...@@ -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) (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 "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." 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, ;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
......
...@@ -87,19 +87,17 @@ ...@@ -87,19 +87,17 @@
(setf test-package::*file3* :reset) (setf test-package::*file3* :reset)
(DBG "Check that require-system of touched .asd will reload the asdf.") (DBG "Check that require-system called with touched .asd won't reload the asdf.")
(DBG "(That's what it does now, but if it could be fixed that'd be nice.)")
(unset-asdf-cache-entry '(find-system "test-asdf")) (unset-asdf-cache-entry '(find-system "test-asdf"))
(unset-asdf-cache-entry '(find-system "test-asdf/force")) (unset-asdf-cache-entry '(find-system "test-asdf/force"))
(touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1))) (touch-file "test-asdf.asd" :timestamp (+ 10000 (get-file-stamp file1)))
(require-system 'test-asdf/force) (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) (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) (require-system 'test-asdf/force)
;;; Somehow, it loads the system... ;;; Somehow, it loads the system...
(with-expected-failure (t) (assert-equal (asymval :*times-loaded* :test-asdf-system) 1)
(assert-equal (asymval :*times-loaded* :test-asdf-system) 2) (assert-equal test-package::*file3* :reset)
(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