From 18c47d2f236c3dee72f9378340b4239dcecbcf7c Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 22 Feb 2013 15:21:28 -0500
Subject: [PATCH] 2.30.4: be more clever wrt refusing to downgrading ASDF.

Also restore lost (setf (gethash name *systems-being-defined*) system)
in register-system-definition.
---
 asdf.asd          |  2 +-
 bin/asdf-builder  |  4 +--
 defsystem.lisp    |  1 +
 find-system.lisp  | 89 ++++++++++++++++++++++++++++++++++++-----------
 header.lisp       |  2 +-
 operate.lisp      |  6 ++--
 upgrade.lisp      | 19 ++++------
 version.lisp-expr |  2 +-
 8 files changed, 85 insertions(+), 40 deletions(-)

diff --git a/asdf.asd b/asdf.asd
index 9bd41e95c..9423c3889 100644
--- a/asdf.asd
+++ b/asdf.asd
@@ -74,7 +74,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.30.3" ;; to be automatically updated by make bump-version
+  :version "2.30.4" ;; to be automatically updated by make bump-version
   :depends-on ()
   #+asdf3 :encoding #+asdf3 :utf-8
   ;; For most purposes, asdf itself specially counts as a builtin system.
diff --git a/bin/asdf-builder b/bin/asdf-builder
index 058f14803..fe4a974dc 100755
--- a/bin/asdf-builder
+++ b/bin/asdf-builder
@@ -192,8 +192,8 @@
   (let ((pv (parse-version v 'error)))
     (assert (first pv))
     (assert (second pv))
-    (unless (third pv) (appendf pv '(0)))
-    (incf (third pv))
+    (unless (third pv) (appendf pv (list 0)))
+    (incf (car (last pv)))
     (unparse-version pv)))
 
 (defun version-from-file ()
diff --git a/defsystem.lisp b/defsystem.lisp
index 548f28d6c..2763b5b48 100644
--- a/defsystem.lisp
+++ b/defsystem.lisp
@@ -192,6 +192,7 @@
              (component-options (remove-plist-key :class options))
              (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
                                            (resolve-dependency-spec nil spec))))
+        (setf (gethash name *systems-being-defined*) system)
         (apply 'load-systems defsystem-dependencies)
         ;; We change-class AFTER we loaded the defsystem-depends-on
         ;; since the class might be defined as part of those.
diff --git a/find-system.lisp b/find-system.lisp
index bcdb16453..09d3640b7 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -232,6 +232,20 @@ Going forward, we recommend new users should be using the source-registry.
                             (list new)
                             (subseq *central-registry* (1+ position))))))))))
 
+  (defvar *preloaded-systems* (make-hash-table :test 'equal))
+
+  (defun sysdef-preloaded-system-search (requested)
+    (let ((name (coerce-name requested)))
+      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
+        (when foundp
+          (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys)))))
+
+  (defun register-preloaded-system (system-name &rest keys)
+    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
+
+  (register-preloaded-system "asdf" :version *asdf-version*)
+  (register-preloaded-system "asdf-driver" :version *asdf-version*)
+
   (defmethod find-system ((name null) &optional (error-p t))
     (declare (ignorable name))
     (when error-p
@@ -281,6 +295,47 @@ Going forward, we recommend new users should be using the source-registry.
             (with-muffled-loader-conditions ()
               (load* pathname :external-format external-format)))))))
 
+  (defvar *old-asdf-systems* (make-hash-table :test 'equal))
+
+  (defun check-not-old-asdf-system (name pathname)
+    (or (not (equal name "asdf"))
+        (null pathname)
+        (let* ((version-pathname (subpathname pathname "version.lisp-expr"))
+               (version (and (probe-file* version-pathname :truename nil)
+                             (read-file-form version-pathname)))
+               (old-version (asdf-version)))
+          (or (version<= old-version version)
+              (let ((old-pathname
+                      (if-let (pair (system-registered-p "asdf"))
+                        (system-source-file (cdr pair))))
+                    (key (list pathname old-version)))
+                (format t "~S~%" (list :cnoas name pathname version-pathname version old-pathname old-version key (gethash key *old-asdf-systems*)))
+                (unless (gethash key *old-asdf-systems*)
+                  (setf (gethash key *old-asdf-systems*) t)
+                  (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. ~
+        Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
+        and having an old version registered is a configuration error. ~
+        ASDF will ignore this configured system rather than downgrade itself. ~
+        In the future, you may want to either: ~
+        (a) upgrade this configured ASDF to a newer version, ~
+        (b) install a newer ASDF and register it in front of the former in your configuration, or ~
+        (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
+        Note that the older ASDF might be registered implicitly through configuration inherited ~
+        from your system installation, in which case you might have to specify ~
+        :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
+        or other source-registry configuration file, environment variable or lisp parameter. ~
+        Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
+        that you might want to upgrade (if a recent enough version is available) ~
+        or else remove altogether (since most implementations ship with a recent asdf); ~
+        if you lack the system administration rights to upgrade or remove this package, ~
+        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)))))))
+
   (defun locate-system (name)
     "Given a system NAME designator, try to locate where to load the system from.
 Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
@@ -298,12 +353,20 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
            (previous-time (car in-memory))
            (found (search-for-system-definition name))
            (found-system (and (typep found 'system) found))
-           (pathname (or (and (typep found '(or pathname string)) (pathname found))
-                         (and found-system (system-source-file found-system))
-                         (and previous (system-source-file previous))))
-           (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
+           (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))
@@ -329,7 +392,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
                                                       (translate-logical-pathname pathname)
                                                       (translate-logical-pathname previous-pathname))))
                                             (stamp<= stamp previous-time))))))
-                  ;; only load when it's a pathname that is different or has newer content
+                  ;; only load when it's a pathname that is different or has newer content, and not an old asdf
                   (load-asd pathname :name name)))
               (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
                 (return
@@ -343,19 +406,5 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
           (reinitialize-source-registry-and-retry ()
             :report (lambda (s)
                       (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
-            (initialize-source-registry))))))
-
-  (defvar *preloaded-systems* (make-hash-table :test 'equal))
-
-  (defun sysdef-preloaded-system-search (requested)
-    (let ((name (coerce-name requested)))
-      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
-        (when foundp
-          (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys)))))
-
-  (defun register-preloaded-system (system-name &rest keys)
-    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
-
-  (register-preloaded-system "asdf" :version *asdf-version*)
-  (register-preloaded-system "asdf-driver" :version *asdf-version*))
+            (initialize-source-registry)))))))
 
diff --git a/header.lisp b/header.lisp
index d9f7b520b..837fdd5f9 100644
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.30.3: Another System Definition Facility.
+;;; This is ASDF 2.30.4: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
diff --git a/operate.lisp b/operate.lisp
index d1aebdeb2..0195a60cf 100644
--- a/operate.lisp
+++ b/operate.lisp
@@ -63,9 +63,6 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
            (systems-being-operated *systems-being-operated*)
            (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
            (system (component-system component)))
-      (setf (gethash (coerce-name system) *systems-being-operated*) system)
-      (unless (version-satisfies component version)
-        (error 'missing-component-of-version :requires component :version version))
       ;; Before we operate on any system, make sure ASDF is up-to-date,
       ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
       (unless systems-being-operated
@@ -78,6 +75,9 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
               (apply (find-symbol* 'operate :asdf)
                      (unreify-symbol operation-name)
                      component-path args)))))
+      (setf (gethash (coerce-name system) *systems-being-operated*) system)
+      (unless (version-satisfies component version)
+        (error 'missing-component-of-version :requires component :version version))
       (let ((plan (apply 'traverse operation system args)))
         (perform-plan plan)
         (values operation plan))))
diff --git a/upgrade.lisp b/upgrade.lisp
index 14eb0fa38..dbad10305 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
          ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
          ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
          ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
-         (asdf-version "2.30.3")
+         (asdf-version "2.30.4")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
     (when (and existing-version (not (equal asdf-version existing-version)))
@@ -119,16 +119,11 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
       (unless (equal old-version new-version)
         (push new-version *previous-asdf-versions*)
         (when old-version
-          (cond
-            ((version-compatible-p new-version old-version)
-             (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
-                           old-version new-version))
-            ((version-compatible-p old-version new-version)
-             (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
-                   old-version new-version))
-            (t
-             (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
-                           old-version new-version)))
+          (if (version<= new-version old-version)
+              (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+                     old-version new-version)
+              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                            old-version new-version))
           (call-functions (reverse *post-upgrade-cleanup-hook*))
           t))))
 
@@ -137,7 +132,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
    We need do that before we operate on anything that may possibly depend on ASDF."
     (let ((*load-print* nil)
           (*compile-print* nil))
-      (handler-bind (((or style-warning warning) #'muffle-warning))
+      (handler-bind (((or style-warning) #'muffle-warning))
         (symbol-call :asdf :load-system :asdf :verbose nil))))
 
   (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
diff --git a/version.lisp-expr b/version.lisp-expr
index 464913af6..fb738892d 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.30.3"
+"2.30.4"
-- 
GitLab