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