Commit 80e5fd58 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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).
parent 7b4e0831
......@@ -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)))))))))
......@@ -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 ()
......
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