From 438e1a97c27c12663de7f1634cb7200e4cf322d3 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Mon, 12 Sep 2016 08:19:07 -0400 Subject: [PATCH] Have locate-system use with-asdf-cache but not cache its own results This should make Daniel K happy. Also remove obsolete cleaning of locate-system cached results, for we haven't cached the result since 00256418 (3.1.2.9, 2014), that this commit partly undoes, partly re-does (due to merge conflict at the time). --- find-system.lisp | 51 ++++++++++++++++++++-------------------- test/script-support.lisp | 22 ++++++++--------- test/test-force.script | 1 - 3 files changed, 36 insertions(+), 38 deletions(-) diff --git a/find-system.lisp b/find-system.lisp index da6949f8a..58e25c2b6 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -160,7 +160,6 @@ NIL if not cleared because the system was found to be immutable." (let ((name (coerce-name system))) (unless (and *immutable-systems* (gethash name *immutable-systems*)) (remhash (coerce-name name) *defined-systems*) - (unset-asdf-cache-entry `(locate-system ,name)) (unset-asdf-cache-entry `(find-system ,name)) t))) @@ -383,28 +382,31 @@ PATHNAME when not null is a path from which to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time))) + (with-asdf-cache () ;; NB: We don't cache the results. We once used to, but it wasn't useful, + ;; and keeping a negative cache was a bug (see lp#1335323), which required + ;; explicit invalidation in clear-system and find-system (when unsucccessful). + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) + (values foundp found-system pathname previous previous-time)))) (defmethod find-system ((name string) &optional (error-p t)) (with-asdf-cache (:key `(find-system ,name)) @@ -443,6 +445,5 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (cdr in-memory)) (error-p (error 'missing-component :requires name)) - (t ;; not found: don't keep negative cache, see lp#1335323 - (unset-asdf-cache-entry `(locate-system ,name)) + (t (return-from find-system nil))))))))) diff --git a/test/script-support.lisp b/test/script-support.lisp index 963db8378..c6bba03cf 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -390,7 +390,7 @@ is bound, write a message and exit on an error. If (finish-outputs*) (unless *debug-asdf* (ignore-errors - (format *error-output* "~&Backtrace:~%") + (format *error-output* "~&Backtrace:~%") (acall :print-condition-backtrace c :count 69 :stream *error-output*)) (leave-test "Script failed" 1))))) @@ -619,18 +619,16 @@ is bound, write a message and exit on an error. If (when (asym :*verbose-out*) (setf (asymval :*verbose-out*) *standard-output*)) (when (and (asym :locate-system) (asym :pathname-directory-pathname) (asym :pathname-equal)) (format t "Comparing directories~%") - (acall :call-with-asdf-cache - #'(lambda () - (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) - (assert-pathname-equal-helper ;; not always EQUAL (!) - '*test-directory* *test-directory* - '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) - (unless (equal *test-directory* x) - (format t "Interestingly, while *test-directory* has components~% ~S~%~ + (let ((x (acall :pathname-directory-pathname (nth-value 2 (acall :locate-system :test-asdf))))) + (assert-pathname-equal-helper ;; not always EQUAL (!) + '*test-directory* *test-directory* + '(:pathname-directory-pathname (nth-value 2 (:locate-system :test-asdf))) x) + (unless (equal *test-directory* x) + (format t "Interestingly, while *test-directory* has components~% ~S~%~ ASDF finds the ASDs in~% ~S~%Using the latter.~%" - (pathname-components *test-directory*) - (pathname-components x))) - (setf *test-directory* x))))) + (pathname-components *test-directory*) + (pathname-components x))) + (setf *test-directory* x))) t) (defun frob-packages () diff --git a/test/test-force.script b/test/test-force.script index d2dc5c278..31f5c69c6 100644 --- a/test/test-force.script +++ b/test/test-force.script @@ -89,7 +89,6 @@ (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.)") -(unset-asdf-cache-entry '(locate-system "test-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))) -- GitLab