1;;;; ------------------------------------------------------------------------- 2;;;; Handle upgrade as forward- and backward-compatibly as possible 3;; See https://bugs.launchpad.net/asdf/+bug/485687 4 5(uiop/package:define-package :asdf/upgrade 6 (:recycle :asdf/upgrade :asdf) 7 (:use :uiop/common-lisp :uiop) 8 (:export 9 #:asdf-version #:*previous-asdf-versions* #:*asdf-version* 10 #:asdf-message #:*verbose-out* 11 #:upgrading-p #:when-upgrading #:upgrade-asdf #:defparameter* 12 #:*post-upgrade-cleanup-hook* #:cleanup-upgraded-asdf 13 ;; There will be no symbol left behind! 14 #:with-asdf-deprecation 15 #:intern*) 16 (:import-from :uiop/package #:intern* #:find-symbol*)) 17(in-package :asdf/upgrade) 18 19;;; Special magic to detect if this is an upgrade 20 21(with-upgradability () 22 (defun asdf-version () 23 "Exported interface to the version of ASDF currently installed. A string. 24You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"3.4.5.67\")." 25 (when (find-package :asdf) 26 (or (symbol-value (find-symbol (string :*asdf-version*) :asdf)) 27 (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf)) 28 (rev (and revsym (boundp revsym) (symbol-value revsym)))) 29 (etypecase rev 30 (string rev) 31 (cons (format nil "~{~D~^.~}" rev)) 32 (null "1.0")))))) 33 ;; This (private) variable contains a list of versions of previously loaded variants of ASDF, 34 ;; from which ASDF was upgraded. 35 ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly. 36 (defvar *previous-asdf-versions* 37 (let ((previous (asdf-version))) 38 (when previous 39 ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package. 40 (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature. 41 (let ((away (format nil "~A-~A" :asdf previous))) 42 (rename-package :asdf away) 43 (when *load-verbose* 44 (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))) 45 (list previous)))) 46 ;; This public variable will be bound shortly to the currently loaded version of ASDF. 47 (defvar *asdf-version* nil) 48 ;; We need to clear systems from versions older than the one in this (private) parameter. 49 ;; The latest incompatible defclass is 2.32.13 renaming a slot in component, 50 ;; or 3.2.0.2 for CCL (incompatibly changing some superclasses). 51 ;; the latest incompatible gf change is in 3.1.7.20 (see redefined-functions below). 52 (defparameter *oldest-forward-compatible-asdf-version* "3.2.0.2") 53 ;; Semi-private variable: a designator for a stream on which to output ASDF progress messages 54 (defvar *verbose-out* nil) 55 ;; Private function by which ASDF outputs progress messages and warning messages: 56 (defun asdf-message (format-string &rest format-args) 57 (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) 58 ;; Private hook for functions to run after ASDF has upgraded itself from an older variant: 59 (defvar *post-upgrade-cleanup-hook* ()) 60 ;; Private function to detect whether the current upgrade counts as an incompatible 61 ;; data schema upgrade implying the need to drop data. 62 (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) 63 (and *previous-asdf-versions* 64 (version< (first *previous-asdf-versions*) oldest-compatible-version))) 65 ;; Private variant of defparameter that works in presence of incompatible upgrades: 66 ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change), 67 ;; but behaves like defparameter if in presence of an incompatible upgrade. 68 (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) 69 (let* ((name (string-trim "*" var)) 70 (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) 71 `(progn 72 (defun ,valfun () ,value) 73 (defvar ,var (,valfun) ,@(ensure-list docstring)) 74 (when (upgrading-p ,version) 75 (setf ,var (,valfun)))))) 76 ;; Private macro to declare sections of code that are only compiled and run when upgrading. 77 ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects, 78 ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs. 79 (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) 80 (upgrading-p `(upgrading-p ,version)) when) &body body) 81 "A wrapper macro for code that should only be run when upgrading a 82previously-loaded version of ASDF." 83 `(with-upgradability () 84 (when (and ,upgrading-p ,@(when when `(,when))) 85 (handler-bind ((style-warning #'muffle-warning)) 86 (eval '(progn ,@body)))))) 87 ;; Only now can we safely update the version. 88 (let* (;; For bug reporting sanity, please always bump this version when you modify this file. 89 ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 90 ;; can help you do these changes in synch (look at the source for documentation). 91 ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp. 92 ;; "3.4" would be the general branch for major version 3, minor version 4. 93 ;; "3.4.5" would be an official release in the 3.4 branch. 94 ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. 95 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 96 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 97 (asdf-version "3.3.4.7") 98 (existing-version (asdf-version))) 99 (setf *asdf-version* asdf-version) 100 (when (and existing-version (not (equal asdf-version existing-version))) 101 (push existing-version *previous-asdf-versions*) 102 (when (or *verbose-out* *load-verbose*) 103 (format (or *verbose-out* *trace-output*) 104 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") 105 existing-version asdf-version))))) 106 107;;; Upon upgrade, specially frob some functions and classes that are being incompatibly redefined 108(when-upgrading () 109 (let* ((previous-version (first *previous-asdf-versions*)) 110 (redefined-functions ;; List of functions that changed incompatibly since 2.27: 111 ;; gf signature changed (should NOT happen), defun that became a generic function, 112 ;; method removed that will mess up with new ones (especially :around :before :after, 113 ;; more specific or call-next-method'ed method) and/or semantics otherwise modified. Oops. 114 ;; NB: it's too late to do anything about functions in UIOP! 115 ;; If you introduce some critical incompatibility there, you must change the function name. 116 ;; Note that we don't need do anything about functions that changed incompatibly 117 ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade. 118 ;; Also note that we don't include the defgeneric=>defun, because they are 119 ;; done directly with defun* and need not trigger a punt on data. 120 ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36 121 `(,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2 122 ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) 123 (redefined-classes 124 ;; redefining the classes causes interim circularities 125 ;; with the old ASDF during upgrade, and many implementations bork 126 #-clozure () 127 #+clozure 128 '((#:compile-concatenated-source-op (#:operation) ()) 129 (#:compile-bundle-op (#:operation) ()) 130 (#:concatenate-source-op (#:operation) ()) 131 (#:dll-op (#:operation) ()) 132 (#:lib-op (#:operation) ()) 133 (#:monolithic-compile-bundle-op (#:operation) ()) 134 (#:monolithic-concatenate-source-op (#:operation) ())))) 135 (loop :for name :in redefined-functions 136 :for sym = (find-symbol* name :asdf nil) 137 :do (when sym (fmakunbound sym))) 138 (labels ((asym (x) (multiple-value-bind (s p) 139 (if (consp x) (values (car x) (cadr x)) (values x :asdf)) 140 (find-symbol* s p nil))) 141 (asyms (l) (mapcar #'asym l))) 142 (loop* :for (name superclasses slots) :in redefined-classes 143 :for sym = (find-symbol* name :asdf nil) 144 :when (and sym (find-class sym)) 145 :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) 146 147 148;;; Self-upgrade functions 149(with-upgradability () 150 ;; This private function is called at the end of asdf/footer and ensures that, 151 ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called. 152 (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*))) 153 (let ((new-version (asdf-version))) 154 (unless (equal old-version new-version) 155 (push new-version *previous-asdf-versions*) 156 (when old-version 157 (if (version<= new-version old-version) 158 (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") 159 old-version new-version) 160 (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") 161 old-version new-version)) 162 ;; In case the previous version was too old to be forward-compatible, clear systems. 163 ;; TODO: if needed, we may have to define a separate hook to run 164 ;; in case of forward-compatible upgrade. 165 ;; Or to move the tests forward-compatibility test inside each hook function? 166 (unless (version<= *oldest-forward-compatible-asdf-version* old-version) 167 (call-functions (reverse *post-upgrade-cleanup-hook*))) 168 t)))) 169 170 (defun upgrade-asdf () 171 "Try to upgrade of ASDF. If a different version was used, return T. 172 We need do that before we operate on anything that may possibly depend on ASDF." 173 (let ((*load-print* nil) 174 (*compile-print* nil)) 175 (handler-bind (((or style-warning) #'muffle-warning)) 176 (symbol-call :asdf :load-system :asdf :verbose nil)))) 177 178 (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body) 179 `(with-upgradability () 180 (with-deprecation ((version-deprecation *asdf-version* ,@keys)) 181 ,@body)))) 182