operate.lisp 11.6 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-op #:make
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 61
           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
             (etypecase operation
               (operation (let ((name (type-of operation))
                                (initargs (operation-original-initargs operation)))
62
                            #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
63 64
               ((or symbol string) (constantly operation))))
           (component-path (typecase component ;; to remake the component after ASDF upgrade
65 66
                             (component (component-find-path component))
                             (t component))))
67 68 69
      ;; 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
70 71 72 73
        (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
74
            (apply 'operate (funcall operation-remaker) component-path keys))))
75
      ;; Setup proper bindings around any operate call.
76
      (with-asdf-cache ()
77 78 79 80 81 82 83 84 85 86 87 88 89
        (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)
90 91
                      &rest keys &key plan-class &allow-other-keys)
    (let ((plan (apply 'make-plan plan-class operation component keys)))
92
      (apply 'perform-plan plan keys)
93
      (values operation plan)))
94 95 96 97 98 99 100

  (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))))
101 102 103


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

110 111
The default operation may change in the future if we implement a
component-directed strategy for how to load or compile systems.")
112

113
  (defmethod component-depends-on ((o prepare-op) (s system))
114 115
    (loop :for (o . cs) :in (call-next-method)
          :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs)))
116

117
  (defclass build-op (non-propagating-operation) ()
118 119 120 121 122 123 124
    (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation,
to operate by default on a system or component, via the function BUILD.
Its meaning is configurable via the :BUILD-OPERATION option of a component.
which typically specifies the name of a specific operation to which to delegate the build,
as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on);
if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION*
that will load the system in the current image, and its typically LOAD-OP."))
125
  (defmethod component-depends-on ((o build-op) (c component))
126 127
    `((,(or (component-build-operation c) *load-system-operation*) ,c)
      ,@(call-next-method)))
128

129 130
  (defun make (system &rest keys)
    "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
131 132
It will build system FOO using the operation BUILD-OP,
the meaning of which is configurable by the system, and
133 134
defaults to *LOAD-SYSTEM-OPERATION*, usually LOAD-OP,
to load it in current image."
135 136
    (apply 'operate 'build-op system keys)
    t)
137

138 139 140 141 142
  (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)
143

144 145 146 147
  (defun load-systems* (systems &rest keys)
    "Loading multiple systems at once."
    (dolist (s systems) (apply 'load-system s keys)))

148 149
  (defun load-systems (&rest systems)
    "Loading multiple systems at once."
150
    (load-systems* systems))
151

152 153 154 155 156
  (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)
157

158 159 160 161 162
  (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))
163

164 165
;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
;; only tries to load its specified target if it's not loaded yet.
166
(with-upgradability ()
167 168 169
  (defun component-loaded-p (component)
    "has given COMPONENT been successfully loaded in the current image (yet)?"
    (action-already-done-p nil (make-instance 'load-op) (find-component component ())))
170 171

  (defun already-loaded-systems ()
172
    "return a list of the names of the systems that have been successfully loaded so far"
173 174
    (remove-if-not 'component-loaded-p (registered-systems)))

175 176 177 178 179
  (defun require-system (system &rest keys &key &allow-other-keys)
    "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but skip any update to the
system or its dependencies if they have already been loaded."
    (apply 'load-system system :force-not (already-loaded-systems) keys)))

180

181 182 183
;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
(with-upgradability ()
184 185 186
  (defvar *modules-being-required* nil)

  (defclass require-system (system)
187 188 189
    ((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."))
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204

  (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))
205 206
           (name (string-downcase module))
           (system (find-system name nil)))
207
      (assert module)
208 209 210 211 212 213
      ;;(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))))
214

215
  (defun module-provide-asdf (name)
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230
    (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)))))))))
231

232 233

;;;; Some upgrade magic
234 235 236
(with-upgradability ()
  (defun restart-upgraded-asdf ()
    ;; If we're in the middle of something, restart it.
237
    (when *asdf-cache*
238 239
      (let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
                     :when (eq (first k) 'find-system) :collect (second k))))
240
        (clrhash *asdf-cache*)
241
        (dolist (s l) (find-system s nil)))))
242
  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
243 244