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

2.26.162: improve the upgrade cleanup mechanism

Make it run even if ASDF wasn't upgraded via upgrade-asdf.
parent 64b4399e
......@@ -62,7 +62,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.161" ;; to be automatically updated by make bump-version
:version "2.26.162" ;; 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.
......
......@@ -69,7 +69,7 @@
:when (eq feature? 'feature) :do
(setf (component-if-feature c) feature)))))
(when-upgrade (:when (fboundp 'make-sub-operation))
(when-upgrading (:when (fboundp 'make-sub-operation))
(defun* make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
......
......@@ -57,7 +57,7 @@ another pathname in a degenerate way."))
;;; TODO: find users, have them stop using that.
(defgeneric* (source-file-type) (component system))
(when-upgrade (:when (find-class 'component nil))
(when-upgrading (:when (find-class 'component nil))
(defmethod reinitialize-instance :after ((c component) &rest initargs &key)
(declare (ignorable c initargs)) (values)))
......@@ -168,7 +168,7 @@ another pathname in a degenerate way."))
(setf (gethash name hash) c))
hash))))
(when-upgrade (:when (find-class 'module nil))
(when-upgrading (:when (find-class 'module nil))
(defmethod reinitialize-instance :after ((m module) &rest initargs &key)
(declare (ignorable m initargs)) (values))
(defmethod update-instance-for-redefined-class :after
......
......@@ -15,7 +15,7 @@
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location #:resolve-absolute-location))
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
(in-package :asdf/configuration)
(define-condition invalid-configuration ()
......@@ -286,3 +286,11 @@ directive.")
(call-functions *clear-configuration-hook*))
(register-image-dump-hook 'clear-configuration)
;; If a previous version of ASDF failed to read some configuration, try again.
(defun* upgrade-configuration ()
(when *ignored-configuration-form*
(clear-configuration)
(setf *ignored-configuration-form* nil)))
......@@ -56,16 +56,18 @@
(error 'formatted-system-definition-error :format-control
format :format-arguments arguments))
(defun* make-defined-systems-table ()
(make-hash-table :test 'equal))
(defvar *defined-systems* (make-defined-systems-table)
(defvar *defined-systems* (make-hash-table :test 'equal)
"This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
element of which is a universal-time indicating when the
system definition was last updated, and the second element
of which is a system object.")
(defun* clear-defined-systems ()
(setf *defined-systems* (make-hash-table :test 'equal)))
(register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil)
(defun* coerce-name (name)
(typecase name
(component (component-name name))
......
......@@ -40,15 +40,6 @@
(values-list l))))))
;;;; Cleanups after hot-upgrade.
;; Things to do in case we're upgrading from a previous version of ASDF.
;; See https://bugs.launchpad.net/asdf/+bug/485687
;;
;; If a previous version of ASDF failed to read some configuration, try again.
(when *ignored-configuration-form*
(clear-configuration)
(setf *ignored-configuration-form* nil))
;;;; Done!
#+allegro
......@@ -60,6 +51,9 @@
(provide :asdf)
;;;; Cleanups after hot-upgrade.
(cleanup-upgraded-asdf)
(when *load-verbose*
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 2.26.161: Another System Definition Facility.
;;; This is ASDF 2.26.162: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -157,14 +157,6 @@ for how to load or compile stuff")
;;;; Some upgrade magic
(defun* reset-asdf-systems ()
(let ((asdf (find-system :asdf)))
(setf (component-version asdf) (asdf-version))
;; Invalidate all systems but ASDF itself.
(setf *defined-systems* (make-defined-systems-table))
(register-system asdf)
(load-system asdf))) ;; re-load ourselves the right way
(defun* restart-upgraded-asdf ()
;; If we're in the middle of something, restart it.
(when *systems-being-defined*
......@@ -172,5 +164,4 @@ for how to load or compile stuff")
(clrhash *systems-being-defined*)
(dolist (s l) (find-system s nil)))))
(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*)
(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)
......@@ -15,7 +15,7 @@
;;; Operation Classes
(when-upgrade (:when (find-class 'operation nil))
(when-upgrading (:when (find-class 'operation nil))
(defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
(declare (ignorable o slot-names initargs)) (values)))
......
......@@ -22,7 +22,7 @@
))
(in-package :asdf/output-translations)
(when-upgrade () (undefine-function '(setf output-translations)))
(when-upgrading () (undefine-function '(setf output-translations)))
(define-condition invalid-output-translation (invalid-configuration warning)
((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
......
......@@ -4,13 +4,12 @@
(asdf/package:define-package :asdf/upgrade
(:recycle :asdf/upgrade :asdf)
(:use :asdf/common-lisp :asdf/package :asdf/utility)
(:use :asdf/common-lisp :asdf/driver)
(:export
#:upgrade-asdf #:asdf-upgrade-error #:when-upgrade
#:*asdf-upgrade-already-attempted*
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
#:asdf-version #:*upgraded-p* #:*asdf-version*
#:asdf-version #:*previous-asdf-versions* #:*asdf-version*
#:asdf-message #:*asdf-verbose* #:*verbose-out*
#:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
;; There will be no symbol left behind!
#:intern*)
(:import-from :asdf/package #:intern* #:find-symbol*))
......@@ -19,30 +18,57 @@
;;; Special magic to detect if this is an upgrade
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")."
(when (find-package :asdf)
(or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
(let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
(etypecase ver
(string ver)
(cons (format nil "~{~D~^.~}" ver))
(null "1.0"))))))
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
(defvar *previous-asdf-versions* nil)
(defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
(defvar *verbose-out* nil)
(defun* asdf-message (format-string &rest format-args)
(apply 'format *verbose-out* format-string format-args)))
(apply 'format *verbose-out* format-string format-args))
(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())
(defun* upgrading-p ()
(and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
(defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and ,upgrading-p ,@(when when `(,when)))
(handler-bind ((style-warning #'muffle-warning))
(eval '(progn ,@body)))))))
(eval-when (:load-toplevel :compile-toplevel :execute)
(let* (;; For bug reporting sanity, please always bump this version when you modify this file.
;; Please also modify asdf.asd to reflect this change. make bump-version
;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
;; can help you do these changes in synch (look at the source for documentation).
;; Relying on its automation, the version is now redundantly present on top of this file.
;; "2.345" would be an official release
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.161")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))
(redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
'(#:component-relative-pathname #:component-parent-pathname ;; component
#:source-file-type
#:find-system #:system-source-file #:system-relative-pathname ;; system
;; "3.4" would be the general branch for major version 3, minor version 4.
;; "3.4.5" would be an official release in the 3.4 branch.
;; "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.26.162")
(existing-version (asdf-version)))
(when (and existing-version (not (equal asdf-version existing-version)))
(push existing-version *previous-asdf-versions*)
(when *asdf-verbose*
(format *trace-output*
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version)))
(setf *asdf-version* asdf-version)))
(when-upgrading ()
(let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
'(#:component-relative-pathname #:component-parent-pathname ;; component
#:source-file-type
#:find-system #:system-source-file #:system-relative-pathname ;; system
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:component-self-dependencies #:operation-done-p
......@@ -51,7 +77,7 @@
#:apply-output-translations ;; output-translations
#:process-output-translations-directive
#:inherit-source-registry #:process-source-registry ;; source-registry
#:process-source-registry-directive
#:process-source-registry-directive
#:trivial-system-p ;; bundle
;; NB: it's too late to do anything about asdf-driver functions!
))
......@@ -61,93 +87,57 @@
#:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols))
(setf *asdf-version* asdf-version)
(when (and existing-asdf (not already-there))
(push existing-version *upgraded-p*)
(when *asdf-verbose*
(format *trace-output*
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
existing-version asdf-version))
(loop :for name :in (append #-(or clisp ecl) redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do
(when sym
;;(format t "Undefining ~S~%" sym);XXX
(fmakunbound sym)))
(loop :with asdf = (find-package :asdf)
:for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX
:for sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do
(when sym
;;(format t "frobbing symbol ~S~%" sym);XXX
(cond
((or (eq base-pkg asdf) (not base-pkg))
(unintern* sym asdf)
(intern* sym asdf))
(t
(unintern* sym base-pkg)
(let ((new (intern* sym base-pkg)))
(shadowing-import new asdf))))))
;; Note that this massive package destruction makes it impossible
;; to use asdf/driver on top of an old ASDF on these implementations
#+(or xcl)
(let ((p (find-package :asdf)))
(when p
(do-symbols (s p) (when (home-package-p s p) (nuke-symbol s)))
(rename-package-away p :prefix (format nil "~A-~A" :asdf (or existing-version :1.x))
:index 0 :separator "-"))))))
(loop :for name :in (append #-(or clisp ecl) redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do
(when sym
(fmakunbound sym)))
(loop :with asdf = (find-package :asdf)
:for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX
:for sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do
(when sym
(cond
((or (eq base-pkg asdf) (not base-pkg))
(unintern* sym asdf)
(intern* sym asdf))
(t
(unintern* sym base-pkg)
(let ((new (intern* sym base-pkg)))
(shadowing-import new asdf))))))))
;;; Upgrade interface
;;; Self-upgrade functions
(defun* asdf-upgrade-error ()
;; Important notice for whom it concerns. The crux of the matter is that
;; TRAVERSE can be completely refactored, and so after the find-system returns, it's too late.
(error "When a system transitively depends on ASDF, it must :defsystem-depends-on (:asdf)~%~
Otherwise, when you upgrade ASDF, you must do it before you operate on any system.~%"))
(defmacro when-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and ,upgraded-p ,@(when when `(,when)))
(handler-bind ((style-warning #'muffle-warning))
(eval '(progn ,@body))))))
(defun* asdf-version ()
"Exported interface to the version of ASDF currently installed. A string.
You can compare this string with e.g.:
(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
*asdf-version*)
Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"))
;;; Self-upgrade functions
(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())
(defun* cleanup-upgraded-asdf (old-version)
(defun* cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
(let ((new-version (asdf-version)))
(unless (equal old-version new-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)))
(dolist (h (reverse *post-upgrade-cleanup-hook*))
(funcall (ensure-function h)))
(dolist (h *post-upgrade-restart-hook*)
(funcall (ensure-function h)))
t)))
(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)))
(call-functions (reverse *post-upgrade-cleanup-hook*))
t))))
(defun* upgrade-asdf ()
"Try to upgrade of ASDF. If a different version was used, return T.
We need do that before we operate on anything that may possibly depend on ASDF."
(let ((version (asdf-version))
(*load-print* nil)
(let ((*load-print* nil)
(*compile-print* nil))
(handler-bind (((or style-warning warning) #'muffle-warning))
(symbol-call :asdf :load-system :asdf :verbose nil))
(cleanup-upgraded-asdf version)))
(symbol-call :asdf :load-system :asdf :verbose nil))))
(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)
......@@ -308,7 +308,7 @@ instead of a list."
(defun* call-functions (function-specs)
(map () 'call-function function-specs))
(defun* register-hook-function (variable hook &optional (call-now-p t))
(defun* register-hook-function (variable hook &optional call-now-p)
(pushnew hook (symbol-value variable))
(when call-now-p (call-function hook)))
......@@ -372,8 +372,8 @@ with later being determined by a lexicographical comparison of minor numbers."
#+allegro 'excl::format-control
#+clisp 'system::$format-control
#+clozure 'ccl::format-control
#+ecl 'si::format-control
#+(or cmu scl) 'conditions::format-control
#+ecl 'si::format-control
#+(or gcl lispworks) 'conditions::format-string
#+sbcl 'sb-kernel:format-control
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
......
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