upgrade.lisp 7.09 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 :asdf/common-lisp :asdf/driver)
8
  (:export
9
   #:asdf-version #:*previous-asdf-versions* #:*asdf-version*
10
   #:asdf-message #:*verbose-out*
11 12
   #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error
   #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf
13
   ;; There will be no symbol left behind!
14
   #:intern*)
15
  (:import-from :asdf/package #:intern* #:find-symbol*))
16 17 18 19
(in-package :asdf/upgrade)

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

20
(with-upgradability ()
21 22 23 24 25
  (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))
26 27 28 29 30
          (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))
31
              (null "1.0"))))))
32
  (defvar *asdf-version* nil)
33
  (defvar *previous-asdf-versions* nil)
34
  (defvar *verbose-out* nil)
35
  (defun asdf-message (format-string &rest format-args)
36
    (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
37 38
  (defvar *post-upgrade-cleanup-hook* ())
  (defvar *post-upgrade-restart-hook* ())
39
  (defun upgrading-p ()
40 41
    (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*)))))
  (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body)
42
    `(with-upgradability ()
43 44
       (when (and ,upgrading-p ,@(when when `(,when)))
         (handler-bind ((style-warning #'muffle-warning))
45
           (eval '(progn ,@body))))))
46
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
47
         ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8
48 49
         ;; 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.
50 51 52 53 54
         ;; "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.
         ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
         ;; "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
55
         (asdf-version "2.32.26")
56
         (existing-version (asdf-version)))
57
    (setf *asdf-version* asdf-version)
58 59
    (when (and existing-version (not (equal asdf-version existing-version)))
      (push existing-version *previous-asdf-versions*)
60
      (when (or *load-verbose* *verbose-out*)
61 62
        (format *trace-output*
                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
63
                existing-version asdf-version)))))
64 65 66 67 68 69

(when-upgrading ()
  (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops.
          '(#:component-relative-pathname #:component-parent-pathname ;; component
            #:source-file-type
            #:find-system #:system-source-file #:system-relative-pathname ;; system
70 71
             #:find-component ;; find-component
             #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
72
             #:component-depends-on #:operation-done-p #:component-depends-on
73 74
             #:traverse ;; plan
             #:operate  ;; operate
75
             #:parse-component-form ;; defsystem
76
             #:apply-output-translations ;; output-translations
77
             #:process-output-translations-directive
78
             #:inherit-source-registry #:process-source-registry ;; source-registry
79
             #:process-source-registry-directive
80
             #:trivial-system-p ;; bundle
81
             ;; NB: it's too late to do anything about asdf-driver functions!
82 83 84 85
             ))
         (uninterned-symbols
           '(#:*asdf-revision* #:around #:asdf-method-combination
             #:split #:make-collector #:do-dep #:do-one-dep
86
             #:component-self-dependencies
87 88
             #:resolve-relative-location-component #:resolve-absolute-location-component
             #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
89
    (declare (ignorable redefined-functions uninterned-symbols))
90
    (loop :for name :in (append redefined-functions)
91 92
          :for sym = (find-symbol* name :asdf nil) :do
            (when sym
93 94
              ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
              #-clisp (fmakunbound sym)))
95
    (loop :with asdf = (find-package :asdf)
96
          :for name :in uninterned-symbols
97 98 99 100 101 102 103 104 105 106 107
          :for sym = (find-symbol* name :asdf nil)
          :for base-pkg = (and sym (symbol-package sym)) :do
            (when sym
              (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))))))))
108

109

110
;;; Self-upgrade functions
111

112 113 114 115 116
(with-upgradability ()
  (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)~%~
117
          Otherwise, when you upgrade from ASDF 2, you must do it before you operate on any system.~%"))
118

119 120 121 122 123
  (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
124 125 126 127 128
          (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))
129 130
          (call-functions (reverse *post-upgrade-cleanup-hook*))
          t))))
131

132 133
  (defun upgrade-asdf ()
    "Try to upgrade of ASDF. If a different version was used, return T.
134
   We need do that before we operate on anything that may possibly depend on ASDF."
135 136
    (let ((*load-print* nil)
          (*compile-print* nil))
137
      (handler-bind (((or style-warning) #'muffle-warning))
138 139 140
        (symbol-call :asdf :load-system :asdf :verbose nil))))

  (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
141