Newer
Older
;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/operate
(:recycle :asdf/operate :asdf)
(: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)
Francois-Rene Rideau
committed
#:operate #:oos
#:*systems-being-operated* #:*asdf-upgrade-already-attempted*
#:build-system
#: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 component &key &allow-other-keys))
(define-convenience-action-methods
operate (operation component &key)
: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
&key verbose
(on-warnings *compile-file-warnings-behaviour*)
(on-failure *compile-file-failure-behaviour*) &allow-other-keys)
(declare (ignorable operation component))
;; Setup proper bindings around any operate call.
(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 operation) (component component)
&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* (;; I'd like to remove-plist-keys :force :force-not :verbose,
;; but swank.asd relies on :force (!).
(systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
(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))
;; 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
(let ((operation-name (reify-symbol (type-of operation)))
(component-path (component-find-path component)))
(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 args)))))
(let ((plan (apply 'traverse operation system args)))
(perform-plan plan)
(values operation plan))))
(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)))
;;;; 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,
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")
(defun* build-system (system &rest keys)
"Shorthand for `(operate 'asdf:build-op system)`."
(apply 'operate 'build-op system keys)
t)
(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)
"Loading multiple systems at once."
(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)
;;;; Define require-system, to be hooked into CL:REQUIRE when possible,
;; 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))
(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))))
;;;; Some upgrade magic
(defun* reset-asdf-systems ()
(let ((asdf (find-system :asdf)))
(setf (component-version asdf) (asdf-version))
;; 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*)