operate.lisp 14.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
   #:build-op #:make
12
13
   #:load-system #:load-systems #:load-systems*
   #:compile-system #:test-system #:require-system
14
   #:*load-system-operation* #:module-provide-asdf
15
   #:component-loaded-p #:already-loaded-systems))
16
17
(in-package :asdf/operate)

18
(with-upgradability ()
19
  (defgeneric operate (operation component &key &allow-other-keys)
20
    (:documentation
21
     "Operate does mainly four things for the user:
22

23
24
25
26
27
28
1. Resolves the OPERATION designator into an operation object.
   OPERATION is typically a symbol denoting an operation class, instantiated with MAKE-OPERATION.
2. Resolves the COMPONENT designator into a component object.
   COMPONENT is typically a string or symbol naming a system, loaded from disk using FIND-SYSTEM.
3. It then calls MAKE-PLAN with the operation and system as arguments.
4. Finally calls PERFORM-PLAN on the resulting plan to actually build the system.
29

30
31
32
33
The entire computation 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.
If a PLAN-CLASS argument is supplied, that class is used for the plan.
34
35
36
37
38
39

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
:FORCE-NOT has precedence over :FORCE; builtin systems cannot be forced.

For backward compatibility, all keyword arguments are passed to MAKE-OPERATION
when instantiating a new operation, that will in turn be inherited by new operations.
But do NOT depend on it, for this is deprecated behavior."))
45

46
47
48
49
50
  (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. Deprecated.
    :if-no-component (error 'missing-component :requires component))
51

52
53
  (defvar *in-operate* nil
    "Are we in operate?")
54

55
56
57
  ;; This method ensures that an ASDF upgrade is attempted as the very first thing,
  ;; with suitable state preservation in case in case it actually happens,
  ;; and that a few suitable dynamic bindings are established.
58
59
60
61
  (defmethod operate :around (operation component &rest keys
                              &key verbose
                                (on-warnings *compile-file-warnings-behaviour*)
                                (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
62
63
64
65
    (nest
     (with-asdf-cache ())
     (let ((in-operate *in-operate*)
           (*in-operate* t)
66
           (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
67
68
69
70
71
            (etypecase operation
              (operation (let ((name (type-of operation))
                               (initargs (operation-original-initargs operation)))
                           #'(lambda () (apply 'make-operation name :original-initargs initargs initargs))))
              ((or symbol string) (constantly operation))))
72
           (component-path (typecase component ;; to remake the component after ASDF upgrade
73
                             (component (component-find-path component))
74
75
76
77
78
79
80
81
82
83
                             (t component)))))
     ;; 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.
     (progn
       (unless in-operate
         (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 'operate (funcall operation-remaker) component-path keys)))))
84
      ;; Setup proper bindings around any operate call.
85
86
87
88
     (let* ((*verbose-out* (and verbose *standard-output*))
            (*compile-file-warnings-behaviour* on-warnings)
            (*compile-file-failure-behaviour* on-failure))
       (call-next-method))))
89
90
91
92
93
94
95

  (defmethod operate :before ((operation operation) (component component)
                              &key version &allow-other-keys)
    (unless (version-satisfies component version)
      (error 'missing-component-of-version :requires component :version version)))

  (defmethod operate ((operation operation) (component component)
96
97
                      &rest keys &key plan-class &allow-other-keys)
    (let ((plan (apply 'make-plan plan-class operation component keys)))
98
      (apply 'perform-plan plan keys)
99
      (values operation plan)))
100
101
102
103
104
105
106

  (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))))
107
108
109


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

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

119
  ;; In prepare-op for a system, propagate *load-system-operation* rather than load-op
120
  (defmethod component-depends-on ((o prepare-op) (s system))
121
122
    (loop :for (do . dc) :in (call-next-method)
          :collect (cons (if (eq do 'load-op) *load-system-operation* do) dc)))
123

124
  (defclass build-op (non-propagating-operation) ()
125
126
127
128
129
130
131
    (: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."))
132
  (defmethod component-depends-on ((o build-op) (c component))
133
134
    `((,(or (component-build-operation c) *load-system-operation*) ,c)
      ,@(call-next-method)))
135

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

145
146
147
148
149
  (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)
150

151
152
153
154
  (defun load-systems* (systems &rest keys)
    "Loading multiple systems at once."
    (dolist (s systems) (apply 'load-system s keys)))

155
156
  (defun load-systems (&rest systems)
    "Loading multiple systems at once."
157
    (load-systems* systems))
158

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

165
166
167
168
169
  (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))
170

171
172
;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
;; only tries to load its specified target if it's not loaded yet.
173
(with-upgradability ()
174
  (defun component-loaded-p (component)
Robert Goldman's avatar
Robert Goldman committed
175
    "Has the given COMPONENT been successfully loaded in the current image (yet)?
176
Note that this returns true even if the component is not up to date."
177
    (if-let ((component (find-component component () :registered t)))
178
      (action-already-done-p nil (make-operation 'load-op) component)))
179
180

  (defun already-loaded-systems ()
181
    "return a list of the names of the systems that have been successfully loaded so far"
182
    (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))
183

184
  (defun require-system (system &rest keys &key &allow-other-keys)
Robert Goldman's avatar
Robert Goldman committed
185
    "Ensure the specified SYSTEM is loaded, passing the KEYS to OPERATE, but do not update the
186
system or its dependencies if they have already been loaded."
187
188
    (unless (component-loaded-p system)
      (apply 'load-system system :force-not (already-loaded-systems) keys))))
189

190

191
192
;;;; Define the class REQUIRE-SYSTEM, to be hooked into CL:REQUIRE when possible,
;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
193
194
;; Note that despite the two being homonyms, the _function_ require-system
;; and the _class_ require-system are quite distinct entities, fulfilling independent purposes.
195
(with-upgradability ()
196
197
198
  (defvar *modules-being-required* nil)

  (defclass require-system (system)
199
200
201
    ((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."))
202
203
204
205
206
207
208
209

  (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)))
210
      ;; CMUCL likes its module names to be all upcase.
211
      (require (nest #+cmucl (string-upcase) module))))
212
213

  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
214
    (unless (and (length=n-p arguments 1)
Robert Goldman's avatar
Robert Goldman committed
215
                 (typep (car arguments) '(or string (and symbol (not null)))))
216
217
218
      (parameter-error (compatfmt "~@<In ~S, bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
                       'resolve-dependency-combination
                       (cons combinator arguments) component combinator))
219
220
221
222
223
224
    ;; :require must be prepared for some implementations providing modules using ASDF,
    ;; as SBCL used to do, and others may might do. Thus, the system provided in the end
    ;; would be a downcased name as per module-provide-asdf above. For the same reason,
    ;; we cannot assume that the system in the end will be of type require-system,
    ;; but must check whether we can use find-system and short-circuit cl:require.
    ;; Otherwise, calling cl:require could result in nasty reentrant calls between
225
226
    ;; cl:require and asdf:operate that could potentially blow up the stack,
    ;; all the while defeating the consistency of the dependency graph.
227
    (let* ((module (car arguments)) ;; NB: we already checked that it was not null
228
229
230
231
232
           (name (string-downcase module))
           (system (find-system name nil)))
      (or system (let ((system (make-instance 'require-system :name name)))
                   (register-system system)
                   system))))
233

234
  (defun module-provide-asdf (name)
235
236
237
238
239
    ;; We must use string-downcase, because modules are traditionally specified as symbols,
    ;; that implementations traditionally normalize as uppercase, for which we seek a system
    ;; with a name that is traditionally in lowercase. Case is lost along the way. That's fine.
    ;; We could make complex, non-portable rules to try to preserve case, and just documenting
    ;; them would be a hell that it would be a disservice to inflict on users.
240
241
242
243
244
245
246
    (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))
247
               (fatal-condition
Robert Goldman's avatar
Robert Goldman committed
248
249
250
                #'(lambda (e)
                    (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                            name e))))
251
252
253
254
255
            (let ((*verbose-out* (make-broadcast-stream)))
              (let ((system (find-system module nil)))
                (when system
                  (require-system system :verbose nil)
                  t)))))))))
256

257
258

;;;; Some upgrade magic
259
260
261
(with-upgradability ()
  (defun restart-upgraded-asdf ()
    ;; If we're in the middle of something, restart it.
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
262
263
264
265
266
267
268
269
270
271
272
273
274
    (let ((systems-being-defined
           (when *asdf-cache*
             (prog1
                 (loop :for k :being :the hash-keys :of *asdf-cache*
                   :when (eq (first k) 'find-system) :collect (second k))
               (clrhash *asdf-cache*)))))
      ;; Regardless, clear defined systems, since they might be invalid
      ;; after an incompatible ASDF upgrade.
      (clear-defined-systems)
      ;; The configuration also may have to be upgraded.
      (upgrade-configuration)
      ;; If we were in the middle of an operation, be sure to restore the system being defined.
      (dolist (s systems-being-defined) (find-system s nil))))
275
  (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf)
276
277
278
279
280

  ;; The following function's symbol is from asdf/find-system.
  ;; It is defined here to resolve what would otherwise be forward package references.
  (defun mark-component-preloaded (component)
    "Mark a component as preloaded."
281
282
283
284
285
286
287
    (let ((component (find-component component nil :registered t)))
      ;; Recurse to children, so asdf/plan will hopefully be happy.
      (map () 'mark-component-preloaded (component-children component))
      ;; Mark the timestamps of the common lisp-action operations as 0.
      (let ((times (component-operation-times component)))
        (dolist (o '(load-op compile-op prepare-op))
          (setf (gethash o times) 0))))))
288