upgrade.lisp 7.2 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.131")
39
         (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
40
         (existing-version *asdf-version*)
41
42
43
44
45
46
47
         (already-there (equal asdf-version existing-version))
         (redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
           '(#:perform #:explain #:output-files #:operation-done-p
             #:component-parent-pathname #:traverse
             #:component-depends-on #:input-files
             #:perform-with-restarts #:component-relative-pathname
             #:system-source-file #:operate #:find-component #:find-system
48
             #:apply-output-translations #:component-self-dependencies
49
             #:system-relative-pathname #:resolve-location
50
51
52
53
54
55
56
57
58
59
             #:inherit-source-registry #:process-source-registry
             #:process-source-registry-directive #:source-file-type
             #:process-output-translations-directive
             #:trivial-system-p
             ))
         (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
60
61
    (declare (ignorable redefined-functions uninterned-symbols))
    (setf *asdf-version* asdf-version)
62
    (when (and existing-asdf (not already-there))
63
64
65
66
67
      (push existing-version *upgraded-p*)
      (when *asdf-verbose*
        (format *trace-output*
                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
                existing-version asdf-version))
68
      (loop :for name :in (append #-(or clisp ecl) redefined-functions)
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
              :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
89
        #+(or xcl)
90
91
92
93
        (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))
94
                         :index 0 :separator "-"))))))
95

96

97
98
99
100
101
102
103
;;; 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.~%"))
104

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

123
(defun* cleanup-upgraded-asdf (old-version)
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
  (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.
144
   We need do that before we operate on anything that may possibly depend on ASDF."
145
146
147
148
149
150
  (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)))