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

find-system.lisp

+7 −4
Changes for find-system.lisp: 7 added lines, 4 removed lines.
Original line number Diff line number Diff line
@@ -309,9 +309,12 @@ 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)

          (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 pathname old-version) *old-asdf-systems*

              (list (namestring pathname) version) *old-asdf-systems*

              #'(lambda ()

                 (let ((old-pathname

                         (if-let (pair (system-registered-p "asdf"))
@@ -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.

test/always-error.lisp

0 → 100644
+6 −0
Changes for test/always-error.lisp: 6 added lines, 0 removed lines.
Original line number Diff line number Diff line 
(in-package :asdf-test)



(defparameter *always-error-was-read-p* t)



(eval-when (:compile-toplevel :load-toplevel :execute)

  (error "ALWAYS ERROR"))

test/test-sysdef-asdf.script

+35 −4
Changes for test/test-sysdef-asdf.script: 35 added lines, 4 removed lines.
Original line number Diff line number Diff line 
;;; -*- 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*))))

test/test-utilities.script

+13 −0
Changes for test/test-utilities.script: 13 added lines, 0 removed lines.
Original line number Diff line number Diff line
@@ -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)))

uiop/utility.lisp

+6 −3
Changes for uiop/utility.lisp: 6 added lines, 3 removed lines.
Original line number Diff line number Diff line
@@ -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)

      (values

       (if foundp

           value

          (setf (gethash key table) (values (call-function default))))))

           (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,