Skip to content
Snippets Groups Projects
Commit b86ab129 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

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.
parent 81134efb
No related branches found
No related tags found
No related merge requests found
......@@ -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))
......
......@@ -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)))))
......@@ -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
......
......@@ -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)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment