upgrade.lisp 10.7 KB
Newer Older
1
2
3
4
;;;; -------------------------------------------------------------------------
;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687

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
18
19
20
(in-package :asdf/upgrade)

;;; Special magic to detect if this is an upgrade

21
(with-upgradability ()
22
23
24
25
26
  (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))
27
28
29
30
31
          (let* ((revsym (find-symbol (string :*asdf-revision*) :asdf))
                 (rev (and revsym (boundp revsym) (symbol-value revsym))))
            (etypecase rev
              (string rev)
              (cons (format nil "~{~D~^.~}" rev))
32
              (null "1.0"))))))
33
34
35
  ;; This (private) variable contains a list of versions of previously loaded variants of ASDF,
  ;; from which ASDF was upgraded.
  ;; Important: define *p-a-v* /before/ *a-v* so that they initialize correctly.
36
37
38
  (defvar *previous-asdf-versions*
    (let ((previous (asdf-version)))
      (when previous
39
        ;; Punt on upgrade from ASDF1 or ASDF2, by renaming (or deleting) the package.
40
41
        (when (version< previous "2.27") ;; 2.27 is the first to have the :asdf3 feature.
          (let ((away (format nil "~A-~A" :asdf previous)))
42
            (rename-package :asdf away)
43
            (when *load-verbose*
Robert Goldman's avatar
Robert Goldman committed
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
50
  ;; The latest incompatible defclass is 2.32.13 renaming a slot in component,
  ;; 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
61
  ;; Private function to detect whether the current upgrade counts as an incompatible
  ;; data schema upgrade implying the need to drop data.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
62
63
64
  (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
    (and *previous-asdf-versions*
         (version< (first *previous-asdf-versions*) oldest-compatible-version)))
65
66
67
  ;; Private variant of defparameter that works in presence of incompatible upgrades:
  ;; behaves like defvar in a compatible upgrade (e.g. reloading system after simple code change),
  ;; but behaves like defparameter if in presence of an incompatible upgrade.
68
69
70
71
72
73
74
75
  (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
    (let* ((name (string-trim "*" var))
           (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
      `(progn
         (defun ,valfun () ,value)
         (defvar ,var (,valfun) ,@(ensure-list docstring))
         (when (upgrading-p ,version)
           (setf ,var (,valfun))))))
76
77
78
  ;; Private macro to declare sections of code that are only compiled and run when upgrading.
  ;; The use of eval portably ensures that the code will not have adverse compile-time side-effects,
  ;; whereas the use of handler-bind portably ensures that it will not issue warnings when it runs.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
79
80
  (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
                               (upgrading-p `(upgrading-p ,version)) when) &body body)
81
    "A wrapper macro for code that should only be run when upgrading a
82
previously-loaded version of ASDF."
83
    `(with-upgradability ()
84
85
       (when (and ,upgrading-p ,@(when when `(,when)))
         (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
93
         ;; "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.
94
         ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5.
95
96
         ;; "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
Robert Goldman's avatar
Robert Goldman committed
97
         (asdf-version "3.3.4.18")
98
         (existing-version (asdf-version)))
99
    (setf *asdf-version* asdf-version)
100
101
    (when (and existing-version (not (equal asdf-version existing-version)))
      (push existing-version *previous-asdf-versions*)
102
103
      (when (or *verbose-out* *load-verbose*)
        (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
112
          ;; gf signature changed, defun that became a generic function (but not way around),
          ;; method removed that will mess up with new ones
113
114
          ;; (especially :around :before :after, more specific or call-next-method'ed method)
          ;; and/or semantics otherwise modified. Oops.
115
          ;; NB: it's too late to do anything about functions in UIOP!
116
          ;; If you introduce some critical incompatibility there, you MUST change the function name.
117
118
          ;; Note that we don't need do anything about functions that changed incompatibly
          ;; from ASDF 2.26 or earlier: we wholly punt on the entire ASDF package in such an upgrade.
119
120
          ;; Also, the strong constraints apply most importantly for functions called from
          ;; the continuation of compiling or loading some of the code in ASDF or UIOP.
121
          ;; See discussion at https://gitlab.common-lisp.net/asdf/asdf/merge_requests/36
122
123
124
          ;; and at https://gitlab.common-lisp.net/asdf/asdf/-/merge_requests/141
          `(,@(when (version< previous-version "2.31") '(#:normalize-version)) ;; pathname became &key
            ,@(when (version< previous-version "3.1.2") '(#:component-depends-on #:input-files)) ;; crucial methods *removed* before 3.1.2
125
            ,@(when (version< previous-version "3.1.7.20") '(#:find-component)))) ;; added &key registered
126
127
         (redefined-classes
          ;; with the old ASDF during upgrade, and many implementations bork
128
129
130
131
132
133
134
135
          (when (or #+(or clozure mkcl) t)
            '((#:compile-concatenated-source-op (#:operation) ())
              (#:compile-bundle-op (#:operation) ())
              (#:concatenate-source-op (#:operation) ())
              (#:dll-op (#:operation) ())
              (#:lib-op (#:operation) ())
              (#:monolithic-compile-bundle-op (#:operation) ())
              (#:monolithic-concatenate-source-op (#:operation) ())))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
136
    (loop :for name :in redefined-functions
137
138
139
140
      :for sym = (find-symbol* name :asdf nil)
      :do (when sym (fmakunbound sym)))
    (labels ((asym (x) (multiple-value-bind (s p)
                           (if (consp x) (values (car x) (cadr x)) (values x :asdf))
141
142
                         (find-symbol* s p nil)))
             (asyms (l) (mapcar #'asym l)))
143
144
145
146
147
      (loop* :for (name superclasses slots) :in redefined-classes
             :for sym = (find-symbol* name :asdf nil)
             :when (and sym (find-class sym))
             :do #+ccl (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots)))
             #-ccl (setf (find-class sym) nil))))) ;; mkcl
148

149
;;; Self-upgrade functions
150
(with-upgradability ()
151
152
  ;; This private function is called at the end of asdf/footer and ensures that,
  ;; *if* this loading of ASDF was an upgrade, then all registered cleanup functions will be called.
153
154
155
156
157
  (defun cleanup-upgraded-asdf (&optional (old-version (first *previous-asdf-versions*)))
    (let ((new-version (asdf-version)))
      (unless (equal old-version new-version)
        (push new-version *previous-asdf-versions*)
        (when old-version
158
159
160
161
162
          (if (version<= new-version old-version)
              (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
                     old-version new-version)
              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
                            old-version new-version))
163
164
165
166
167
168
          ;; 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*)))
169
          t))))
170

171
172
  (defun upgrade-asdf ()
    "Try to upgrade of ASDF. If a different version was used, return T.
173
   We need do that before we operate on anything that may possibly depend on ASDF."
174
175
    (let ((*load-print* nil)
          (*compile-print* nil))
176
      (handler-bind (((or style-warning) #'muffle-warning))
177
178
179
180
181
182
        (symbol-call :asdf :load-system :asdf :verbose nil))))

  (defmacro with-asdf-deprecation ((&rest keys &key &allow-other-keys) &body body)
    `(with-upgradability ()
       (with-deprecation ((version-deprecation *asdf-version* ,@keys))
         ,@body))))