|
| 1 | +;;;; ------------------------------------------------------------------------- |
| 2 | +;;;; Forcing |
| 3 | + |
| 4 | +(uiop/package:define-package :asdf/forcing |
| 5 | + (:recycle :asdf/forcing :asdf/plan :asdf) |
| 6 | + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/session |
| 7 | + :asdf/component :asdf/operation :asdf/system :asdf/system-registry) |
| 8 | + (:export |
| 9 | + #:forcing #:make-forcing #:forced #:forced-not #:performable-p |
| 10 | + #:normalize-forced-systems #:normalize-forced-not-systems |
| 11 | + #:action-forced-p #:action-forced-not-p)) |
| 12 | +(in-package :asdf/forcing) |
| 13 | + |
| 14 | +;;;; Forcing |
| 15 | +(with-upgradability () |
| 16 | + (defclass forcing () |
| 17 | + (;; Can plans using this forcing be PERFORMed? A plan that has different force and force-not |
| 18 | + ;; settings than the session can only be used for read-only queries that do not cause the |
| 19 | + ;; status of any action to be raised. |
| 20 | + (performable-p :initform nil :initarg :performable-p :reader performable-p) |
| 21 | + ;; Parameters |
| 22 | + (parameters :initform nil :initarg :parameters :reader parameters) |
| 23 | + ;; Table of systems specified via :force arguments |
| 24 | + (forced :initarg :forced :reader forced) |
| 25 | + ;; Table of systems specified via :force-not argument (and/or immutable) |
| 26 | + (forced-not :initarg :forced-not :reader forced-not))) |
| 27 | + |
| 28 | + (defgeneric action-forced-p (forcing operation component) |
| 29 | + (:documentation "Is this action forced to happen in this plan?")) |
| 30 | + (defgeneric action-forced-not-p (forcing operation component) |
| 31 | + (:documentation "Is this action forced to not happen in this plan? |
| 32 | +Takes precedence over action-forced-p.")) |
| 33 | + |
| 34 | + (defun normalize-forced-systems (force system) |
| 35 | + "Given a SYSTEM on which operate is called and the specified FORCE argument, |
| 36 | +extract a hash-set of systems that are forced, or a predicate on system names, |
| 37 | +or NIL if none are forced, or :ALL if all are." |
| 38 | + (etypecase force |
| 39 | + ((or (member nil :all) hash-table function) force) |
| 40 | + (cons (list-to-hash-set (mapcar #'coerce-name force))) |
| 41 | + ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) |
| 42 | + |
| 43 | + (defun normalize-forced-not-systems (force-not system) |
| 44 | + "Given a SYSTEM on which operate is called, the specified FORCE-NOT argument, |
| 45 | +and the set of IMMUTABLE systems, extract a hash-set of systems that are effectively forced-not, |
| 46 | +or predicate on system names, or NIL if none are forced, or :ALL if all are." |
| 47 | + (let ((requested |
| 48 | + (etypecase force-not |
| 49 | + ((or (member nil :all) hash-table function) force-not) |
| 50 | + (cons (list-to-hash-set (mapcar #'coerce-name force-not))) |
| 51 | + ((eql t) (if system (let ((name (coerce-name system))) |
| 52 | + #'(lambda (x) (not (equal x name)))) |
| 53 | + :all))))) |
| 54 | + (if (and *immutable-systems* requested) |
| 55 | + #'(lambda (x) (or (call-function requested x) |
| 56 | + (call-function *immutable-systems* x))) |
| 57 | + (or *immutable-systems* requested)))) |
| 58 | + |
| 59 | + ;; TODO: shouldn't we be looking up the primary system name, rather than the system name? |
| 60 | + (defun action-override-p (forcing operation component override-accessor) |
| 61 | + "Given a plan, an action, and a function that given the plan accesses a set of overrides, |
| 62 | +i.e. force or force-not, see if the override applies to the current action." |
| 63 | + (declare (ignore operation)) |
| 64 | + (call-function (funcall override-accessor forcing) |
| 65 | + (coerce-name (component-system (find-component () component))))) |
| 66 | + |
| 67 | + (defmethod action-forced-p (forcing operation component) |
| 68 | + (and |
| 69 | + ;; Did the user ask us to re-perform the action? |
| 70 | + (action-override-p forcing operation component 'forced) |
| 71 | + ;; You really can't force a builtin system and :all doesn't apply to it. |
| 72 | + (not (builtin-system-p (component-system component))))) |
| 73 | + |
| 74 | + (defmethod action-forced-not-p (forcing operation component) |
| 75 | + ;; Did the user ask us to not re-perform the action? |
| 76 | + ;; NB: force-not takes precedence over force, as it should |
| 77 | + (action-override-p forcing operation component 'forced-not)) |
| 78 | + |
| 79 | + ;; Null forcing means no forcing either way |
| 80 | + (defmethod action-forced-p ((forcing null) (operation operation) (component component)) |
| 81 | + nil) |
| 82 | + (defmethod action-forced-not-p ((forcing null) (operation operation) (component component)) |
| 83 | + nil) |
| 84 | + |
| 85 | + (defun or-function (fun1 fun2) |
| 86 | + (cond |
| 87 | + ((or (null fun2) (eq fun1 :all)) fun1) |
| 88 | + ((or (null fun1) (eq fun2 :all)) fun2) |
| 89 | + (t #'(lambda (x) (or (call-function fun1 x) (call-function fun2 x)))))) |
| 90 | + |
| 91 | + (defun make-forcing (&key performable-p system |
| 92 | + (force nil force-p) (force-not nil force-not-p) &allow-other-keys) |
| 93 | + (let* ((session-forcing (when *asdf-session* (forcing *asdf-session*))) |
| 94 | + (system (and system (coerce-name system))) |
| 95 | + (forced (normalize-forced-systems force system)) |
| 96 | + (forced-not (normalize-forced-not-systems force-not system)) |
| 97 | + (parameters `(,@(when force `(:force ,force)) |
| 98 | + ,@(when force-not `(:force-not ,force-not)) |
| 99 | + ,@(when (or (eq force t) (eq force-not t)) `(:system ,system)) |
| 100 | + ,@(when performable-p `(:performable-p t)))) |
| 101 | + forcing) |
| 102 | + (cond |
| 103 | + ((not session-forcing) |
| 104 | + (setf forcing (make-instance 'forcing |
| 105 | + :performable-p performable-p :parameters parameters |
| 106 | + :forced forced :forced-not forced-not)) |
| 107 | + (when (and performable-p *asdf-session*) |
| 108 | + (setf (forcing *asdf-session*) forcing))) |
| 109 | + (performable-p |
| 110 | + (when (and (not (equal parameters (parameters session-forcing))) |
| 111 | + (or force-p force-not-p)) |
| 112 | + (parameter-error "~*~S and ~S arguments not allowed in a nested call to ~3:*~S ~ |
| 113 | +unless identically to toplevel" |
| 114 | + (find-symbol* :operate :asdf) :force :force-not)) |
| 115 | + (setf forcing session-forcing)) |
| 116 | + (t |
| 117 | + (setf forcing (make-instance 'forcing |
| 118 | + ;; Combine force and force-not with values from the toplevel-plan |
| 119 | + :parameters `(,@parameters :on-top-of ,(parameters session-forcing)) |
| 120 | + :forced (or-function (forced session-forcing) forced) |
| 121 | + :forced-not (or-function (forced-not session-forcing) forced-not))))) |
| 122 | + forcing)) |
| 123 | + |
| 124 | + (defmethod print-object ((forcing forcing) stream) |
| 125 | + (print-unreadable-object (forcing stream :type t) |
| 126 | + (format stream "~{~S~^ ~}" (parameters forcing)))) |
| 127 | + |
| 128 | + ;; During upgrade, the *asdf-session* may legitimately be NIL, so we must handle that case. |
| 129 | + (defmethod forcing ((x null)) |
| 130 | + (if-let (session (toplevel-asdf-session)) |
| 131 | + (forcing session) |
| 132 | + (make-forcing :performable-p t))) |
| 133 | + |
| 134 | + ;; When performing a plan that is a list of actions, use the toplevel asdf sesssion forcing. |
| 135 | + (defmethod forcing ((x cons)) (forcing (toplevel-asdf-session)))) |
0 commit comments