Commit 18c47d2f authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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.
parent 77640721
...@@ -74,7 +74,7 @@ ...@@ -74,7 +74,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :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 () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
......
...@@ -192,8 +192,8 @@ ...@@ -192,8 +192,8 @@
(let ((pv (parse-version v 'error))) (let ((pv (parse-version v 'error)))
(assert (first pv)) (assert (first pv))
(assert (second pv)) (assert (second pv))
(unless (third pv) (appendf pv '(0))) (unless (third pv) (appendf pv (list 0)))
(incf (third pv)) (incf (car (last pv)))
(unparse-version pv))) (unparse-version pv)))
(defun version-from-file () (defun version-from-file ()
......
...@@ -192,6 +192,7 @@ ...@@ -192,6 +192,7 @@
(component-options (remove-plist-key :class options)) (component-options (remove-plist-key :class options))
(defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
(resolve-dependency-spec nil spec)))) (resolve-dependency-spec nil spec))))
(setf (gethash name *systems-being-defined*) system)
(apply 'load-systems defsystem-dependencies) (apply 'load-systems defsystem-dependencies)
;; We change-class AFTER we loaded the defsystem-depends-on ;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those. ;; since the class might be defined as part of those.
......
...@@ -232,6 +232,20 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -232,6 +232,20 @@ Going forward, we recommend new users should be using the source-registry.
(list new) (list new)
(subseq *central-registry* (1+ position)))))))))) (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)) (defmethod find-system ((name null) &optional (error-p t))
(declare (ignorable name)) (declare (ignorable name))
(when error-p (when error-p
...@@ -281,6 +295,47 @@ Going forward, we recommend new users should be using the source-registry. ...@@ -281,6 +295,47 @@ Going forward, we recommend new users should be using the source-registry.
(with-muffled-loader-conditions () (with-muffled-loader-conditions ()
(load* pathname :external-format external-format))))))) (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) (defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from. "Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME 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. ...@@ -298,12 +353,20 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(previous-time (car in-memory)) (previous-time (car in-memory))
(found (search-for-system-definition name)) (found (search-for-system-definition name))
(found-system (and (typep found 'system) found)) (found-system (and (typep found 'system) found))
(pathname (or (and (typep found '(or pathname string)) (pathname found)) (pathname (ensure-pathname
(and found-system (system-source-file found-system)) (or (and (typep found '(or pathname string)) (pathname found))
(and previous (system-source-file previous)))) (and found-system (system-source-file found-system))
(pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t)) (and previous (system-source-file previous)))
:want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t))) (foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system)) (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))) (values foundp found-system pathname previous previous-time)))
(defmethod find-system ((name string) &optional (error-p t)) (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. ...@@ -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 pathname)
(translate-logical-pathname previous-pathname)))) (translate-logical-pathname previous-pathname))))
(stamp<= stamp previous-time)))))) (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))) (load-asd pathname :name name)))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return (return
...@@ -343,19 +406,5 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ...@@ -343,19 +406,5 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(reinitialize-source-registry-and-retry () (reinitialize-source-registry-and-retry ()
:report (lambda (s) :report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
(initialize-source-registry)))))) (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*))
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -63,9 +63,6 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -63,9 +63,6 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(systems-being-operated *systems-being-operated*) (systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(system (component-system component))) (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, ;; 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. ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated (unless systems-being-operated
...@@ -78,6 +75,9 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -78,6 +75,9 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(apply (find-symbol* 'operate :asdf) (apply (find-symbol* 'operate :asdf)
(unreify-symbol operation-name) (unreify-symbol operation-name)
component-path args))))) 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))) (let ((plan (apply 'traverse operation system args)))
(perform-plan plan) (perform-plan plan)
(values operation plan)))) (values operation plan))))
......
...@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -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.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.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 ;; "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))) (existing-version (asdf-version)))
(setf *asdf-version* asdf-version) (setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-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 ...@@ -119,16 +119,11 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(unless (equal old-version new-version) (unless (equal old-version new-version)
(push new-version *previous-asdf-versions*) (push new-version *previous-asdf-versions*)
(when old-version (when old-version
(cond (if (version<= new-version old-version)
((version-compatible-p new-version old-version) (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
(asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version)
old-version new-version)) (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
((version-compatible-p old-version new-version) 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)))
(call-functions (reverse *post-upgrade-cleanup-hook*)) (call-functions (reverse *post-upgrade-cleanup-hook*))
t)))) t))))
...@@ -137,7 +132,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -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." We need do that before we operate on anything that may possibly depend on ASDF."
(let ((*load-print* nil) (let ((*load-print* nil)
(*compile-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)))) (symbol-call :asdf :load-system :asdf :verbose nil))))
(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
......
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