upgrade.lisp 7.17 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 31 32 33 34 35 36 37
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
         ;; 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.126")
39
         (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
40
         (existing-version *asdf-version*)
41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
         (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
             #:apply-output-translations
             #:system-relative-pathname
             #: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
    (when (and existing-asdf (not already-there))
61 62
      (when existing-asdf
        (asdf-message "~&; Upgrading ASDF ~@[from version ~A ~]to version ~A~%"
63
                      existing-version asdf-version)
64
        (push existing-version *upgraded-p*))
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
      ;;(format t "UPGRADE FROBBING! ~S~%" (list existing-asdf existing-version asdf-version)) ;XXX
      (loop :for name :in (append #-(or clisp ecl) redefined-functions)
              :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
        #+(or clisp 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 "-"))))
    (setf *asdf-version* asdf-version)))
94

95

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

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

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