From 7898ee5f2096b9c5f3095de35ab7b9c5de537d02 Mon Sep 17 00:00:00 2001 From: Rod Kay Date: Mon, 16 Sep 2024 22:45:31 +1000 Subject: [PATCH] lace.events: Add 'event_Sender'. --- .../source/events/interface/lace-subject.ads | 28 +- .../source/events/mixin/lace-make_subject.adb | 59 +++- .../source/events/mixin/lace-make_subject.ads | 36 +- .../mixin/private/lace-event_sender.adb | 325 ++++++++++++++++++ .../mixin/private/lace-event_sender.ads | 107 ++++++ .../events/utility/lace-event-logger-text.adb | 39 ++- .../events/utility/lace-event-logger-text.ads | 4 + .../events/utility/lace-event-logger.ads | 4 + 8 files changed, 586 insertions(+), 16 deletions(-) create mode 100644 1-base/lace/source/events/mixin/private/lace-event_sender.adb create mode 100644 1-base/lace/source/events/mixin/private/lace-event_sender.ads diff --git a/1-base/lace/source/events/interface/lace-subject.ads b/1-base/lace/source/events/interface/lace-subject.ads index f3d6557..b10c119 100644 --- a/1-base/lace/source/events/interface/lace-subject.ads +++ b/1-base/lace/source/events/interface/lace-subject.ads @@ -22,6 +22,7 @@ is type fast_Views is array (Positive range <>) of fast_View; + ------------- -- Containers -- @@ -29,6 +30,7 @@ is type Observer_views is array (Positive range <>) of Observer.view; + ------------- -- Attributes -- @@ -36,6 +38,7 @@ is function Name (Self : in Item) return Event.subject_Name is abstract; + ------------ -- Observers -- @@ -46,14 +49,18 @@ is procedure deregister (Self : in out Item; the_Observer : in Observer.view; of_Kind : in Event.Kind) is abstract; - function Observers (Self : in Item; of_Kind : in Event.Kind) return Observer_views is abstract; - function observer_Count (Self : in Item) return Natural is abstract; + function Observers (Self : in Item; of_Kind : in Event.Kind) return Observer_views is abstract; + function observer_Count (Self : in Item) return Natural is abstract; + ------------- -- Operations -- + -- Emit + -- + procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event) is abstract; -- -- Communication errors are ignored. @@ -66,7 +73,22 @@ is procedure use_event_Emitter (Self : in out Item) is abstract; -- - -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA. + -- Delegate event emission to a task to prevent blocking. Useful for handling lag with DSA. + + + + -- Send + -- + + procedure send (Self : access Item; the_Event : in Event.item'Class; + to_Observer : in Observer.view) is abstract; + -- + -- Communication errors are ignored. + + + procedure use_event_Sender (Self : in out Item) is abstract; + -- + -- Delegate 'send' to a task to prevent blocking. Useful for handling lag with DSA. diff --git a/1-base/lace/source/events/mixin/lace-make_subject.adb b/1-base/lace/source/events/mixin/lace-make_subject.adb index 2f90111..8387413 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.adb +++ b/1-base/lace/source/events/mixin/lace-make_subject.adb @@ -82,6 +82,10 @@ is + -------- + --- Emit + -- + overriding procedure use_event_Emitter (Self : in out Item) is @@ -148,7 +152,7 @@ is loop begin my_Observers (i).receive (the_Event, - from_Subject => Subject.item'Class (Self.all).Name); + from_Subject => Subject.view (Self).Name); if Subject.Logger /= null then Subject.Logger.log_Emit (Subject.view (Self), @@ -169,6 +173,59 @@ is + + -------- + --- Send + -- + + overriding + procedure use_event_Sender (Self : in out Item) + is + begin + Self.Sender := new event_Sender.item; + Self.Sender.define (Self'unchecked_Access); + end use_event_Sender; + + + + overriding + procedure send (Self : access Item; the_Event : in Event.item'Class; + to_Observer : in Observer.view) + is + begin + if Self.Sender = null + then + begin + to_Observer.receive (the_Event, + from_Subject => Subject.view (Self).Name); + if Subject.Logger /= null + then + Subject.Logger.log_Send (Subject.view (Self), + to_Observer, + the_Event); + end if; + + exception + when system.RPC.communication_Error + | storage_Error => + + if Subject.Logger /= null + then + Subject.Logger.log_Send (Subject.view (Self), + to_Observer, + the_Event); + end if; + end; + + else + Self.Sender.add (the_Event, + for_Observer => to_Observer, + from_Subject => Self); + end if; + end send; + + + ----------------- -- Safe Observers -- diff --git a/1-base/lace/source/events/mixin/lace-make_subject.ads b/1-base/lace/source/events/mixin/lace-make_subject.ads index 3602695..7418f02 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.ads +++ b/1-base/lace/source/events/mixin/lace-make_subject.ads @@ -7,6 +7,7 @@ with private with lace.event_Emitter, + lace.event_Sender, ada.Containers.Vectors, ada.Containers.indefinite_hashed_Maps; @@ -29,6 +30,7 @@ is procedure destroy (Self : in out Item); + ------------- -- Attributes -- @@ -40,6 +42,7 @@ is function observer_Count (Self : in Item) return Natural; + ------------- -- Operations -- @@ -51,27 +54,40 @@ is procedure deregister (Self : in out Item; the_Observer : in Observer.view; of_Kind : in Event.Kind); - overriding - procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event); + + -- Emit + -- overriding - function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event) + procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event); -- TODO: Rid default. + + overriding + function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event) -- TODO: Rid default. return subject.Observer_views; overriding procedure use_event_Emitter (Self : in out Item); + + + + -- Send -- - -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA. + overriding + procedure send (Self : access Item; the_Event : in Event.item'Class; + to_Observer : in Observer.view); + + overriding + procedure use_event_Sender (Self : in out Item); private - pragma Suppress (Container_Checks); -- Suppress expensive tamper checks. + pragma suppress (container_Checks); -- Suppress expensive tamper checks. - ------------------------- - -- Event observer vectors + -------------------------- + -- Event observer vectors. -- use type Observer.view; @@ -81,8 +97,8 @@ private - ------------------------------------- - -- Event kind Maps of event observers + -------------------------------------- + -- Event kind Maps of event observers. -- use type Event.Kind; package event_kind_Maps_of_event_observers is new ada.Containers.indefinite_hashed_Maps (Event.Kind, @@ -121,6 +137,7 @@ private -- type event_Emitter_view is access all event_Emitter.item'Class; + type event_Sender_view is access all event_Sender .item'Class; type Item is abstract limited new T and Subject.item @@ -128,6 +145,7 @@ private record safe_Observers : make_Subject.safe_Observers; Emitter : event_Emitter_view; + Sender : event_Sender_view; end record; end lace.make_Subject; diff --git a/1-base/lace/source/events/mixin/private/lace-event_sender.adb b/1-base/lace/source/events/mixin/private/lace-event_sender.adb new file mode 100644 index 0000000..20d9cee --- /dev/null +++ b/1-base/lace/source/events/mixin/private/lace-event_sender.adb @@ -0,0 +1,325 @@ +with + ada.Text_IO, + ada.Exceptions, + ada.unchecked_Deallocation; + + +package body lace.event_Sender +is + + --------------- + --- Containers. + -- + + package string_Holders is new ada.Containers.indefinite_Holders (Element_type => String); + subtype string_Holder is string_Holders.Holder; + + + package sender_Vectors is new ada.Containers.Vectors (Positive, + Sender_view); + subtype sender_Vector is sender_Vectors.Vector; + + + + ----------------- + --- Safe senders. + -- + + protected + type safe_Senders + is + procedure add (new_Sender : in Sender_view); + procedure get (a_Sender : out Sender_view); + + private + all_Senders : sender_Vector; + end safe_Senders; + + type safe_Senders_view is access all safe_Senders; + + + + + ----------- + --- Sender. + -- + + task + type Sender + is + entry send (Self : in Sender_view; + the_Event : in lace.Event.item'Class; + To : in lace.Observer.view; + from_Subject : in String; + Senders : in safe_Senders_view); + end Sender; + + + + task body Sender + is + Myself : Sender_view; + Event : event_Holder; + the_Observer : lace.Observer.view; + subject_Name : string_Holder; + sender_Pool : safe_Senders_view; + begin + loop + begin + select + accept send (Self : in Sender_view; + the_Event : in lace.Event.item'Class; + To : in lace.Observer.view; + from_Subject : in String; + Senders : in safe_Senders_view) + do + Event .replace_Element (the_Event); + subject_Name.replace_Element (from_Subject); + + Myself := Self; + the_Observer := To; + + sender_Pool := Senders; + end send; + or + terminate; + end select; + + the_Observer.receive (Event.Reference, + from_Subject => subject_Name.Element); + sender_Pool.add (Myself); -- Return the sender to the safe pool. + + exception + when E : others => + ada.Text_IO.new_Line; + ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E)); + ada.Text_IO.put_Line ("Error detected in 'lace.event_Sender.Sender' task."); + ada.Text_IO.put_Line ("Subject: '" & subject_Name.Element & "'."); + ada.Text_IO.put_Line ("Event: '" & Event.Element'Image & "'."); + ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name & "'."); + ada.Text_IO.put_Line ("Continuing."); + ada.Text_IO.new_Line (2); + sender_Pool.add (Myself); -- Return the sender to the safe pool. + end; + end loop; + + exception + when E : others => + ada.Text_IO.new_Line; + ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E)); + ada.Text_IO.put_Line ("Fatal error detected in 'lace.event_Sender.Sender' task."); + ada.Text_IO.put_Line ("Subject: '" & subject_Name.Element & "'."); + ada.Text_IO.put_Line ("Event: '" & Event.Element'Image & "'."); + ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name & "'."); + ada.Text_IO.new_Line (2); + end Sender; + + + + + ------------------- + --- Send delegator. + -- + + task body send_Delegator + is + the_subject_Name : string_Holder; + + the_Senders : aliased safe_Senders; + + the_Pairs : safe_Pairs_view; + new_Pairs : pair_Vector; + Done : Boolean := False; + + + procedure shutdown + is + procedure free is new ada.unchecked_Deallocation (Sender, + Sender_view); + the_Sender : Sender_view; + begin + loop + the_Senders.get (the_Sender); + exit when the_Sender = null; + + free (the_Sender); + end loop; + end shutdown; + + + begin + accept start (Subject : in lace.Subject.view; + Pairs : in safe_Pairs_view) + do + the_Pairs := Pairs; + the_subject_Name.replace_Element (Subject.Name); + end start; + + + loop + select + accept stop + do + Done := True; + end stop; + + else + null; + end select; + + + exit when Done + and the_Pairs.is_Empty; + + the_Pairs.get (new_Pairs); + + for each_Pair of new_Pairs + loop + declare + the_Sender : Sender_view; + begin + the_Senders.get (the_Sender); + + if the_Sender = null + then + the_Sender := new Sender; + end if; + + the_Sender.send (Self => the_Sender, + the_Event => each_Pair.Event.Element, + To => each_Pair.Observer, + from_Subject => the_subject_Name.Element, + Senders => the_Senders'unchecked_Access); + exception + when E : others => + ada.Text_IO.new_Line; + ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E)); + ada.Text_IO.new_Line; + ada.Text_IO.put_Line ("Error detected in 'lace.event_Sender.send_Delegator'."); + ada.Text_IO.put_Line ("Subject '" & the_subject_Name.Element & "'."); + ada.Text_IO.put_Line ("Observer '" & each_Pair.Observer.Name & "'."); + ada.Text_IO.put_Line ("Event '" & each_Pair.Event'Image & "'."); + ada.Text_IO.put_Line ("Continuing."); + ada.Text_IO.new_Line (2); + end; + end loop; + + delay 0.001; + end loop; + + shutdown; + + exception + when E : others => + ada.Text_IO.new_Line; + ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E)); + ada.Text_IO.new_Line; + ada.Text_IO.put_Line ("Fatal error detected in 'lace.event_Sender.send_Delegator' for subject '" & the_subject_Name.Element & "'."); + ada.Text_IO.new_Line (2); + + shutdown; + end send_Delegator; + + + + + --------------- + --- Safe Pairs. + -- + + protected body safe_Pairs + is + + procedure add (new_Pair : in event_observer_Pair) + is + begin + all_Pairs.append (new_Pair); + end add; + + + + procedure get (the_Pairs : out pair_Vector) + is + begin + the_Pairs := all_Pairs; + all_Pairs.clear; + end get; + + + + function is_Empty return Boolean + is + begin + return all_Pairs.is_Empty; + end is_Empty; + + end safe_Pairs; + + + + + ----------------- + --- Safe senders. + -- + + protected body safe_Senders + is + + procedure add (new_Sender : in Sender_view) + is + begin + all_Senders.append (new_Sender); + end add; + + + + procedure get (a_Sender : out Sender_view) + is + begin + if all_Senders.is_Empty + then + a_Sender := null; + else + a_Sender := all_Senders.last_Element; + all_Senders.delete_Last; + end if; + end get; + + end safe_Senders; + + + + + ---------------------- + --- event_Sender item. + -- + + procedure define (Self : in out Item; Subject : in lace.Subject.view) + is + begin + Self.Delegator.start (Subject => Subject, + Pairs => Self.Pairs'unchecked_Access); + end define; + + + + procedure destruct (Self : in out Item) + is + begin + Self.Delegator.stop; + end destruct; + + + + procedure add (Self : in out Item; new_Event : in lace.Event.item'Class; + for_Observer : in lace.Observer.view; + from_Subject : in lace.Subject.view) + is + use event_Holders; + begin + Self.Pairs.add (event_observer_Pair' (Event => to_Holder (new_Event), + Observer => for_Observer)); + end add; + + +end lace.event_Sender; diff --git a/1-base/lace/source/events/mixin/private/lace-event_sender.ads b/1-base/lace/source/events/mixin/private/lace-event_sender.ads new file mode 100644 index 0000000..c62d663 --- /dev/null +++ b/1-base/lace/source/events/mixin/private/lace-event_sender.ads @@ -0,0 +1,107 @@ +with + lace.Event, + lace.Subject, + lace.Observer; + + +private +with + ada.Containers.Vectors, + ada.Containers.indefinite_Holders; + + +package lace.event_Sender with remote_Types +is + + type Item is tagged limited private; + + + procedure define (Self : in out Item; Subject : in lace.Subject.view); + procedure destruct (Self : in out Item); + + procedure add (Self : in out Item; new_Event : in lace.Event.item'Class; + for_Observer : in lace.Observer.view; + from_Subject : in lace.Subject.view); + + +private + + use type lace.Event.item'Class; + package event_Holders is new ada.Containers.indefinite_Holders (Element_type => lace.Event.item'Class); + subtype event_Holder is event_Holders.Holder; + + + + type event_observer_Pair is + record + Event : event_Holder; + Observer : lace.Observer.view; + end record; + + + + ----------- + --- Sender. + -- + + type Sender; + type Sender_view is access Sender; + + + + ------------------------------- + --- event_observer_Pair_Vector. + -- + + package pair_Vectors is new ada.Containers.Vectors (Positive, + event_observer_Pair); + subtype pair_Vector is pair_Vectors.Vector; + + + + --------------- + --- Safe pairs. + -- + + protected + type safe_Pairs + is + procedure add (new_Pair : in event_observer_Pair); + procedure get (the_pairs : out pair_Vector); + + function is_Empty return Boolean; + + private + all_Pairs : pair_Vector; + end safe_Pairs; + + type safe_Pairs_view is access all safe_Pairs; + + + + ------------------- + --- Send delegator. + -- + + task + type send_Delegator + is + entry start (Subject : in lace.Subject.view; + Pairs : in safe_Pairs_view); + entry stop; + end send_Delegator; + + + + --------- + --- Item. + -- + + type Item is tagged limited + record + Pairs : aliased safe_Pairs; + Delegator : send_Delegator; + end record; + + +end lace.event_Sender; diff --git a/1-base/lace/source/events/utility/lace-event-logger-text.adb b/1-base/lace/source/events/utility/lace-event-logger-text.adb index 42e7328..efa8c07 100644 --- a/1-base/lace/source/events/utility/lace-event-logger-text.adb +++ b/1-base/lace/source/events/utility/lace-event-logger-text.adb @@ -78,6 +78,10 @@ is + function to_Integer is new ada.unchecked_Conversion (lace.Observer.view, + long_Integer); + + overriding procedure log_Emit (Self : in out Item; From : in Subject .view; To : in Observer.view; @@ -85,10 +89,9 @@ is is function to_Name return String is - function to_Integer is new ada.unchecked_Conversion (lace.Observer.view, - long_Integer); begin return To.Name; + exception when system.RPC.communication_Error | storage_Error => @@ -103,12 +106,42 @@ is new_Line (Self.File); put_Line (Self.File, "Emit => " - & From.Name & " sends " & Name_of (Kind_of (the_Event)) + & From.Name & " emits " & Name_of (Kind_of (the_Event)) & " to " & to_Name & "."); end log_Emit; + overriding + procedure log_Send (Self : in out Item; From : in Subject .view; + To : in Observer.view; + the_Event : in Event.item'Class) + is + function to_Name return String + is + begin + return To.Name; + + exception + when system.RPC.communication_Error + | storage_Error => + return "dead Observer (" & to_Integer (To)'Image & ")"; + end to_Name; + + begin + if Self.Ignored.contains (to_Kind (the_Event'Tag)) + then + return; + end if; + + new_Line (Self.File); + put_Line (Self.File, "Send => " + & From.Name & " sends " & Name_of (Kind_of (the_Event)) + & " to " & to_Name & "."); + end log_Send; + + + overriding procedure log_Relay (Self : in out Item; From : in Observer.view; To : in Observer.view; diff --git a/1-base/lace/source/events/utility/lace-event-logger-text.ads b/1-base/lace/source/events/utility/lace-event-logger-text.ads index 5adb9a1..61cca8c 100644 --- a/1-base/lace/source/events/utility/lace-event-logger-text.ads +++ b/1-base/lace/source/events/utility/lace-event-logger-text.ads @@ -61,6 +61,10 @@ is To : in Observer.view; the_Event : in Event.item'Class); overriding + procedure log_Send (Self : in out Item; From : in Subject .view; + To : in Observer.view; + the_Event : in Event.item'Class); + overriding procedure log_Relay (Self : in out Item; From : in Observer.view; To : in Observer.view; the_Event : in Event.item'Class); diff --git a/1-base/lace/source/events/utility/lace-event-logger.ads b/1-base/lace/source/events/utility/lace-event-logger.ads index 7305e90..9ede194 100644 --- a/1-base/lace/source/events/utility/lace-event-logger.ads +++ b/1-base/lace/source/events/utility/lace-event-logger.ads @@ -51,6 +51,10 @@ is To : in Observer.view; the_Event : in Event.item'Class) is abstract; + procedure log_Send (Self : in out Item; From : in Subject .view; + To : in Observer.view; + the_Event : in Event.item'Class) is abstract; + procedure log_Relay (Self : in out Item; From : in Observer.view; To : in Observer.view; the_Event : in Event.item'Class) is abstract;