operate.lisp 14.4 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/session
7
        :asdf/component :asdf/system :asdf/system-registry :asdf/find-component
8
        :asdf/operation :asdf/action :asdf/lisp-action :asdf/forcing :asdf/plan)
9
  (:export
10
   #:operate #:oos #:build-op #:make
11
   #:load-system #:load-systems #:load-systems*
12
   #:compile-system #:test-system #:require-system #:module-provide-asdf
13 14
   #:component-loaded-p #:already-loaded-systems
   #:recursive-operate))
15 16
(in-package :asdf/operate)

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

22 23 24 25 26 27
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.
28

29 30 31 32
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.
33
If a PLAN-OPTIONS argument is supplied, the options are passed to 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
  (define-convenience-action-methods operate (operation component &key)
    :if-no-component (error 'missing-component :requires component))
48

49 50 51
  ;; 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.
52 53 54
  (defmethod operate :around (operation component &rest keys
                              &key verbose
                                (on-warnings *compile-file-warnings-behaviour*)
55
                                (on-failure *compile-file-failure-behaviour*))
56
    (nest
57
     (with-asdf-session ())
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
     (let* ((operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was)
             (etypecase operation
               (operation (let ((name (type-of operation)))
                            #'(lambda () (make-operation name))))
               ((or symbol string) (constantly operation))))
            (component-path (typecase component ;; to remake the component after ASDF upgrade
                              (component (component-find-path component))
                              (t component)))
            (system-name (labels ((first-name (x)
                                    (etypecase x
                                      ((or string symbol) x) ; NB: includes the NIL case.
                                      (cons (or (first-name (car x)) (first-name (cdr x)))))))
                           (coerce-name (first-name component-path)))))
       (apply 'make-forcing :performable-p t :system system-name keys)
       ;; 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.
74 75
       (unless (asdf-upgraded-p (toplevel-asdf-session))
         (setf (asdf-upgraded-p (toplevel-asdf-session)) t)
76 77
         (when (upgrade-asdf)
           ;; If we were upgraded, restart OPERATE the hardest of ways, for
78
           ;; its function may have been redefined.
79
           (return-from operate
80
             (with-asdf-session (:override t :override-cache t)
81
               (apply 'operate (funcall operation-remaker) component-path keys))))))
82
      ;; Setup proper bindings around any operate call.
83 84
     (let* ((*verbose-out* (and verbose *standard-output*))
            (*compile-file-warnings-behaviour* on-warnings)
85
            (*compile-file-failure-behaviour* on-failure)))
86
     (with-shared-syntax (:package :asdf-user))
87 88 89 90 91
     (unwind-protect
          (progn
            (incf (operate-level))
            (call-next-method))
       (decf (operate-level)))))
92 93

  (defmethod operate :before ((operation operation) (component component)
94
                              &key version)
95
    (unless (version-satisfies component version)
96
      (error 'missing-component-of-version :requires component :version version))
97 98
    (record-dependency nil operation component))

99
  (defmethod operate ((operation operation) (component component)
100 101 102 103
                      &key plan-class plan-options)
    (let ((plan (apply 'make-plan plan-class operation component
                       :forcing (forcing *asdf-session*) plan-options)))
      (perform-plan plan)
104
      (values operation plan)))
105 106 107 108 109 110

  (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"
111
                (documentation 'operate 'function)))
112

113 114 115 116 117 118 119 120 121 122 123
  (define-condition recursive-operate (warning)
    ((operation :initarg :operation :reader condition-operation)
     (component :initarg :component :reader condition-component)
     (action :initarg :action :reader condition-action))
    (:report (lambda (c s)
               (format s (compatfmt "~@<Deprecated recursive use of (~S '~S '~S) while visiting ~S ~
- please use proper dependencies instead~@:>")
                       'operate
                       (type-of (condition-operation c))
                       (component-find-path (condition-component c))
                       (action-path (condition-action c)))))))
124 125

;;;; Common operations
126
(when-upgrading ()
127
  (defmethod component-depends-on ((o prepare-op) (s system))
128 129
    (call-next-method)))
(with-upgradability ()
130
  (defclass build-op (non-propagating-operation) ()
131 132 133 134 135
    (: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);
136 137
if NIL is specified (the default), BUILD-OP falls back to LOAD-OP,
that will load the system in the current image."))
138
  (defmethod component-depends-on ((o build-op) (c component))
139
    `((,(or (component-build-operation c) 'load-op) ,c)
140
      ,@(call-next-method)))
141

142 143
  (defun make (system &rest keys)
    "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO).
144 145
It will build system FOO using the operation BUILD-OP,
the meaning of which is configurable by the system, and
146
defaults to LOAD-OP, to load it in current image."
147 148
    (apply 'operate 'build-op system keys)
    t)
149

150 151 152
  (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))
153
    (apply 'operate 'load-op system keys)
154
    t)
155

156 157 158 159
  (defun load-systems* (systems &rest keys)
    "Loading multiple systems at once."
    (dolist (s systems) (apply 'load-system s keys)))

160 161
  (defun load-systems (&rest systems)
    "Loading multiple systems at once."
162
    (load-systems* systems))
163

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

170 171 172 173 174
  (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))
175

176 177
;;;;; Define the function REQUIRE-SYSTEM, that, similarly to REQUIRE,
;; only tries to load its specified target if it's not loaded yet.
178
(with-upgradability ()
179
  (defun component-loaded-p (component)
Robert Goldman's avatar
Robert Goldman committed
180
    "Has the given COMPONENT been successfully loaded in the current image (yet)?
181
Note that this returns true even if the component is not up to date."
182
    (if-let ((component (find-component component () :registered t)))
183
      (nth-value 1 (component-operation-time (make-operation 'load-op) component))))
184 185

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

189

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

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

  (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)))
209
      (require module)))
210 211

  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
212
    (unless (and (length=n-p arguments 1)
Robert Goldman's avatar
Robert Goldman committed
213
                 (typep (car arguments) '(or string (and symbol (not null)))))
214 215 216
      (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))
217 218 219 220 221 222
    ;; :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
223 224
    ;; cl:require and asdf:operate that could potentially blow up the stack,
    ;; all the while defeating the consistency of the dependency graph.
225
    (let* ((module (car arguments)) ;; NB: we already checked that it was not null
226 227 228 229 230
           ;; CMUCL, MKCL, SBCL like their module names to be all upcase.
           (module-name (string module))
           (system-name (string-downcase module))
           (system (find-system system-name nil)))
      (or system (let ((system (make-instance 'require-system :name system-name :module module-name)))
231 232
                   (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
    (let ((module-name (string name))
          (system-name (string-downcase name)))
      (unless (member module-name *modules-being-required* :test 'equal)
        (let ((*modules-being-required* (cons module-name *modules-being-required*))
              #+sbcl (sb-impl::*requiring* (remove module-name sb-impl::*requiring* :test 'equal)))
245
          (handler-bind
246
              (((or style-warning recursive-operate) #'muffle-warning)
247
               (missing-component (constantly nil))
248
               (fatal-condition
Robert Goldman's avatar
Robert Goldman committed
249 250 251
                #'(lambda (e)
                    (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
                            name e))))
252
            (let ((*verbose-out* (make-broadcast-stream)))
253
              (let ((system (find-system system-name nil)))
254
                (when system
255 256 257 258 259
                  ;; Do not use require-system after all, use load-system:
                  ;; on the one hand, REQUIRE already uses *MODULES* not to load something twice,
                  ;; on the other hand, REQUIRE-SYSTEM uses FORCE-NOT which may conflict with
                  ;; the toplevel session forcing settings.
                  (load-system system :verbose nil)
260
                  t)))))))))
261

262 263

;;;; Some upgrade magic
264 265 266
(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
267
    (let ((systems-being-defined
268
           (when *asdf-session*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
269
             (prog1
270
                 (loop :for k :being :the hash-keys :of (asdf-cache)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
271
                   :when (eq (first k) 'find-system) :collect (second k))
272
               (clrhash (asdf-cache))))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
273 274
      ;; Regardless, clear defined systems, since they might be invalid
      ;; after an incompatible ASDF upgrade.
275
      (clear-registered-systems)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
276 277 278 279
      ;; 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))))
280
  (register-hook-function '*post-upgrade-cleanup-hook* 'restart-upgraded-asdf))