upgrade.lisp 7.41 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
6
(asdf/package:define-package :asdf/upgrade
  (:recycle :asdf/upgrade :asdf)
7
  (:use :common-lisp :asdf/package :asdf/compatibility :asdf/utility)
8
  (:export
9
   #:upgrade-asdf #:asdf-upgrade-error #:when-upgrade
10
   #:*asdf-upgrade-already-attempted*
11
   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
12
   #:asdf-version #:*upgraded-p* #:*asdf-version*
13
14
   #:asdf-message #:*asdf-verbose* #:*verbose-out*
   ;; There will be no symbol left behind!
15
   #:intern*)
16
  (:import-from :asdf/package #:intern* #:find-symbol*))
17
18
19
20
21
22
23
(in-package :asdf/upgrade)

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

(eval-when (:load-toplevel :compile-toplevel :execute)
  (defvar *asdf-version* nil)
  (defvar *upgraded-p* nil)
24
25
  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
  (defvar *verbose-out* nil)
26
  (defun* asdf-message (format-string &rest format-args)
27
    (apply 'format *verbose-out* format-string format-args)))
28

29
(eval-when (:load-toplevel :compile-toplevel :execute)
30
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
31
         ;; Please also modify asdf.asd to reflect this change. make bump-version
32
33
34
35
36
37
         ;; 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
38
         (asdf-version "2.26.139")
39
         (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
40
         (existing-version *asdf-version*)
41
42
         (already-there (equal asdf-version existing-version))
         (redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
43
44
45
46
47
48
49
50
51
           '(#: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
             #:traverse ;; plan
             #:operate  ;; operate
             #:apply-output-translations ;; output-translations
52
             #:process-output-translations-directive
53
54
55
             #:inherit-source-registry #:process-source-registry ;; source-registry
             #:process-source-registry-directive 
             #:trivial-system-p ;; bundle
56
             ;; NB: it's too late to do anything about asdf-driver functions!
57
58
59
60
61
62
             ))
         (uninterned-symbols
           '(#:*asdf-revision* #:around #:asdf-method-combination
             #:split #:make-collector #:do-dep #:do-one-dep
             #:resolve-relative-location-component #:resolve-absolute-location-component
             #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
63
64
    (declare (ignorable redefined-functions uninterned-symbols))
    (setf *asdf-version* asdf-version)
65
    (when (and existing-asdf (not already-there))
66
67
68
69
70
      (push existing-version *upgraded-p*)
      (when *asdf-verbose*
        (format *trace-output*
                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
                existing-version asdf-version))
71
      (loop :for name :in (append #-(or clisp ecl) redefined-functions)
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
              :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
92
        #+(or xcl)
93
94
95
96
        (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))
97
                         :index 0 :separator "-"))))))
98

99

100
101
102
103
104
105
106
;;; Upgrade interface

(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.~%"))
107

108
(defmacro when-upgrade ((&key (upgraded-p '*upgraded-p*) when) &body body)
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
  `(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

(defvar *post-upgrade-cleanup-hook* ())
(defvar *post-upgrade-restart-hook* ())

126
(defun* cleanup-upgraded-asdf (old-version)
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
  (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)))

(defun* upgrade-asdf ()
  "Try to upgrade of ASDF. If a different version was used, return T.
147
   We need do that before we operate on anything that may possibly depend on ASDF."
148
149
150
151
152
153
  (let ((version (asdf-version))
        (*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)))