Commit 2b1c8b62 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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.
parent 28a5c936
......@@ -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)
(list pathname old-version) *old-asdf-systems*
#'(lambda ()
(let ((old-pathname
(if-let (pair (system-registered-p "asdf"))
(system-source-file (cdr pair)))))
(warn "~@<~
((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
(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)
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.
(in-package :asdf-test)
(defparameter *always-error-was-read-p* t)
(eval-when (:compile-toplevel :load-toplevel :execute)
(error "ALWAYS ERROR"))
;;; -*- 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")
'(: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")
#'(lambda (c)
(when (search "ASDF will ignore this configured system rather than downgrade itself."
(simple-condition-format-control c))
(setf state "Caught warning")))))
(assert-equal state "Caught warning")
(DBG "2nd bogus attempt at loading same old ASDF: should ignore without a warning")
#'(lambda (c)
(error "Should not have issued warning, but did issue:~% ~A" c))))
(DBG "Load ASDF with proper configuration: should find asdf.asd from the source above")
(:directory ,*asdf-directory*)
(:directory ,*uiop-directory*)
(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*))))
......@@ -274,3 +274,16 @@
(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)))
......@@ -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
(setf (gethash key table) (values (call-function default))))))
(if foundp
(setf (gethash key table) (call-function default)))
(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,
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