lace.event: Add an event connector to speed up remote connections.
This commit is contained in:
Rod Kay
378
1-base/lace/source/events/lace-event_connector.adb
Normal file
378
1-base/lace/source/events/lace-event_connector.adb
Normal file
@@ -0,0 +1,378 @@
|
||||
with
|
||||
lace.Event.utility,
|
||||
|
||||
ada.Text_IO,
|
||||
ada.Exceptions,
|
||||
ada.unchecked_Deallocation,
|
||||
ada.Containers.Vectors;
|
||||
|
||||
|
||||
package body lace.event_Connector
|
||||
is
|
||||
|
||||
---------------
|
||||
--- Containers.
|
||||
--
|
||||
|
||||
package connector_Vectors is new ada.Containers.Vectors (Positive,
|
||||
Connector_view);
|
||||
subtype connector_Vector is connector_Vectors.Vector;
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--- Safe connectors.
|
||||
--
|
||||
|
||||
protected
|
||||
type safe_Connectors
|
||||
is
|
||||
procedure add (new_Connector : in Connector_view);
|
||||
procedure get ( a_Connector : out Connector_view);
|
||||
|
||||
private
|
||||
all_Connectors : connector_Vector;
|
||||
end safe_Connectors;
|
||||
|
||||
type safe_Connectors_view is access all safe_Connectors;
|
||||
|
||||
|
||||
|
||||
|
||||
--------------
|
||||
--- Connector.
|
||||
--
|
||||
|
||||
task
|
||||
type Connector
|
||||
is
|
||||
entry connect (Self : in Connector_view;
|
||||
the_Connection : in Connection;
|
||||
Connectors : in safe_Connectors_view);
|
||||
end Connector;
|
||||
|
||||
|
||||
|
||||
task body Connector
|
||||
is
|
||||
use ada.Text_IO,
|
||||
lace.Text;
|
||||
|
||||
Myself : Connector_view;
|
||||
my_Connection : Connection;
|
||||
connector_Pool : safe_Connectors_view;
|
||||
begin
|
||||
loop
|
||||
begin
|
||||
select
|
||||
accept connect (Self : in Connector_view;
|
||||
the_Connection : in Connection;
|
||||
Connectors : in safe_Connectors_view)
|
||||
do
|
||||
my_Connection := the_Connection;
|
||||
Myself := Self;
|
||||
connector_Pool := Connectors;
|
||||
end connect;
|
||||
or
|
||||
terminate;
|
||||
end select;
|
||||
|
||||
if my_Connection.is_Connecting
|
||||
then
|
||||
lace.Event.utility.connect (the_Observer => my_Connection.Observer,
|
||||
to_Subject => my_Connection.Subject,
|
||||
with_Response => my_Connection.Response,
|
||||
to_Event_Kind => Event.Kind (+my_Connection.Event_Kind));
|
||||
else
|
||||
lace.Event.utility.disconnect (the_Observer => my_Connection.Observer,
|
||||
from_Subject => my_Connection.Subject,
|
||||
for_Response => my_Connection.Response,
|
||||
to_Event_Kind => Event.Kind (+my_Connection.Event_Kind),
|
||||
subject_Name => my_Connection.Subject.Name);
|
||||
end if;
|
||||
|
||||
connector_Pool.add (Myself); -- Return the connector to the safe pool.
|
||||
|
||||
exception
|
||||
when E : others =>
|
||||
new_Line;
|
||||
put_Line (ada.Exceptions.exception_Information (E));
|
||||
put_Line ("Error detected in 'lace.event_Connector.Connector' task.");
|
||||
new_Line;
|
||||
put_Line ("Subject: '" & my_Connection.Subject.Name & "'.");
|
||||
put_Line ("Observer: '" & my_Connection.Observer.Name & "'.");
|
||||
put_Line ("Event: '" & (+my_Connection.Event_Kind) & "'.");
|
||||
put_Line ("Response '" & my_Connection.Response.Name & "'.");
|
||||
new_Line;
|
||||
put_Line ("Continuing.");
|
||||
new_Line (2);
|
||||
|
||||
connector_Pool.add (Myself); -- Return the connector to the safe pool.
|
||||
end;
|
||||
end loop;
|
||||
|
||||
exception
|
||||
when E : others =>
|
||||
new_Line;
|
||||
put_Line (ada.Exceptions.exception_Information (E));
|
||||
put_Line ("Fatal error detected in 'lace.event_Connector.Connector' task.");
|
||||
new_Line;
|
||||
put_Line ("Subject: '" & my_Connection.Subject.Name & "'.");
|
||||
put_Line ("Observer: '" & my_Connection.Observer.Name & "'.");
|
||||
put_Line ("Event: '" & (+my_Connection.Event_Kind) & "'.");
|
||||
put_Line ("Response '" & my_Connection.Response.Name & "'.");
|
||||
new_Line (2);
|
||||
end Connector;
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--- Connection delegator.
|
||||
--
|
||||
|
||||
task body connection_Delegator
|
||||
is
|
||||
use ada.Text_IO;
|
||||
|
||||
the_Connectors : aliased safe_Connectors;
|
||||
the_Connections : safe_Connections_view;
|
||||
new_Connections : connection_Vector;
|
||||
Done : Boolean := False;
|
||||
|
||||
|
||||
procedure shutdown
|
||||
is
|
||||
procedure free is new ada.unchecked_Deallocation (Connector,
|
||||
Connector_view);
|
||||
the_Connector : Connector_view;
|
||||
begin
|
||||
loop
|
||||
the_Connectors.get (the_Connector);
|
||||
exit when the_Connector = null;
|
||||
|
||||
free (the_Connector);
|
||||
end loop;
|
||||
end shutdown;
|
||||
|
||||
|
||||
begin
|
||||
ada.text_io.put_Line ("KKK0");
|
||||
|
||||
accept start (Connections : in safe_Connections_view)
|
||||
do
|
||||
ada.text_io.put_Line ("KKK2");
|
||||
|
||||
the_Connections := Connections;
|
||||
ada.text_io.put_Line ("KKK3");
|
||||
|
||||
end start;
|
||||
|
||||
|
||||
loop
|
||||
select
|
||||
accept stop
|
||||
do
|
||||
Done := True;
|
||||
end stop;
|
||||
|
||||
else
|
||||
null;
|
||||
end select;
|
||||
|
||||
|
||||
exit when Done
|
||||
and the_Connections.is_Empty;
|
||||
|
||||
the_Connections.get (new_Connections);
|
||||
|
||||
for each_Connection of new_Connections
|
||||
loop
|
||||
declare
|
||||
use lace.Text;
|
||||
the_Connector : Connector_view;
|
||||
begin
|
||||
the_Connectors.get (the_Connector);
|
||||
|
||||
if the_Connector = null
|
||||
then
|
||||
the_Connector := new Connector;
|
||||
end if;
|
||||
|
||||
the_Connector.connect (Self => the_Connector,
|
||||
the_Connection => each_Connection,
|
||||
Connectors => the_Connectors'unchecked_Access);
|
||||
exception
|
||||
when E : others =>
|
||||
new_Line;
|
||||
put_Line (ada.Exceptions.exception_Information (E));
|
||||
new_Line;
|
||||
put_Line ("Error detected in 'lace.event_Connector.connector_Delegator'.");
|
||||
new_Line;
|
||||
put_Line ("Subject: '" & each_Connection.Subject.Name & "'.");
|
||||
put_Line ("Observer: '" & each_Connection.Observer.Name & "'.");
|
||||
put_Line ("Event: '" & (+each_Connection.Event_Kind) & "'.");
|
||||
put_Line ("Response '" & each_Connection.Response.Name & "'.");
|
||||
new_Line;
|
||||
put_Line ("Continuing.");
|
||||
new_Line (2);
|
||||
end;
|
||||
end loop;
|
||||
|
||||
delay 0.001; -- Keep task from churning when idle.
|
||||
end loop;
|
||||
|
||||
shutdown;
|
||||
|
||||
exception
|
||||
when E : others =>
|
||||
new_Line;
|
||||
put_Line (ada.Exceptions.exception_Information (E));
|
||||
new_Line;
|
||||
put_Line ("Fatal error detected in 'lace.event_Connector.connection_Delegator'.");
|
||||
new_Line (2);
|
||||
|
||||
shutdown;
|
||||
end connection_Delegator;
|
||||
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--- Safe connections.
|
||||
--
|
||||
|
||||
protected body safe_Connections
|
||||
is
|
||||
|
||||
procedure add (new_Connection : in Connection)
|
||||
is
|
||||
begin
|
||||
all_Connections.append (new_Connection);
|
||||
end add;
|
||||
|
||||
|
||||
|
||||
procedure get (the_Connections : out connection_Vector)
|
||||
is
|
||||
begin
|
||||
the_Connections := all_Connections;
|
||||
all_Connections.clear;
|
||||
end get;
|
||||
|
||||
|
||||
|
||||
function is_Empty return Boolean
|
||||
is
|
||||
begin
|
||||
return all_Connections.is_Empty;
|
||||
end is_Empty;
|
||||
|
||||
|
||||
end safe_Connections;
|
||||
|
||||
|
||||
|
||||
|
||||
------------------
|
||||
--- Safe emitters.
|
||||
--
|
||||
|
||||
protected body safe_Connectors
|
||||
is
|
||||
|
||||
procedure add (new_Connector : in Connector_view)
|
||||
is
|
||||
begin
|
||||
all_Connectors.append (new_Connector);
|
||||
end add;
|
||||
|
||||
|
||||
|
||||
procedure get (a_Connector : out Connector_view)
|
||||
is
|
||||
begin
|
||||
if all_Connectors.is_Empty
|
||||
then
|
||||
a_Connector := null;
|
||||
else
|
||||
a_Connector := all_Connectors.last_Element;
|
||||
all_Connectors.delete_Last;
|
||||
end if;
|
||||
end get;
|
||||
|
||||
|
||||
end safe_Connectors;
|
||||
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--- event_Connector item.
|
||||
--
|
||||
|
||||
procedure define (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
ada.text_io.put_Line ("KKK");
|
||||
Self.Delegator.start (Connections => Self.Connections'unchecked_Access);
|
||||
ada.text_io.put_Line ("JJJ");
|
||||
end define;
|
||||
|
||||
|
||||
|
||||
procedure destruct (Self : in out Item)
|
||||
is
|
||||
begin
|
||||
Self.Delegator.stop;
|
||||
end destruct;
|
||||
|
||||
|
||||
|
||||
procedure connect (Self : in out Item; the_Observer : in Observer.view;
|
||||
to_Subject : in Subject .view;
|
||||
with_Response : in Response.view;
|
||||
to_Event_Kind : in Event.Kind)
|
||||
is
|
||||
use lace.Text;
|
||||
|
||||
new_Connection : Connection := (Observer => the_Observer,
|
||||
Subject => to_Subject,
|
||||
Response => with_Response,
|
||||
Event_Kind => <>,
|
||||
subject_Name => <>,
|
||||
is_Connecting => True);
|
||||
begin
|
||||
String_is (new_Connection.Event_Kind,
|
||||
String (to_Event_Kind));
|
||||
|
||||
Self.Connections.add (new_Connection);
|
||||
end connect;
|
||||
|
||||
|
||||
|
||||
procedure disconnect (Self : in out Item; the_Observer : in Observer.view;
|
||||
from_Subject : in Subject .view;
|
||||
for_Response : in Response.view;
|
||||
to_Event_Kind : in Event.Kind;
|
||||
subject_Name : in String)
|
||||
is
|
||||
use lace.Text;
|
||||
|
||||
new_Disconnection : Connection := (Observer => the_Observer,
|
||||
Subject => from_Subject,
|
||||
Response => for_Response,
|
||||
Event_Kind => <>,
|
||||
subject_Name => <>,
|
||||
is_Connecting => False);
|
||||
begin
|
||||
String_is (new_Disconnection.event_Kind,
|
||||
String (to_Event_Kind));
|
||||
|
||||
String_is (new_Disconnection.subject_Name,
|
||||
subject_Name);
|
||||
|
||||
Self.Connections.add (new_Disconnection);
|
||||
end disconnect;
|
||||
|
||||
|
||||
end lace.event_Connector;
|
||||
116
1-base/lace/source/events/lace-event_connector.ads
Normal file
116
1-base/lace/source/events/lace-event_connector.ads
Normal file
@@ -0,0 +1,116 @@
|
||||
with
|
||||
lace.Event,
|
||||
lace.Response,
|
||||
lace.Observer,
|
||||
lace.Subject;
|
||||
|
||||
|
||||
private
|
||||
with
|
||||
lace.Text,
|
||||
ada.Containers.indefinite_Vectors;
|
||||
|
||||
|
||||
package lace.event_Connector
|
||||
is
|
||||
|
||||
type Item is tagged limited private;
|
||||
|
||||
|
||||
procedure define (Self : in out Item);
|
||||
procedure destruct (Self : in out Item);
|
||||
|
||||
procedure connect (Self : in out Item; the_Observer : in Observer.view;
|
||||
to_Subject : in Subject .view;
|
||||
with_Response : in Response.view;
|
||||
to_Event_Kind : in Event.Kind);
|
||||
|
||||
procedure disconnect (Self : in out Item; the_Observer : in Observer.view;
|
||||
from_Subject : in Subject .view;
|
||||
for_Response : in Response.view;
|
||||
to_Event_Kind : in Event.Kind;
|
||||
subject_Name : in String);
|
||||
|
||||
|
||||
private
|
||||
|
||||
--------------
|
||||
--- Connector.
|
||||
--
|
||||
|
||||
type Connector;
|
||||
type Connector_view is access Connector;
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--- Connection.
|
||||
--
|
||||
|
||||
type Connection is
|
||||
record
|
||||
Observer : lace.Observer.view;
|
||||
Subject : lace.Subject .view;
|
||||
Response : lace.Response.view;
|
||||
Event_Kind : lace.Text.item_256;
|
||||
subject_Name : lace.Text.item_256;
|
||||
is_Connecting : Boolean;
|
||||
end record;
|
||||
|
||||
|
||||
|
||||
---------------
|
||||
--- Containers.
|
||||
--
|
||||
|
||||
package connection_Vectors is new ada.Containers.indefinite_Vectors (Positive,
|
||||
Connection);
|
||||
subtype connection_Vector is connection_Vectors.Vector;
|
||||
|
||||
|
||||
|
||||
---------------------
|
||||
--- Safe connections.
|
||||
--
|
||||
|
||||
protected
|
||||
type safe_Connections
|
||||
is
|
||||
procedure add (new_Connection : in Connection);
|
||||
procedure get (the_Connections : out connection_Vector);
|
||||
|
||||
function is_Empty return Boolean;
|
||||
|
||||
private
|
||||
all_Connections : connection_Vector;
|
||||
end safe_Connections;
|
||||
|
||||
type safe_Connections_view is access all safe_Connections;
|
||||
|
||||
|
||||
|
||||
-------------------------
|
||||
--- Connection delegator.
|
||||
--
|
||||
|
||||
task
|
||||
type connection_Delegator
|
||||
is
|
||||
entry start (Connections : in safe_Connections_view);
|
||||
entry stop;
|
||||
end connection_Delegator;
|
||||
|
||||
|
||||
|
||||
---------
|
||||
--- Item.
|
||||
--
|
||||
|
||||
type Item is tagged limited
|
||||
record
|
||||
Connections : aliased safe_Connections;
|
||||
Delegator : connection_Delegator;
|
||||
end record;
|
||||
|
||||
|
||||
end lace.event_Connector;
|
||||
@@ -62,6 +62,7 @@ is
|
||||
end connect;
|
||||
|
||||
|
||||
|
||||
procedure disconnect (the_Observer : in Observer.view;
|
||||
from_Subject : in Subject .view;
|
||||
for_Response : in Response.view;
|
||||
|
||||
Reference in New Issue
Block a user