|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 35840 (0x8c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Broker, seg_027f7a
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦this⟧
-------------------------------------------------------------------------------
with Umps_Defs;
with Database;
with Temporary;
with Canvas;
with Broker_Defs;
with Notice;
with Request;
with Wild_String;
with Slot;
with Set;
with Text_Io;
package body Broker is
Character_Message_Max : constant Natural := 4000;
No_Error : constant Broker_Defs.Result := 0;
Protocol_Error : constant Broker_Defs.Result := 1000;
Already_Exist_Error : constant Broker_Defs.Result := 1001;
Database_Requests_Full_Error : constant Broker_Defs.Result := 1002;
Database_Notices_Full_Error : constant Broker_Defs.Result := 1003;
Database_Device_Error : constant Broker_Defs.Result := 1004;
Database_Internal_Error : constant Broker_Defs.Result := 1005;
Cannot_Found_Behavior_Error : constant Broker_Defs.Result := 1006;
Query : constant String := "Query";
End_Query : constant String := "End_Query";
Observation : constant String := "Observation";
---------------------------------------------------------------------------
procedure Put_Notice (The_Full_Notice : Canvas.Object;
With_Status : Broker_Defs.Status;
With_Error : Broker_Defs.Result) is
Message_Sended : Boolean;
A_Full_Notice : Canvas.Object := The_Full_Notice;
begin
Canvas.Add_Status (With_Status, A_Full_Notice);
Canvas.Add_Result (With_Error, A_Full_Notice);
Temporary.Put (Canvas.Image (A_Full_Notice), Message_Sended);
if (not Message_Sended) then
null;
end if;
end Put_Notice;
---------------------------------------------------------------------------
procedure Put_Back_Notice (The_Full_Notice : Canvas.Object;
With_Status : Broker_Defs.Status;
With_Error : Broker_Defs.Result) is
Message_Sended : Boolean;
The_Notice : Notice.Element := Canvas.Element_Of (The_Full_Notice);
A_Full_Notice : Canvas.Object := The_Full_Notice;
begin
Canvas.Add_Status (With_Status, A_Full_Notice);
Canvas.Add_Result (With_Error, A_Full_Notice);
Notice.Add_Handler (Notice.Sender (The_Notice), The_Notice);
Canvas.Add_Element (The_Notice, A_Full_Notice);
Temporary.Put (Canvas.Image (A_Full_Notice), Message_Sended);
if (not Message_Sended) then
null;
end if;
end Put_Back_Notice;
---------------------------------------------------------------------------
procedure Put_Request (The_Full_Request : Canvas.Object;
With_Status : Broker_Defs.Status;
With_Error : Broker_Defs.Result) is
Message_Sended : Boolean;
A_Full_Request : Canvas.Object := The_Full_Request;
begin
Canvas.Add_Status (With_Status, A_Full_Request);
Canvas.Add_Result (With_Error, A_Full_Request);
Temporary.Put (Canvas.Image (A_Full_Request), Message_Sended);
if (not Message_Sended) then
null;
end if;
end Put_Request;
---------------------------------------------------------------------------
procedure Put_Back_Request (The_Full_Request : Canvas.Object;
With_Status : Broker_Defs.Status;
With_Error : Broker_Defs.Result) is
Message_Sended : Boolean;
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
A_Full_Request : Canvas.Object := The_Full_Request;
begin
Canvas.Add_Status (With_Status, A_Full_Request);
Canvas.Add_Result (With_Error, A_Full_Request);
Request.Add_Handler (Request.Sender (The_Request), The_Request);
Canvas.Add_Element (The_Request, A_Full_Request);
Temporary.Put (Canvas.Image (A_Full_Request), Message_Sended);
if (not Message_Sended) then
null;
end if;
end Put_Back_Request;
---------------------------------------------------------------------------
procedure Record_Request (The_Full_Request : Canvas.Object;
The_Action : Database.Actions) is
Finding_Into : Boolean := False;
Iter : Database.Iter_Request;
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
A_Request : Request.Element;
Action : Database.Actions;
State : Database.States;
begin
Database.Init (Iter,
On => The_Request,
Field => Slot.On_Value,
Action => The_Action,
State => Database.States'(Database.Both),
Behavior => Request.Sender (The_Request));
Search_If_The_Request_Is_Already_Into:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Request, Action, State);
Finding_Into := True;
exit Search_If_The_Request_Is_Already_Into;
Database.Next (Iter); -- Never execute
end loop Search_If_The_Request_Is_Already_Into;
if (not Finding_Into) then
Database.Put (The_Request, The_Action);
Put_Back_Request (The_Full_Request, Broker_Defs.Done, No_Error);
else -- Finding_Into
Put_Back_Request (The_Full_Request, Broker_Defs.Failed,
Already_Exist_Error);
end if;
exception
when Database.Too_Many_Requests_Error =>
Put_Back_Request (The_Full_Request, Broker_Defs.Failed,
Database_Requests_Full_Error);
when Database.Device_Error =>
Put_Back_Request (The_Full_Request, Broker_Defs.Failed,
Database_Device_Error);
when others =>
Put_Back_Request (The_Full_Request, Broker_Defs.Failed,
Database_Internal_Error);
end Record_Request;
---------------------------------------------------------------------------
procedure Register_Request (The_Full_Request : Canvas.Object) is
begin
if (Wild_String.Is_With_Wildcards
(Request.Method (Canvas.Element_Of (The_Full_Request)))) then
Put_Back_Request (The_Full_Request,
Broker_Defs.Failed, Protocol_Error);
else
Record_Request (The_Full_Request, Database.Performed);
end if;
end Register_Request;
---------------------------------------------------------------------------
procedure Observe_Request (The_Full_Request : Canvas.Object) is
begin
Record_Request (The_Full_Request, Database.Interested);
end Observe_Request;
---------------------------------------------------------------------------
function Put_Into_Full_Notice (The_Request : Request.Element;
With_Handler : Umps_Defs.Behavior_Number;
With_Class : String) return Canvas.Object is
The_Full_Notice : Canvas.Object := Canvas.Create_Notice;
A_Notice : Notice.Element;
begin
Notice.Add_Sender (Request.Sender (The_Request), A_Notice);
Notice.Add_Handler (With_Handler, A_Notice);
Notice.Add_Class (With_Class, A_Notice);
Notice.Add_Id (Request.Method (The_Request), A_Notice);
Notice.Add_Params (Request.Params (The_Request), A_Notice);
Canvas.Add_Element (A_Notice, The_Full_Notice);
return The_Full_Notice;
end Put_Into_Full_Notice;
---------------------------------------------------------------------------
procedure Query_Request (The_Full_Request : Canvas.Object) is
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
Iter : Database.Iter_Request;
A_Request : Request.Element;
A_Notice : Notice.Element;
Action : Database.Actions;
State : Database.States;
The_Field : Slot.Fields := Slot.On_Value;
begin
Put_Back_Request (The_Full_Request, Broker_Defs.Handled, No_Error);
if (Set.Is_Empty (Request.Params (The_Request))) then
The_Field := Slot.On_None;
end if;
Database.Init (Iter,
On => The_Request,
Field => The_Field,
Action => Database.Performed,
State => Database.States'(Database.Both));
Search_All_Requests_Corresponding_To_Query:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Request, Action, State);
Put_Notice (Put_Into_Full_Notice
(A_Request,
With_Handler => Request.Sender (The_Request),
With_Class => Query),
Broker_Defs.Send, No_Error);
Database.Next (Iter);
end loop Search_All_Requests_Corresponding_To_Query;
Put_Notice (Put_Into_Full_Notice
(The_Request,
With_Handler => Request.Sender (The_Request),
With_Class => End_Query), Broker_Defs.Send, No_Error);
exception
when Database.Device_Error =>
Put_Back_Notice (Put_Into_Full_Notice
(The_Request,
With_Handler => Request.Sender (The_Request),
With_Class => Query),
Broker_Defs.Failed, Database_Device_Error);
when others =>
Put_Back_Notice (Put_Into_Full_Notice
(The_Request,
With_Handler => Request.Sender (The_Request),
With_Class => Query),
Broker_Defs.Failed, Database_Internal_Error);
end Query_Request;
---------------------------------------------------------------------------
procedure Send_To_All_Interested_Behaviors
(The_Full_Request : Canvas.Object) is
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
A_Request : Request.Element;
Iter : Database.Iter_Request;
The_Sender : Umps_Defs.Behavior_Number := Request.Sender (The_Request);
A_Handler : Umps_Defs.Behavior_Number;
The_Handler : Umps_Defs.Behavior_Number :=
Request.Handler (The_Request);
Action : Database.Actions;
State : Database.States;
begin
Database.Init (Iter,
On => The_Request,
Field => Slot.On_Value,
Action => Database.Interested);
Search_All_Behaviors_Interested_By:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Request, Action, State);
A_Handler := Request.Sender (A_Request);
if (The_Sender /= A_Handler and then
The_Handler /= A_Handler) then
Put_Notice (Put_Into_Full_Notice
(The_Request,
With_Handler => A_Handler,
With_Class => Observation),
Broker_Defs.Send, No_Error);
end if;
Database.Next (Iter);
end loop Search_All_Behaviors_Interested_By;
exception
when others =>
null; -- if an error occurs then ignore them
end Send_To_All_Interested_Behaviors;
---------------------------------------------------------------------------
procedure Complete_Empties_Values (Source : Request.Element;
Destination : in out Request.Element) is
function Is_Value_Equal is
new Request.Is_Equal (Field => Slot.On_Value);
begin
if (not Is_Value_Equal (Source, Destination)) then
declare
Iter_Source : Set.Iterator;
Iter_Dest : Set.Iterator;
Params_Source : Set.Object := Request.Params (Source);
Params_Dest : Set.Object := Request.Params (Destination);
New_Params : Set.Object := Set.Null_Object;
Elt_Source : Slot.Element;
Elt_Dest : Slot.Element;
begin
Set.Init (Iter_Source, Params_Source);
Set.Init (Iter_Dest, Params_Dest);
while (not Set.Done (Iter_Source, Params_Source)) loop
Elt_Source := Set.Value (Iter_Source, Params_Source);
Elt_Dest := Set.Value (Iter_Dest, Params_Dest);
if (Slot.Is_Empty_Value (Elt_Dest)) then
New_Params := Set.Add (Elt_Source, New_Params);
else
New_Params := Set.Add (Elt_Dest, New_Params);
end if;
Set.Next (Iter_Source, Params_Source);
Set.Next (Iter_Dest, Params_Dest);
end loop;
Request.Add_Params (New_Params, Destination);
end;
end if;
end Complete_Empties_Values;
---------------------------------------------------------------------------
procedure Send_Request_To_Behaviors (The_Full_Request : Canvas.Object) is
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
A_Request : Request.Element;
Iter : Database.Iter_Request;
Finding : Boolean := False;
Action : Database.Actions;
State : Database.States;
A_Full_Request : Canvas.Object := The_Full_Request;
begin
Database.Init (Iter,
On => The_Request,
Field => Slot.On_Kind,
Action => Database.Performed,
State => Database.Unlock,
Behavior => Request.Handler (The_Request));
Search_The_Request_Corresponding_To_Send:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Request, Action, State);
Request.Add_Handler (Request.Sender (A_Request), The_Request);
Canvas.Add_Element (The_Request, A_Full_Request);
Database.Replace (Iter,
The_Element => A_Request,
With_Action => Database.Performed,
With_State => Database.Lock);
Complete_Empties_Values (Source => A_Request,
Destination => The_Request);
Canvas.Add_Element (The_Request, A_Full_Request);
Put_Request (A_Full_Request, Broker_Defs.Send, No_Error);
Finding := True;
exit Search_The_Request_Corresponding_To_Send;
Database.Next (Iter); -- never execute =>
-- searching for only one
end loop Search_The_Request_Corresponding_To_Send;
if (not Finding) then
Put_Back_Request (The_Full_Request, Broker_Defs.Failed,
Cannot_Found_Behavior_Error);
else
Send_To_All_Interested_Behaviors (A_Full_Request);
end if;
end Send_Request_To_Behaviors;
---------------------------------------------------------------------------
procedure Send_Request (The_Full_Request : Canvas.Object) is
begin
if (Wild_String.Is_With_Wildcards
(Request.Method (Canvas.Element_Of (The_Full_Request)))) then
Put_Back_Request (The_Full_Request,
Broker_Defs.Failed, Protocol_Error);
else
Send_Request_To_Behaviors (The_Full_Request);
end if;
end Send_Request;
---------------------------------------------------------------------------
procedure Relax_Behavior_And_Propage (The_Full_Request : Canvas.Object) is
Iter : Database.Iter_Request;
The_Request : Request.Element := Canvas.Element_Of (The_Full_Request);
A_Request : Request.Element;
Action : Database.Actions;
State : Database.States;
begin
Database.Init (Iter,
On => The_Request,
Field => Slot.On_Kind,
Action => Database.Performed,
State => Database.Lock,
Behavior => Request.Sender (The_Request));
Search_The_Request_Corresponding_To_End_Execution:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Request, Action, State);
Database.Replace (Iter,
The_Element => A_Request,
With_Action => Database.Performed,
With_State => Database.Unlock);
Put_Request (The_Full_Request,
Canvas.Status_Of (The_Full_Request),
Canvas.Result_Of (The_Full_Request));
exit Search_The_Request_Corresponding_To_End_Execution;
Database.Next (Iter); -- never execute =>
-- searching for only one
end loop Search_The_Request_Corresponding_To_End_Execution;
end Relax_Behavior_And_Propage;
---------------------------------------------------------------------------
procedure Dispatch_Request (The_Full_Request : Canvas.Object) is
begin
case (Canvas.Status_Of (The_Full_Request)) is
when Broker_Defs.Register =>
Register_Request (The_Full_Request);
when Broker_Defs.Observed =>
Observe_Request (The_Full_Request);
when Broker_Defs.Query =>
Query_Request (The_Full_Request);
when Broker_Defs.Send =>
Send_Request (The_Full_Request);
when Broker_Defs.Failed =>
Relax_Behavior_And_Propage (The_Full_Request);
when Broker_Defs.Handled =>
Relax_Behavior_And_Propage (The_Full_Request);
when Broker_Defs.Done =>
Relax_Behavior_And_Propage (The_Full_Request);
when others =>
Put_Back_Request (The_Full_Request,
Broker_Defs.Failed, Protocol_Error);
end case;
end Dispatch_Request;
---------------------------------------------------------------------------
procedure Observe_Notice (The_Full_Notice : Canvas.Object) is
Iter : Database.Iter_Notice;
The_Notice : Notice.Element := Canvas.Element_Of (The_Full_Notice);
Finding_Into : Boolean := False;
A_Notice : Notice.Element;
begin
Database.Init (Iter,
On => The_Notice,
Behavior => Notice.Sender (The_Notice));
Search_If_The_Notice_Is_Already_Into:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Notice);
Finding_Into := True;
exit Search_If_The_Notice_Is_Already_Into;
Database.Next (Iter); -- Never execute
end loop Search_If_The_Notice_Is_Already_Into;
if (not Finding_Into) then
Database.Put (The_Notice);
end if;
exception
when Database.Too_Many_Notices_Error =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Failed,
Database_Notices_Full_Error);
when Database.Device_Error =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Failed,
Database_Device_Error);
when others =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Failed,
Database_Internal_Error);
end Observe_Notice;
---------------------------------------------------------------------------
procedure Send_Notice_To_The_Behaviors (The_Full_Notice : Canvas.Object) is
Behavior_Interested : Umps_Defs.Behavior_Number;
The_Notice : Notice.Element := Canvas.Element_Of (The_Full_Notice);
The_Sender : Umps_Defs.Behavior_Number := Notice.Sender (The_Notice);
The_Handler : Umps_Defs.Behavior_Number := Notice.Handler (The_Notice);
Iter : Database.Iter_Notice;
A_Notice : Notice.Element;
A_Full_Notice : Canvas.Object := The_Full_Notice;
begin
Database.Init (Iter, On => The_Notice);
Search_All_Behaviors_Interested_By_The_Notice:
while (not Database.Done (Iter)) loop
Database.Value (Iter, A_Notice);
Behavior_Interested := Notice.Sender (A_Notice);
if (Behavior_Interested /= The_Sender and then
Behavior_Interested /= The_Handler) then
Notice.Add_Sender (The_Sender, The_Notice);
Notice.Add_Handler (Behavior_Interested, The_Notice);
Canvas.Add_Element (The_Notice, A_Full_Notice);
Put_Notice (A_Full_Notice, Broker_Defs.Send, No_Error);
end if;
Database.Next (Iter);
end loop Search_All_Behaviors_Interested_By_The_Notice;
if (The_Handler /= Umps_Defs.Any_Behaviors) then
Notice.Add_Sender (The_Sender, The_Notice);
Notice.Add_Handler (The_Handler, The_Notice);
Canvas.Add_Element (The_Notice, A_Full_Notice);
Put_Notice (A_Full_Notice, Broker_Defs.Send, No_Error);
end if;
exception
when Database.Device_Error =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Send,
Database_Device_Error);
when others =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Send,
Database_Internal_Error);
end Send_Notice_To_The_Behaviors;
---------------------------------------------------------------------------
procedure Send_Notice (The_Full_Notice : Canvas.Object) is
The_Notice : Notice.Element := Canvas.Element_Of (The_Full_Notice);
begin
if (Wild_String.Is_With_Wildcards (Notice.Class (The_Notice)) or else
Wild_String.Is_With_Wildcards (Notice.Id (The_Notice))) then
Put_Back_Notice (The_Full_Notice, Broker_Defs.Failed,
Protocol_Error);
else
Send_Notice_To_The_Behaviors (The_Full_Notice);
end if;
end Send_Notice;
---------------------------------------------------------------------------
procedure Dispatch_Notice (The_Full_Notice : Canvas.Object) is
begin
case (Canvas.Status_Of (The_Full_Notice)) is
when Broker_Defs.Observed =>
Observe_Notice (The_Full_Notice);
when Broker_Defs.Send =>
Send_Notice (The_Full_Notice);
when others =>
Put_Back_Notice (The_Full_Notice, Broker_Defs.Failed,
Protocol_Error);
end case;
end Dispatch_Notice;
---------------------------------------------------------------------------
procedure Dispatch_Message (The_Message : Canvas.Object) is
use Broker_Defs;
begin
if (Canvas.Class_Of (The_Message) = Broker_Defs.Request) then
Dispatch_Request (The_Message);
else
Dispatch_Notice (The_Message);
end if;
end Dispatch_Message;
---------------------------------------------------------------------------
procedure Start is
A_Message : String (1 .. Character_Message_Max);
Message_Size : Natural;
Message_Receive : Boolean;
The_Message : Canvas.Object;
begin
Database.Open;
Temporary.Init;
Forever:
loop
Temporary.Get (A_Message, Message_Size, Message_Receive);
if (Message_Receive) then
The_Message := Canvas.Value (A_Message (A_Message'First ..
Message_Size));
Text_Io.Put_Line ("--> Message recu : " &
Canvas.Image (The_Message));
Dispatch_Message (The_Message);
end if;
end loop Forever;
exception
when Database.Internal_Error =>
Text_Io.Put_Line ("*** Verify your access rigths");
raise;
when others =>
raise;
end Start;
end Broker;
-------------------------------------------------------------------------------
nblk1=22
nid=7
hdr6=3c
[0x00] rec0=1e rec1=00 rec2=01 rec3=00e
[0x01] rec0=16 rec1=00 rec2=11 rec3=016
[0x02] rec0=00 rec1=00 rec2=19 rec3=002
[0x03] rec0=15 rec1=00 rec2=15 rec3=012
[0x04] rec0=17 rec1=00 rec2=10 rec3=046
[0x05] rec0=18 rec1=00 rec2=0f rec3=004
[0x06] rec0=15 rec1=00 rec2=04 rec3=00c
[0x07] rec0=16 rec1=00 rec2=13 rec3=086
[0x08] rec0=15 rec1=00 rec2=17 rec3=01c
[0x09] rec0=16 rec1=00 rec2=18 rec3=080
[0x0a] rec0=01 rec1=00 rec2=08 rec3=00e
[0x0b] rec0=14 rec1=00 rec2=05 rec3=068
[0x0c] rec0=12 rec1=00 rec2=1e rec3=058
[0x0d] rec0=0a rec1=00 rec2=0c rec3=028
[0x0e] rec0=16 rec1=00 rec2=02 rec3=084
[0x0f] rec0=14 rec1=00 rec2=21 rec3=044
[0x10] rec0=14 rec1=00 rec2=12 rec3=032
[0x11] rec0=14 rec1=00 rec2=1c rec3=058
[0x12] rec0=15 rec1=00 rec2=22 rec3=034
[0x13] rec0=10 rec1=00 rec2=1a rec3=05a
[0x14] rec0=14 rec1=00 rec2=16 rec3=074
[0x15] rec0=16 rec1=00 rec2=03 rec3=026
[0x16] rec0=16 rec1=00 rec2=20 rec3=052
[0x17] rec0=17 rec1=00 rec2=09 rec3=010
[0x18] rec0=16 rec1=00 rec2=1b rec3=02e
[0x19] rec0=15 rec1=00 rec2=14 rec3=020
[0x1a] rec0=17 rec1=00 rec2=0d rec3=01c
[0x1b] rec0=01 rec1=00 rec2=06 rec3=01e
[0x1c] rec0=1a rec1=00 rec2=0a rec3=02c
[0x1d] rec0=1b rec1=00 rec2=0e rec3=000
[0x1e] rec0=1b rec1=00 rec2=0e rec3=000
[0x1f] rec0=00 rec1=00 rec2=00 rec3=000
[0x20] rec0=8c rec1=00 rec2=00 rec3=000
[0x21] rec0=00 rec1=00 rec2=15 rec3=7cf
tail 0x21520d49883ad7d1004b3 0x42a00088462063c03
Free Block Chain:
0x7: 0000 00 0b 00 16 80 09 20 22 51 75 65 72 79 22 3b 09 ┆ "Query"; ┆
0xb: 0000 00 1f 02 53 80 08 73 65 2e 4f 70 65 6e 3b 08 00 ┆ S se.Open; ┆
0x1f: 0000 00 1d 00 0a 80 07 20 4f 62 73 65 72 76 07 20 20 ┆ Observ ┆
0x1d: 0000 00 00 00 13 80 10 74 5f 49 73 5f 41 6c 72 65 61 ┆ t_Is_Alrea┆