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.129")
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)))