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

(asdf/package:define-package :asdf/operate
  (:recycle :asdf/operate :asdf)
6
7
8
  (:use :common-lisp :asdf/driver :asdf/upgrade
   :asdf/component :asdf/system :asdf/operation :asdf/action
   :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
9
  (:export
10
11
   #:operate #:oos
   #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
12
   #:build-system
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
   #:load-system #:load-systems #:compile-system #:test-system #:require-system
   #:*load-system-operation* #:module-provide-asdf
   #:component-loaded-p #:already-loaded-systems
   #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
(in-package :asdf/operate)

(defgeneric* operate (operation-class system &key &allow-other-keys))

(defvar *systems-being-operated* nil
  "A boolean indicating that some systems are being operated on")

(defmethod operate :around (operation-class system
                            &key verbose
                              (on-warnings *compile-file-warnings-behaviour*)
                              (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
  (declare (ignorable operation-class system))
29
  ;; Setup proper bindings around any operate call.
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
  (with-system-definitions ()
    (let* ((*asdf-verbose* verbose)
           (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
           (*compile-file-warnings-behaviour* on-warnings)
           (*compile-file-failure-behaviour* on-failure))
      (call-next-method))))

(defmethod operate (operation-class system &rest args &key version &allow-other-keys)
  "Operate does three things:

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
:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
  (let* ((system (etypecase system
                   (system system)
                   ((or string symbol) (find-system system))))
60
61
         ;; I'd like to remove-plist-keys :force :force-not :verbose,
         ;; but swank.asd relies on :force (!).
62
63
64
65
66
         (op (apply 'make-operation operation-class args))
         (systems-being-operated *systems-being-operated*)
         (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))))
    (check-type system system)
    (setf (gethash (coerce-name system) *systems-being-operated*) system)
67
68
69
70
71
    (unless (version-satisfies system version)
      (error 'missing-component-of-version :requires system :version version))
    ;; Before we operate on any system, make sure ASDF is up-to-date,
    ;; for if an upgrade is attempted at any later time, there may be trouble.
    ;; If we upgraded, restart the OPERATE from scratch,
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
72
73
    ;; for the function will have been redefined,
    ;; maybe from a new symbol for it may have been uninterned.
74
    (if (upgrade-asdf)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
75
        (apply 'symbol-call :asdf 'operate operation-class system args)
76
77
78
        (let ((plan (apply 'traverse op system args)))
          (perform-plan plan)
          (values op plan)))))
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94

(defun* oos (operation-class system &rest args
             &key force force-not verbose version &allow-other-keys)
  (declare (ignore force force-not verbose version))
  (apply 'operate operation-class system args))

(setf (documentation 'oos 'function)
      (format nil "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
              (documentation 'operate 'function)))


;;;; Common operations

(defvar *load-system-operation* 'load-op
  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
95
96
97
98
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")
99

100
101
102
103
104
(defun* build-system (system &rest keys)
  "Shorthand for `(operate 'asdf:build-op system)`."
  (apply 'operate 'build-op system keys)
  t)

105
106
107
108
109
110
111
(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)

(defun* load-systems (&rest systems)
112
  "Loading multiple systems at once."
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
  (map () 'load-system systems))

(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)

(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)


128
;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
129
130
131
132
133
134
135
136
137
138
;; i.e. for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL

(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))
139

140
141
142
143
144
145
146
147
148
149
150
151
152
(defun* module-provide-asdf (name)
  (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))
          (system (find-system (string-downcase name) nil)))
      (when system
        (require-system system :verbose nil)
        t))))

153
154
155
156
157

;;;; Some upgrade magic

(defun* reset-asdf-systems ()
  (let ((asdf (find-system :asdf)))
158
    (setf (component-version asdf) (asdf-version))
159
160
161
162
163
164
165
166
167
168
169
170
171
172
    ;; Invalidate all systems but ASDF itself.
    (setf *defined-systems* (make-defined-systems-table))
    (register-system asdf)
    (load-system asdf))) ;; re-load ourselves the right way

(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)))))

(pushnew 'reset-asdf-systems *post-upgrade-cleanup-hook*)
(pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)