From b86ab12926bf8afa7581a3cc5fd4304976e05eef Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" <rpgoldman@gmail.com> Date: Wed, 9 Jul 2014 15:20:22 -0500 Subject: [PATCH] Fix for bug where caching mistakenly overrides error flag in FIND-SYSTEM. This required refactoring to move REINITIALIZE-SOURCE-REGISTRY-AND-RESTART to correct location. This shoudl also fix bug13353423, but we still need a better test. --- cache.lisp | 27 ++++++++-- find-system.lisp | 107 +++++++++++++++++++------------------ source-registry.lisp | 1 + test/test-utilities.script | 2 + 4 files changed, 80 insertions(+), 57 deletions(-) diff --git a/cache.lisp b/cache.lisp index 018ce8ad..ec395ad1 100644 --- a/cache.lisp +++ b/cache.lisp @@ -7,7 +7,11 @@ #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* - #:clear-asdf-cache)) + #:clear-asdf-cache + #:reinitialize-source-registry-and-retry + ;; defined in source-registry, but specially mentioned here: + #:initialize-source-registry + )) (in-package :asdf/cache) ;;; This stamp cache is useful for: @@ -16,6 +20,8 @@ ;; * the ability to test with fake timestamps, without touching files (with-upgradability () + (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference + (defvar *asdf-cache* nil) (defun set-asdf-cache-entry (key value-list) @@ -26,7 +32,7 @@ (defun clear-asdf-cache () (when *asdf-cache* - (setf *asdf-cache* (make-hash-table :test 'equal)))) + (setf *asdf-cache* (clrhash *asdf-cache*)))) (defun unset-asdf-cache-entry (key) (when *asdf-cache* @@ -47,8 +53,21 @@ (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (if (and *asdf-cache* (not override)) (funcall fun) - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (funcall fun))))) + (flet ((establish-cache-and-call () + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (funcall fun)))) + (restart-case + (establish-cache-and-call) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@<Retry ASDF operation after reinitializing the source-registry.~@:>"))) + ;; since you're reinitializing the source registry, an arbitrary + ;; amount of the ASDF cache is invalidated, not just the entry + ;; for the current NAME. + (clear-asdf-cache) + ;; (unset-asdf-cache-entry `(locate-system ,name)) + (initialize-source-registry) + (establish-cache-and-call))))))) (defmacro with-asdf-cache ((&key key override) &body body) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) diff --git a/find-system.lisp b/find-system.lisp index c2795b68..a817b305 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -21,13 +21,11 @@ #:clear-defined-system #:clear-defined-systems #:*defined-systems* #:*immutable-systems* ;; defined in source-registry, but specially mentioned here: - #:initialize-source-registry #:sysdef-source-registry-search - #:reinitialize-source-registry-and-retry + #:sysdef-source-registry-search )) (in-package :asdf/find-system) (with-upgradability () - (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) @@ -384,55 +382,58 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (setf found-system found pathname nil)))) (values foundp found-system pathname previous previous-time)))) - (defmethod find-system ((name string) &optional (error-p t)) + (defun find-system-1 (name) (with-asdf-cache (:key `(find-system ,name)) - (let ((primary-name (primary-system-name name))) - (unless (equal name primary-name) - (find-system primary-name nil))) - (loop - (restart-case - (multiple-value-bind (foundp found-system pathname previous previous-time) - (locate-system name) - (when (and found-system (eq found-system previous) - (or (first (gethash `(find-system ,name) *asdf-cache*)) - (and *immutable-systems* (gethash name *immutable-systems*)))) - (return found-system)) - (assert (eq foundp (and (or found-system pathname previous) t))) - (let ((previous-pathname (and previous (system-source-file previous))) - (system (or previous found-system))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and system pathname) - (setf (system-source-file system) pathname)) - (when (and pathname - (let ((stamp (get-file-stamp pathname))) - (and stamp - (not (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content, and not an old asdf - (load-asd pathname :name name))) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed - (return - (cond - (in-memory - (when pathname - (setf (car in-memory) (get-file-stamp pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)))))) - (reinitialize-source-registry-and-retry () - :report (lambda (s) - (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) - ;; since you're reinitializing the source registry, an arbitrary - ;; amount of the ASDF cache is invalidated, not just the entry - ;; for the current NAME. - (clear-asdf-cache) - ;; (unset-asdf-cache-entry `(locate-system ,name)) - (initialize-source-registry) - (find-system name error-p))))))) + (let ((primary-name (primary-system-name name))) + (unless (equal name primary-name) + (find-system primary-name nil))) + (prog () + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (when (and found-system (eq found-system previous) + (or (first (gethash `(find-system ,name) *asdf-cache*)) + (and *immutable-systems* (gethash name *immutable-systems*)))) + (return found-system)) + (assert (eq foundp (and (or found-system pathname previous) t))) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (let ((stamp (get-file-stamp pathname))) + (and stamp + (not (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time)))))) + ;; only load when it's a pathname that is different or has newer content, and not an old asdf + (load-asd pathname :name name))) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (when in-memory + (when pathname + (setf (car in-memory) (get-file-stamp pathname))) + (cdr in-memory)))))))) + (defmethod find-system ((name string) &optional (error-p t)) + (restart-case + (let ((ret (find-system-1 name))) + (cond (ret ret) + (error-p + (error 'missing-component :requires name)) + (t nil))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s (compatfmt "~@<Retry ASDF operation after reinitializing the source-registry.~@:>"))) + ;; since you're reinitializing the source registry, an arbitrary + ;; amount of the ASDF cache is invalidated, not just the entry + ;; for the current NAME. + (clear-asdf-cache) + ;; (unset-asdf-cache-entry `(locate-system ,name)) + (initialize-source-registry) + (find-system name error-p))))) diff --git a/source-registry.lisp b/source-registry.lisp index d85285fd..cc7fd3d4 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -5,6 +5,7 @@ (uiop/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) + (:import-from :asdf/cache #:initialize-source-registry) (:export #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry diff --git a/test/test-utilities.script b/test/test-utilities.script index 9e2217e4..de51182e 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -160,6 +160,8 @@ asdf/backward-interface:on-warnings asdf/find-system:contrib-sysdef-search asdf/find-system:sysdef-find-asdf + ;; restart + asdf/cache:reinitialize-source-registry-and-retry )) (defun defined-symbol-p (symbol) -- GitLab