Commit db6a7b33 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Have softer upgrades when upgrading from a forward-compatible-enough version.

NB: insufficiently tested.
parent 7bb84d2e
...@@ -16,7 +16,7 @@ ...@@ -16,7 +16,7 @@
;;;; Backward compatibility with "inline methods" ;;;; Backward compatibility with "inline methods"
(with-upgradability () (with-upgradability ()
(defparameter +asdf-methods+ (defparameter* +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p)) '(perform-with-restarts perform explain output-files operation-done-p))
(defun %remove-component-inline-methods (component) (defun %remove-component-inline-methods (component)
......
...@@ -36,7 +36,8 @@ ...@@ -36,7 +36,8 @@
;;; make-operation, find-operation ;;; make-operation, find-operation
(with-upgradability () (with-upgradability ()
(defparameter *operations* (make-hash-table :test 'equal)) (defparameter* *operations* (make-hash-table :test 'equal))
(defun make-operation (operation-class &rest initargs) (defun make-operation (operation-class &rest initargs)
(ensure-gethash (cons operation-class initargs) *operations* (ensure-gethash (cons operation-class initargs) *operations*
(list* 'make-instance operation-class initargs))) (list* 'make-instance operation-class initargs)))
......
...@@ -128,7 +128,7 @@ and the order is by decreasing length of namestring of the source pathname.") ...@@ -128,7 +128,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(push :ignore-inherited-configuration directives)) (push :ignore-inherited-configuration directives))
(return `(:output-translations ,@(nreverse directives))))))))) (return `(:output-translations ,@(nreverse directives)))))))))
(defparameter *default-output-translations* (defparameter* *default-output-translations*
'(environment-output-translations '(environment-output-translations
user-output-translations-pathname user-output-translations-pathname
user-output-translations-directory-pathname user-output-translations-directory-pathname
......
...@@ -141,7 +141,7 @@ system names to pathnames of .asd files") ...@@ -141,7 +141,7 @@ system names to pathnames of .asd files")
(collect-sub*directories-asd-files (collect-sub*directories-asd-files
directory :exclude exclude :collect collect))) directory :exclude exclude :collect collect)))
(defparameter *default-source-registries* (defparameter* *default-source-registries*
'(environment-source-registry '(environment-source-registry
user-source-registry user-source-registry
user-source-registry-directory user-source-registry-directory
......
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
(:export (:export
#:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
#:asdf-message #:*verbose-out* #:asdf-message #:*verbose-out*
#:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter*
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
;; There will be no symbol left behind! ;; There will be no symbol left behind!
#:intern*) #:intern*)
...@@ -29,8 +29,20 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -29,8 +29,20 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
(string rev) (string rev)
(cons (format nil "~{~D~^.~}" rev)) (cons (format nil "~{~D~^.~}" rev))
(null "1.0")))))) (null "1.0"))))))
;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly.
(defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous)))
(defvar *asdf-version* nil) (defvar *asdf-version* nil)
(defvar *previous-asdf-versions* nil) ;; We need to clear systems from versions yet older than the below:
(defparameter *oldest-forward-compatible-asdf-version* "2.27")
(defmacro defparameter* (var value &optional docstring)
(let* ((name (string-trim "*" var))
(valfun (intern (format nil "%~A-~A-~A" :compute name :value)))
(clearfun (intern (format nil "%~A-~A" :clear name))))
`(progn
(defun ,valfun () ,value)
(defvar ,var (,valfun) ,@(ensure-list docstring))
(defun ,clearfun () (setf ,var (,valfun)))
(register-hook-function '*post-upgrade-cleanup-hook* ',clearfun))))
(defvar *verbose-out* nil) (defvar *verbose-out* nil)
(defun asdf-message (format-string &rest format-args) (defun asdf-message (format-string &rest format-args)
(when *verbose-out* (apply 'format *verbose-out* format-string format-args))) (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
...@@ -126,7 +138,12 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -126,7 +138,12 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
old-version new-version) old-version new-version)
(asdf-message (compatfmt "~&~@<; ~@;Upgraded 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))
(call-functions (reverse *post-upgrade-cleanup-hook*)) ;; In case the previous version was too old to be forward-compatible, clear systems.
;; TODO: if needed, we may have to define a separate hook to run
;; in case of forward-compatible upgrade.
;; Or to move the tests forward-compatibility test inside each hook function?
(unless (version<= *oldest-forward-compatible-asdf-version* old-version)
(call-functions (reverse *post-upgrade-cleanup-hook*)))
t)))) t))))
(defun upgrade-asdf () (defun upgrade-asdf ()
......
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