From db6a7b33c2714b09febb42347411e9d8c9e629d5 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 19 Dec 2013 15:59:51 -0500 Subject: [PATCH] Have softer upgrades when upgrading from a forward-compatible-enough version. NB: insufficiently tested. --- backward-internals.lisp | 2 +- operation.lisp | 3 ++- output-translations.lisp | 2 +- source-registry.lisp | 2 +- upgrade.lisp | 23 ++++++++++++++++++++--- 5 files changed, 25 insertions(+), 7 deletions(-) diff --git a/backward-internals.lisp b/backward-internals.lisp index 0ecb7dd5..07e39c6a 100644 --- a/backward-internals.lisp +++ b/backward-internals.lisp @@ -16,7 +16,7 @@ ;;;; Backward compatibility with "inline methods" (with-upgradability () - (defparameter +asdf-methods+ + (defparameter* +asdf-methods+ '(perform-with-restarts perform explain output-files operation-done-p)) (defun %remove-component-inline-methods (component) diff --git a/operation.lisp b/operation.lisp index 16ac4875..7f18c45a 100644 --- a/operation.lisp +++ b/operation.lisp @@ -36,7 +36,8 @@ ;;; make-operation, find-operation (with-upgradability () - (defparameter *operations* (make-hash-table :test 'equal)) + (defparameter* *operations* (make-hash-table :test 'equal)) + (defun make-operation (operation-class &rest initargs) (ensure-gethash (cons operation-class initargs) *operations* (list* 'make-instance operation-class initargs))) diff --git a/output-translations.lisp b/output-translations.lisp index 6905cf5b..26587655 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -128,7 +128,7 @@ and the order is by decreasing length of namestring of the source pathname.") (push :ignore-inherited-configuration directives)) (return `(:output-translations ,@(nreverse directives))))))))) - (defparameter *default-output-translations* + (defparameter* *default-output-translations* '(environment-output-translations user-output-translations-pathname user-output-translations-directory-pathname diff --git a/source-registry.lisp b/source-registry.lisp index a558ed1f..cd7ab5ae 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -141,7 +141,7 @@ system names to pathnames of .asd files") (collect-sub*directories-asd-files directory :exclude exclude :collect collect))) - (defparameter *default-source-registries* + (defparameter* *default-source-registries* '(environment-source-registry user-source-registry user-source-registry-directory diff --git a/upgrade.lisp b/upgrade.lisp index 14a03fe2..3b7d9044 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -8,7 +8,7 @@ (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #: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 ;; There will be no symbol left behind! #:intern*) @@ -29,8 +29,20 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (string rev) (cons (format nil "~{~D~^.~}" rev)) (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 *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) (defun asdf-message (format-string &rest 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 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*)) + ;; 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)))) (defun upgrade-asdf () -- GitLab