operate.lisp 9.91 KB
Newer Older
1 2
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
3

4
(uiop/package:define-package :asdf/operate
5
  (:recycle :asdf/operate :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache
7 8
   :asdf/component :asdf/system :asdf/operation :asdf/action
   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
9
  (:export
10
   #:operate #:oos
11
   #:*systems-being-operated*
12
   #:build-system
13 14
   #:load-system #:load-systems #:load-systems*
   #:compile-system #:test-system #:require-system
15
   #:*load-system-operation* #:module-provide-asdf
16
   #:component-loaded-p #:already-loaded-systems))
17 18
(in-package :asdf/operate)

19
(with-upgradability ()
20 21 22
  (defgeneric* (operate) (operation component &key &allow-other-keys)
    (:documentation
     "Operate does three things:
23 24 25

1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
2. It finds the  asdf-system specified by SYSTEM (possibly loading it from disk).
26
3. It then calls MAKE-PLAN with the operation and system as arguments
27

28 29 30
The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error
handling code.  If a VERSION argument is supplied, then operate also ensures
that the system found satisfies it using the VERSION-SATISFIES method.
31 32 33 34 35 36 37 38 39

Note that dependencies may cause the operation to invoke other operations on the system
or its components: the new operations will be created with the same initargs as the original one.

The :FORCE or :FORCE-NOT argument to OPERATE can be:
  T to force the inside of the specified system to be rebuilt (resp. not),
    without recursively forcing the other systems we depend on.
  :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
  (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))

  (define-convenience-action-methods
      operate (operation component &key)
      ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
      ;; but swank.asd relies on :force (!).
      :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
      :if-no-component (error 'missing-component :requires component))

  (defvar *systems-being-operated* nil
    "A boolean indicating that some systems are being operated on")

  (defmethod operate :around (operation component &rest keys
                              &key verbose
                                (on-warnings *compile-file-warnings-behaviour*)
                                (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
    (let* ((systems-being-operated *systems-being-operated*)
57
           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
58 59 60
           (operation-name (reify-symbol (etypecase operation
                                           (operation (type-of operation))
                                           (symbol operation))))
61
           (operation-initargs (operation-original-initargs operation))
62 63 64
           (component-path (typecase component
                             (component (component-find-path component))
                             (t component))))
65 66 67
      ;; Before we operate on any system, make sure ASDF is up-to-date,
      ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
      (unless systems-being-operated
68 69 70 71 72
        (when (upgrade-asdf)
          ;; If we were upgraded, restart OPERATE the hardest of ways, for
          ;; its function may have been redefined, its symbol uninterned, its package deleted.
          (return-from operate
            (apply (find-symbol* 'operate :asdf)
73 74 75
                   (apply (find-symbol* 'make-operation :asdf)
                          (unreify-symbol operation-name)
                          :original-initargs operation-initargs operation-initargs)
76 77
                   component-path keys))))
      ;; Setup proper bindings around any operate call.
78
      (with-asdf-cache ()
79 80 81 82 83 84 85 86 87 88 89 90 91
        (let* ((*verbose-out* (and verbose *standard-output*))
               (*compile-file-warnings-behaviour* on-warnings)
               (*compile-file-failure-behaviour* on-failure))
          (call-next-method)))))

  (defmethod operate :before ((operation operation) (component component)
                              &key version &allow-other-keys)
    (let ((system (component-system component)))
      (setf (gethash (coerce-name system) *systems-being-operated*) system))
    (unless (version-satisfies component version)
      (error 'missing-component-of-version :requires component :version version)))

  (defmethod operate ((operation operation) (component component)
92 93
                      &rest keys &key plan-class &allow-other-keys)
    (let ((plan (apply 'make-plan plan-class operation component keys)))
94
      (apply 'perform-plan plan keys)
95
      (values operation plan)))
96 97 98 99 100 101 102

  (defun oos (operation component &rest args &key &allow-other-keys)
    (apply 'operate operation component args))

  (setf (documentation 'oos 'function)
        (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
                (documentation 'operate 'function))))
103 104 105


;;;; Common operations
106 107 108
(with-upgradability ()
  (defvar *load-system-operation* 'load-op
    "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
109
You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
110 111 112 113
or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.

This may change in the future as we will implement component-based strategy
for how to load or compile stuff")
114

115 116 117 118
  (defun build-system (system &rest keys)
    "Shorthand for `(operate 'asdf:build-op system)`."
    (apply 'operate 'build-op system keys)
    t)
119

120 121 122 123 124
  (defun load-system (system &rest keys &key force force-not verbose version &allow-other-keys)
    "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for details."
    (declare (ignore force force-not verbose version))
    (apply 'operate *load-system-operation* system keys)
    t)
125

126 127 128 129
  (defun load-systems* (systems &rest keys)
    "Loading multiple systems at once."
    (dolist (s systems) (apply 'load-system s keys)))

130 131
  (defun load-systems (&rest systems)
    "Loading multiple systems at once."
132
    (load-systems* systems))
133

134 135 136 137 138
  (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys)
    "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details."
    (declare (ignore force force-not verbose version))
    (apply 'operate 'compile-op system args)
    t)
139

140 141 142 143 144
  (defun test-system (system &rest args &key force force-not verbose version &allow-other-keys)
    "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for details."
    (declare (ignore force force-not verbose version))
    (apply 'operate 'test-op system args)
    t))
145 146


147
;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
148
;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
149 150 151 152 153 154 155 156 157 158
(with-upgradability ()
  (defun component-loaded-p (c)
    (action-already-done-p nil (make-instance 'load-op) (find-component c ())))

  (defun already-loaded-systems ()
    (remove-if-not 'component-loaded-p (registered-systems)))

  (defun require-system (s &rest keys &key &allow-other-keys)
    (apply 'load-system s :force-not (already-loaded-systems) keys))

159 160 161
  (defvar *modules-being-required* nil)

  (defclass require-system (system)
162 163 164
    ((module :initarg :module :initform nil :accessor required-module))
    (:documentation "A SYSTEM subclass whose processing is handled by
the implementation's REQUIRE rather than by internal ASDF mechanisms."))
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179

  (defmethod perform ((o compile-op) (c require-system))
    nil)

  (defmethod perform ((o load-op) (s require-system))
    (let* ((module (or (required-module s) (coerce-name s)))
           (*modules-being-required* (cons module *modules-being-required*)))
      (assert (null (component-children s)))
      (require module)))

  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
    (unless (length=n-p arguments 1)
      (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
             (cons combinator arguments) component combinator))
    (let* ((module (car arguments))
180 181
           (name (string-downcase module))
           (system (find-system name nil)))
182
      (assert module)
183 184 185 186 187 188
      ;;(unless (typep system '(or null require-system))
      ;;  (warn "~S depends on ~S but ~S is registered as a ~S"
      ;;        component (cons combinator arguments) module (type-of system)))
      (or system (let ((system (make-instance 'require-system :name name)))
                   (register-system system)
                   system))))
189

190
  (defun module-provide-asdf (name)
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205
    (let ((module (string-downcase name)))
      (unless (member module *modules-being-required* :test 'equal)
        (let ((*modules-being-required* (cons module *modules-being-required*))
              #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal)))
          (handler-bind
              ((style-warning #'muffle-warning)
               (missing-component (constantly nil))
               (error #'(lambda (e)
                          (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                                  name e))))
            (let ((*verbose-out* (make-broadcast-stream)))
              (let ((system (find-system module nil)))
                (when system
                  (require-system system :verbose nil)
                  t)))))))))
206

207 208

;;;; Some upgrade magic
209 210 211
(with-upgradability ()
  (defun restart-upgraded-asdf ()
    ;; If we're in the middle of something, restart it.
212 213 214 215
    (when *asdf-cache*
      (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
                      :when (eq x 'find-system) :collect y)))
        (clrhash *asdf-cache*)
216
        (dolist (s l) (find-system s nil)))))
217
  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
218 219