operate.lisp 12.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
    (mapcar 'coerce-name (remove-if-not 'component-loaded-p (registered-systems*))))
174

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

  (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)
201
202
203
    (unless (and (length=n-p arguments 1)
		 (typep (car argument) '(or string (and symbol (not null)))))
      (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes one argument, a string or non-null symbol~@:>")
204
             (cons combinator arguments) component combinator))
205
206
207
208
209
210
211
    ;; :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
    ;; cl:require and asdf:operate that could potentially blow up the stack.
212
    (let* ((module (car arguments))
213
214
           (name (string-downcase module))
           (system (find-system name nil)))
215
      (assert module)
216
217
218
      (or system (let ((system (make-instance 'require-system :name name)))
                   (register-system system)
                   system))))
219

220
  (defun module-provide-asdf (name)
221
222
223
224
225
    ;; 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.
226
227
228
229
230
231
232
    (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))
233
               (uiop:fatal-condition #'(lambda (e)
234
235
236
237
238
239
240
                          (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)))))))))
241

242
243

;;;; Some upgrade magic
244
245
246
(with-upgradability ()
  (defun restart-upgraded-asdf ()
    ;; If we're in the middle of something, restart it.
247
    (when *asdf-cache*
248
249
      (let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
                     :when (eq (first k) 'find-system) :collect (second k))))
250
        (clrhash *asdf-cache*)
251
        (dolist (s l) (find-system s nil)))))
252
  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
253
254