operate.lisp 9.67 KB
Newer Older
1
2
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
3
4
5

(asdf/package:define-package :asdf/operate
  (:recycle :asdf/operate :asdf)
6
  (:use :uiop/common-lisp :uiop :asdf/upgrade
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
26
27
28
29
30
31
32
33
34
35
36
37
38
39

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).
3. It then calls TRAVERSE with the operation and system as arguments

The traverse operation 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.

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
57
: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)
    (declare (ignorable operation component))
    (let* ((systems-being-operated *systems-being-operated*)
58
           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
59
60
61
62
63
64
           (operation-name (reify-symbol (etypecase operation
                                           (operation (type-of operation))
                                           (symbol operation))))
           (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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
        (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)
                   (unreify-symbol operation-name)
                   component-path keys))))
      ;; Setup proper bindings around any operate call.
      (with-system-definitions ()
        (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
110
111
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")
112

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

118
119
120
121
122
  (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)
123

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

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

132
133
134
135
136
  (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)
137

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


145
;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
146
;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
147
148
149
150
151
152
153
154
155
156
(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))

157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
  (defvar *modules-being-required* nil)

  (defclass require-system (system)
    ((module :initarg :module :initform nil :accessor required-module)))

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

  (defmethod perform ((o load-op) (s require-system))
    (declare (ignorable o))
    (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)
    (declare (ignorable component combinator))
    (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))
179
180
           (name (string-downcase module))
           (system (find-system name nil)))
181
      (assert module)
182
183
184
185
186
187
      ;;(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))))
188

189
  (defun module-provide-asdf (name)
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
    (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)))))))))
205

206
207

;;;; Some upgrade magic
208
209
210
211
212
213
214
215
(with-upgradability ()
  (defun restart-upgraded-asdf ()
    ;; If we're in the middle of something, restart it.
    (when *systems-being-defined*
      (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
        (clrhash *systems-being-defined*)
        (dolist (s l) (find-system s nil)))))

216
  (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
217
218