nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lace.events: Add 'event_Sender'.

Browse Source
This commit is contained in:
Rod Kay
2024-09-16 22:45:31 +10:00
parent bb41976be9
commit 7898ee5f20
8 changed files with 586 additions and 16 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
1-base/lace/source/events/interface/lace-subject.ads
View File

@@ -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.

59
1-base/lace/source/events/mixin/lace-make_subject.adb
View File

@@ -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
--

36
1-base/lace/source/events/mixin/lace-make_subject.ads
View File

@@ -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;

325
1-base/lace/source/events/mixin/private/lace-event_sender.adb Normal file
View File

@@ -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;

107
1-base/lace/source/events/mixin/private/lace-event_sender.ads Normal file
View File

@@ -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;

39
1-base/lace/source/events/utility/lace-event-logger-text.adb
View File

@@ -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;

4
1-base/lace/source/events/utility/lace-event-logger-text.ads
View File

@@ -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);

4
1-base/lace/source/events/utility/lace-event-logger.ads
View File

@@ -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;