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 @@ ...@@ -62,7 +62,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.26.161" ;; to be automatically updated by make bump-version :version "2.26.162" ;; 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.
......
...@@ -69,7 +69,7 @@ ...@@ -69,7 +69,7 @@
:when (eq feature? 'feature) :do :when (eq feature? 'feature) :do
(setf (component-if-feature c) feature))))) (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) (defun* make-sub-operation (c o dep-c dep-o)
(declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error)))
......
...@@ -57,7 +57,7 @@ another pathname in a degenerate way.")) ...@@ -57,7 +57,7 @@ another pathname in a degenerate way."))
;;; TODO: find users, have them stop using that. ;;; TODO: find users, have them stop using that.
(defgeneric* (source-file-type) (component system)) (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) (defmethod reinitialize-instance :after ((c component) &rest initargs &key)
(declare (ignorable c initargs)) (values))) (declare (ignorable c initargs)) (values)))
...@@ -168,7 +168,7 @@ another pathname in a degenerate way.")) ...@@ -168,7 +168,7 @@ another pathname in a degenerate way."))
(setf (gethash name hash) c)) (setf (gethash name hash) c))
hash)))) hash))))
(when-upgrade (:when (find-class 'module nil)) (when-upgrading (:when (find-class 'module nil))
(defmethod reinitialize-instance :after ((m module) &rest initargs &key) (defmethod reinitialize-instance :after ((m module) &rest initargs &key)
(declare (ignorable m initargs)) (values)) (declare (ignorable m initargs)) (values))
(defmethod update-instance-for-redefined-class :after (defmethod update-instance-for-redefined-class :after
......
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
#:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #: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) (in-package :asdf/configuration)
(define-condition invalid-configuration () (define-condition invalid-configuration ()
...@@ -286,3 +286,11 @@ directive.") ...@@ -286,3 +286,11 @@ directive.")
(call-functions *clear-configuration-hook*)) (call-functions *clear-configuration-hook*))
(register-image-dump-hook 'clear-configuration) (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 @@ ...@@ -56,16 +56,18 @@
(error 'formatted-system-definition-error :format-control (error 'formatted-system-definition-error :format-control
format :format-arguments arguments)) format :format-arguments arguments))
(defun* make-defined-systems-table () (defvar *defined-systems* (make-hash-table :test 'equal)
(make-hash-table :test 'equal))
(defvar *defined-systems* (make-defined-systems-table)
"This is a hash table whose keys are strings, being the "This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first names of the systems, and whose values are pairs, the first
element of which is a universal-time indicating when the element of which is a universal-time indicating when the
system definition was last updated, and the second element system definition was last updated, and the second element
of which is a system object.") 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) (defun* coerce-name (name)
(typecase name (typecase name
(component (component-name name)) (component (component-name name))
......
...@@ -40,15 +40,6 @@ ...@@ -40,15 +40,6 @@
(values-list l)))))) (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! ;;;; Done!
#+allegro #+allegro
...@@ -60,6 +51,9 @@ ...@@ -60,6 +51,9 @@
(provide :asdf) (provide :asdf)
;;;; Cleanups after hot-upgrade.
(cleanup-upgraded-asdf)
(when *load-verbose* (when *load-verbose*
(asdf-message ";; ASDF, version ~a~%" (asdf-version))) (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -157,14 +157,6 @@ for how to load or compile stuff") ...@@ -157,14 +157,6 @@ for how to load or compile stuff")
;;;; Some upgrade magic ;;;; 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 () (defun* restart-upgraded-asdf ()
;; If we're in the middle of something, restart it. ;; If we're in the middle of something, restart it.
(when *systems-being-defined* (when *systems-being-defined*
...@@ -172,5 +164,4 @@ for how to load or compile stuff") ...@@ -172,5 +164,4 @@ for how to load or compile stuff")
(clrhash *systems-being-defined*) (clrhash *systems-being-defined*)
(dolist (s l) (find-system s nil))))) (dolist (s l) (find-system s nil)))))
(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*)
(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*) (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
;;; Operation Classes ;;; 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) (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key)
(declare (ignorable o slot-names initargs)) (values))) (declare (ignorable o slot-names initargs)) (values)))
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
)) ))
(in-package :asdf/output-translations) (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) (define-condition invalid-output-translation (invalid-configuration warning)
((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
......
...@@ -4,13 +4,12 @@ ...@@ -4,13 +4,12 @@
(asdf/package:define-package :asdf/upgrade (asdf/package:define-package :asdf/upgrade
(:recycle :asdf/upgrade :asdf) (:recycle :asdf/upgrade :asdf)
(:use :asdf/common-lisp :asdf/package :asdf/utility) (:use :asdf/common-lisp :asdf/driver)
(:export (:export
#:upgrade-asdf #:asdf-upgrade-error #:when-upgrade #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
#:*asdf-upgrade-already-attempted*
#:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
#:asdf-version #:*upgraded-p* #:*asdf-version*
#:asdf-message #:*asdf-verbose* #:*verbose-out* #: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! ;; There will be no symbol left behind!
#:intern*) #:intern*)
(:import-from :asdf/package #:intern* #:find-symbol*)) (:import-from :asdf/package #:intern* #:find-symbol*))
...@@ -19,30 +18,57 @@ ...@@ -19,30 +18,57 @@
;;; Special magic to detect if this is an upgrade ;;; Special magic to detect if this is an upgrade
(eval-when (:load-toplevel :compile-toplevel :execute) (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 *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 *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
(defvar *verbose-out* nil) (defvar *verbose-out* nil)
(defun* asdf-message (format-string &rest format-args) (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) (eval-when (:load-toplevel :compile-toplevel :execute)
(let* (;; For bug reporting sanity, please always bump this version when you modify this file. (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). ;; 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. ;; Relying on its automation, the version is now redundantly present on top of this file.
;; "2.345" would be an official release ;; "3.4" would be the general branch for major version 3, minor version 4.
;; "2.345.6" would be a development version in the official upstream ;; "3.4.5" would be an official release in the 3.4 branch.
;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
(asdf-version "2.26.161") ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (asdf-version "2.26.162")
(existing-version *asdf-version*) (existing-version (asdf-version)))
(already-there (equal asdf-version existing-version)) (when (and existing-version (not (equal asdf-version existing-version)))
(redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. (push existing-version *previous-asdf-versions*)
'(#:component-relative-pathname #:component-parent-pathname ;; component (when *asdf-verbose*
#:source-file-type (format *trace-output*
#:find-system #:system-source-file #:system-relative-pathname ;; system (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 #:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
#:component-depends-on #:component-self-dependencies #:operation-done-p #:component-depends-on #:component-self-dependencies #:operation-done-p
...@@ -51,7 +77,7 @@ ...@@ -51,7 +77,7 @@
#:apply-output-translations ;; output-translations #:apply-output-translations ;; output-translations
#:process-output-translations-directive #:process-output-translations-directive
#:inherit-source-registry #:process-source-registry ;; source-registry #:inherit-source-registry #:process-source-registry ;; source-registry
#:process-source-registry-directive #:process-source-registry-directive
#:trivial-system-p ;; bundle #:trivial-system-p ;; bundle
;; NB: it's too late to do anything about asdf-driver functions! ;; NB: it's too late to do anything about asdf-driver functions!
)) ))
...@@ -61,93 +87,57 @@ ...@@ -61,93 +87,57 @@
#:resolve-relative-location-component #:resolve-absolute-location-component #:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols)) (declare (ignorable redefined-functions uninterned-symbols))
(setf *asdf-version* asdf-version) (loop :for name :in (append #-(or clisp ecl) redefined-functions)
(when (and existing-asdf (not already-there)) :for sym = (find-symbol* name :asdf nil) :do
(push existing-version *upgraded-p*) (when sym
(when *asdf-verbose* (fmakunbound sym)))
(format *trace-output* (loop :with asdf = (find-package :asdf)
(compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") :for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX
existing-version asdf-version)) :for sym = (find-symbol* name :asdf nil)
(loop :for name :in (append #-(or clisp ecl) redefined-functions) :for base-pkg = (and sym (symbol-package sym)) :do
:for sym = (find-symbol* name :asdf nil) :do (when sym
(when sym (cond
;;(format t "Undefining ~S~%" sym);XXX ((or (eq base-pkg asdf) (not base-pkg))
(fmakunbound sym))) (unintern* sym asdf)
(loop :with asdf = (find-package :asdf) (intern* sym asdf))
:for name :in (append #+(or clisp ecl) redefined-functions uninterned-symbols) ;XXX (t
:for sym = (find-symbol* name :asdf nil) (unintern* sym base-pkg)
:for base-pkg = (and sym (symbol-package sym)) :do (let ((new (intern* sym base-pkg)))
(when sym (shadowing-import new asdf))))))))
;;(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 "-"))))))
;;; Upgrade interface ;;; Self-upgrade functions
(defun* asdf-upgrade-error () (defun* asdf-upgrade-error ()
;; Important notice for whom it concerns. The crux of the matter is that ;; 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. ;; 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)~%~ (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.~%")) Otherwise, when you upgrade from ASDF 2, 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*)
;;; Self-upgrade functions (defun* cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())
(defun* cleanup-upgraded-asdf (old-version)
(let ((new-version (asdf-version))) (let ((new-version (asdf-version)))
(unless (equal old-version new-version) (unless (equal old-version new-version)
(cond (push new-version *previous-asdf-versions*)
((version-compatible-p new-version old-version) (when old-version
(asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") (cond
old-version new-version)) ((version-compatible-p new-version old-version)
((version-compatible-p old-version new-version) (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
(warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version))
old-version new-version)) ((version-compatible-p old-version new-version)
(t (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
(asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") old-version new-version))
old-version new-version))) (t
(dolist (h (reverse *post-upgrade-cleanup-hook*)) (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
(funcall (ensure-function h))) old-version new-version)))
(dolist (h *post-upgrade-restart-hook*) (call-functions (reverse *post-upgrade-cleanup-hook*))
(funcall (ensure-function h))) t))))
t)))
(defun* upgrade-asdf () (defun* upgrade-asdf ()
"Try to upgrade of ASDF. If a different version was used, return T. "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." We need do that before we operate on anything that may possibly depend on ASDF."
(let ((version (asdf-version)) (let ((*load-print* nil)
(*load-print* nil)
(*compile-print* nil)) (*compile-print* nil))
(handler-bind (((or style-warning warning) #'muffle-warning)) (handler-bind (((or style-warning warning) #'muffle-warning))
(symbol-call :asdf :load-system :asdf :verbose nil)) (symbol-call :asdf :load-system :asdf :verbose nil))))
(cleanup-upgraded-asdf version)))
(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)
...@@ -308,7 +308,7 @@ instead of a list." ...@@ -308,7 +308,7 @@ instead of a list."
(defun* call-functions (function-specs) (defun* call-functions (function-specs)
(map () 'call-function 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)) (pushnew hook (symbol-value variable))
(when call-now-p (call-function hook))) (when call-now-p (call-function hook)))
...@@ -372,8 +372,8 @@ with later being determined by a lexicographical comparison of minor numbers." ...@@ -372,8 +372,8 @@ with later being determined by a lexicographical comparison of minor numbers."
#+allegro 'excl::format-control #+allegro 'excl::format-control
#+clisp 'system::$format-control #+clisp 'system::$format-control
#+clozure 'ccl::format-control #+clozure 'ccl::format-control
#+ecl 'si::format-control
#+(or cmu scl) 'conditions::format-control #+(or cmu scl) 'conditions::format-control
#+ecl 'si::format-control
#+(or gcl lispworks) 'conditions::format-string #+(or gcl lispworks) 'conditions::format-string
#+sbcl 'sb-kernel:format-control #+sbcl 'sb-kernel:format-control
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil #-(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