diff --git a/src/actor-context-api.lisp b/src/actor-context-api.lisp index 05e2cec..19c5fe3 100644 --- a/src/actor-context-api.lisp +++ b/src/actor-context-api.lisp @@ -43,7 +43,7 @@ This function allows to unsubsribe from event-stream or such. Additional options: - `:queue-size` limits the message-box's size. By default, it is unbounded. -- `:mbox-type` specify a custom message-box type similar as can be done is dispatcher config. +- `:mbox-type` specify a custom message-box type similar as can be done is dispatcher config. It also could be a function which accept a `:max-queue-size` argument for `:pinned` dispatcher or `:max-queue-size` and `:dispatcher` arguments for other types of dispatchers. It must be a subtype of `mesgb:message-box/dp`. ")) diff --git a/src/actor-context.lisp b/src/actor-context.lisp index 6fdd583..dd47376 100644 --- a/src/actor-context.lisp +++ b/src/actor-context.lisp @@ -50,22 +50,43 @@ The `actor-system` and the `actor` itself are composed of an `actor-context`.")) old-actors))))) (defun %message-box-for-dispatcher-id (context dispatcher-id queue-size mbox-type) - (case dispatcher-id - (:pinned (make-instance 'mesgb:message-box/bt - :max-queue-size queue-size)) - (otherwise (let* ((asys (system context)) - (sys-config (asys:config asys)) - (disp-config (%get-dispatcher-config sys-config dispatcher-id)) - (dispatcher (%get-shared-dispatcher asys dispatcher-id))) - (unless dispatcher - (error (format nil "No such dispatcher identifier '~a' exists!" dispatcher-id))) - ;; if dispatcher exists, the config does, too. - (let ((eff-mbox-type (if mbox-type - mbox-type - (getf disp-config :mbox-type 'mesgb:message-box/dp)))) - (make-instance eff-mbox-type - :dispatcher dispatcher - :max-queue-size queue-size)))))) + (let* ((asys (system context)) + (sys-config (asys:config asys)) + (disp-config (%get-dispatcher-config sys-config dispatcher-id)) + (default-mbox-type (case dispatcher-id + (:pinned 'mesgb:message-box/bt) + (otherwise + 'mesgb:message-box/dp))) + (eff-mbox-type (if mbox-type + mbox-type + (getf disp-config :mbox-type + default-mbox-type)))) + (case dispatcher-id + (:pinned + (etypecase eff-mbox-type + (function + (let ((result (funcall eff-mbox-type :max-queue-size queue-size))) + (check-type result mesgb::message-box-base) + result)) + (symbol + (make-instance eff-mbox-type + :max-queue-size queue-size)))) + (otherwise + (let ((dispatcher (%get-shared-dispatcher asys dispatcher-id))) + (unless dispatcher + (error (format nil "No such dispatcher identifier '~a' exists!" dispatcher-id))) + ;; if dispatcher exists, the config does, too. + (etypecase eff-mbox-type + (function + (let ((result (funcall eff-mbox-type + :dispatcher dispatcher + :max-queue-size queue-size))) + (check-type result mesgb::message-box-base) + result)) + (symbol + (make-instance eff-mbox-type + :dispatcher dispatcher + :max-queue-size queue-size)))))))) (defun %find-actor-by-name (context name) (find-if (lambda (a) diff --git a/tests/actor-context-test.lisp b/tests/actor-context-test.lisp index aba542a..3a008fc 100644 --- a/tests/actor-context-test.lisp +++ b/tests/actor-context-test.lisp @@ -67,7 +67,12 @@ (is (not (eq cut (act:context actor)))) (is (not (null (ac:system (act:context actor)))))))) + (defclass my-mbox-type (mesgb:message-box/dp) ()) + +(defclass my-bt-mbox-type (mesgb:message-box/bt) ()) + + (test actor-of--shared--custom-mbox-type (with-fixture test-system () (let* ((cut (make-actor-context system)) @@ -119,6 +124,57 @@ )) (ac:shutdown system)))) + +(test actor-of--custom-dispatcher-with-mbox-made-by-func + (let ((system)) + (unwind-protect + (progn + (setf system (asys:make-actor-system `(:dispatchers + (:foo + (:workers 0 + :mbox-type ,(lambda (&key dispatcher max-queue-size &allow-other-keys) + (make-instance 'my-mbox-type + :dispatcher dispatcher + :max-queue-size max-queue-size))))))) + (let* ((cut (make-actor-context system)) + (actor (actor-of cut :receive (lambda ()) + :dispatcher :foo))) + (is (not (null actor))) + (is (typep (act-cell:msgbox actor) 'my-mbox-type)) + (is (eq :foo (slot-value (mesgb::dispatcher (act-cell:msgbox actor)) 'disp::identifier))))) + (ac:shutdown system)))) + + +(test actor-of--pinned-dispatcher-with-custom-mbox-type + (let ((system)) + (unwind-protect + (progn + (setf system (asys:make-actor-system)) + (let* ((cut (make-actor-context system)) + (actor (actor-of cut :receive (lambda ()) + :dispatcher :pinned + :mbox-type 'my-bt-mbox-type))) + (is (not (null actor))) + (is (typep (act-cell:msgbox actor) 'my-bt-mbox-type)))) + (ac:shutdown system)))) + + +(test actor-of--pinned-dispatcher-with-mbox-made-by-func + (let ((system)) + (unwind-protect + (progn + (setf system (asys:make-actor-system)) + (let* ((cut (make-actor-context system)) + (actor (actor-of cut :receive (lambda ()) + :dispatcher :pinned + :mbox-type (lambda (&key max-queue-size &allow-other-keys) + (make-instance 'my-bt-mbox-type + :max-queue-size max-queue-size))))) + (is (not (null actor))) + (is (typep (act-cell:msgbox actor) 'my-bt-mbox-type)))) + (ac:shutdown system)))) + + (test actor-of--err-custom-dispatcher--unknown-mbox-type "Tests creating an actor with a custom shared dispatcher." (let ((system))