From 2b1c8b6257a8666523bd1085b335fdd5deb2bab3 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Tue, 14 Jan 2014 00:07:30 -0500 Subject: [PATCH] Fix regression whereby ASDF 3.0.3 warns but still loads an old ASDF. Also decline to "upgrade" to very same version, but without warning. Add a regression test. You can see the test fail with old versions, with e.g. cat build/asdf-3.0.3.lisp > build/asdf.lisp ; make t l=ccl t=test-sysdef-asdf.script Also tweak ensure-gethash to return two values, and add tests. --- find-system.lisp | 23 ++++++++++++--------- test/always-error.lisp | 6 ++++++ test/test-sysdef-asdf.script | 39 ++++++++++++++++++++++++++++++++---- test/test-utilities.script | 13 ++++++++++++ uiop/utility.lisp | 13 +++++++----- 5 files changed, 75 insertions(+), 19 deletions(-) create mode 100644 test/always-error.lisp diff --git a/find-system.lisp b/find-system.lisp index 9606712c6..84d53d275 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -309,14 +309,17 @@ Going forward, we recommend new users should be using the source-registry. (version (and (probe-file* version-pathname :truename nil) (read-file-form version-pathname))) (old-version (asdf-version))) - (or (version<= old-version version) - (ensure-gethash - (list pathname old-version) *old-asdf-systems* - #'(lambda () - (let ((old-pathname - (if-let (pair (system-registered-p "asdf")) - (system-source-file (cdr pair))))) - (warn "~@<~ + (cond + ((version< old-version version) t) ;; newer version: good! + ((equal old-version version) nil) ;; same version: don't load, but don't warn + (t ;; old version: bad + (ensure-gethash + (list (namestring pathname) version) *old-asdf-systems* + #'(lambda () + (let ((old-pathname + (if-let (pair (system-registered-p "asdf")) + (system-source-file (cdr pair))))) + (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ @@ -338,8 +341,8 @@ Going forward, we recommend new users should be using the source-registry. then you might indeed want to either install and register a more recent version, ~ or use :ignore-inherited-configuration to avoid registering the old one. ~ Please consult ASDF documentation and/or experts.~@:>~%" - old-version old-pathname version pathname) - t))))))) + old-version old-pathname version pathname)))) + nil))))) ;; only issue the warning the first time, but always return nil (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. diff --git a/test/always-error.lisp b/test/always-error.lisp new file mode 100644 index 000000000..8c7d93688 --- /dev/null +++ b/test/always-error.lisp @@ -0,0 +1,6 @@ +(in-package :asdf-test) + +(defparameter *always-error-was-read-p* t) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (error "ALWAYS ERROR")) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index e3943185e..ca64760d6 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -1,23 +1,54 @@ ;;; -*- Lisp -*- -;; Empty configuration: no asdf.asd +(format! t "~%Using ASDF ~A~%" (asdf-version)) +(assert (version< "3.0" (asdf-version))) ;; check that we have a recent enough ASDF + +(DBG "Try load ASDF with an empty configuration") (initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (load-system :asdf) -;; We didn't find it and got the fallback +;; We haven't found it, and got the fallback (assert-equal nil (system-source-file (find-system :asdf))) -;; Proper configuration: asdf.asd from the source above +;; Bogus sysdef finding function, for the sake of testing no-load-old-version. +(defun sysdef-bogus-test-search (system) + (declare (ignore system)) + (subpathname *test-directory* "always-error.lisp")) + +(let ((*system-definition-search-functions* '(sysdef-bogus-test-search)) + (state "Didn't catch warning")) + (DBG "Bogus attempt at loading an old ASDF: should issue a warning and ignore") + (handler-bind + ((simple-warning + #'(lambda (c) + (when (search "ASDF will ignore this configured system rather than downgrade itself." + (simple-condition-format-control c)) + (setf state "Caught warning"))))) + (upgrade-asdf)) + (assert-equal state "Caught warning") + (DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning") + (handler-bind + ((simple-warning + #'(lambda (c) + (error "Should not have issued warning, but did issue:~% ~A" c)))) + (upgrade-asdf))) + +(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above") (initialize-source-registry `(:source-registry (:directory ,*asdf-directory*) (:directory ,*uiop-directory*) :ignore-inherited-configuration)) (load-system :asdf) -;; This time we found it +;; This time we found it, but it was skipped because the version was the same +(assert-equal nil (system-source-file (find-system :asdf))) +;; But if we cheat on our version, that should work +(setf asdf::*asdf-version* "3.0") +(load-system :asdf) (assert-pathname-equal (subpathname *asdf-directory* "asdf.asd") (system-source-file (find-system :asdf))) +(DBG "Checking that Makefile and asdf.asd are in synch") (defun system-lisp-files (system) (loop :for f :in (required-components system :keep-component 'cl-source-file) :collect (namestring (enough-pathname (component-pathname f) *asdf-directory*)))) diff --git a/test/test-utilities.script b/test/test-utilities.script index b2a5eb576..3daaaf260 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -274,3 +274,16 @@ p))) (assert-equal (read-file-lines pn) '("Hello, World")) (delete-file pn)) + +(DBG :ensure-gethash) +(let ((h (make-hash-table :test 'equal))) + (assert-equal (multiple-value-list (gethash 1 h 2)) '(2 nil)) + (assert-equal (multiple-value-list (ensure-gethash 1 h 2)) '(2 nil)) + (assert-equal (multiple-value-list (gethash 1 h 2)) '(2 t)) + (assert-equal (multiple-value-list (ensure-gethash 1 h 3)) '(2 t)) + (assert-equal (multiple-value-list (ensure-gethash 1 h '(error "foo"))) '(2 t)) + (signals parse-error (ensure-gethash 2 h '(error parse-error))) + (assert-equal (multiple-value-list (gethash 3 h nil)) '(nil nil)) + (assert-equal (multiple-value-list (ensure-gethash 3 h nil)) '(nil nil)) + (assert-equal (multiple-value-list (gethash 3 h 4)) '(nil t)) + (assert-equal (multiple-value-list (ensure-gethash 3 h 5)) '(nil t))) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index bd6454989..48dd4759a 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -438,13 +438,16 @@ When CALL-NOW-P is true, also call the function immediately." ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default) - "Lookup the TABLE for a KEY as by gethash, but if not present, + "Lookup the TABLE for a KEY as by GETHASH, but if not present, call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, -set the corresponding entry to the result in the table, and return that result." +set the corresponding entry to the result in the table. +Return two values: the entry after its optional computation, and whether it was found" (multiple-value-bind (value foundp) (gethash key table) - (if foundp - value - (setf (gethash key table) (values (call-function default)))))) + (values + (if foundp + value + (setf (gethash key table) (call-function default))) + foundp))) (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) "Convert a LIST into hash-table that has the same elements when viewed as a set, -- GitLab