|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 18937 (0x49f9)
Types: TextFile
Names: »B«
└─⟦149519bd4⟧ Bits:30000546 8mm tape, Rational 1000, !projects 93-07-13
└─ ⟦124ff5788⟧ »DATA«
└─⟦this⟧
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦this⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦this⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─ ⟦d65440be7⟧ »DATA«
└─⟦this⟧
-------------------------------------------------------------------------------
with Direct_Io;
with Text_Io;
with Request;
with Notice;
package body Database is
File_Request_Name : constant String := "requests";
File_Notice_Name : constant String := "notices";
Request_File : Request_Io.File_Type;
Notice_File : Notice_Io.File_Type;
--------------------------------------------------------------------------
procedure Succ (Count : in out Request_Io.Count) is
begin
if (Natural (Count) < Natural (Request_Io.Count'Last)) then
Count := Request_Io.Count'Succ (Count);
end if;
end Succ;
--------------------------------------------------------------------------
procedure Pred (Count : in out Request_Io.Count) is
begin
if (Natural (Count) > Natural (Request_Io.Count'First)) then
Count := Request_Io.Count'Pred (Count);
end if;
end Pred;
--------------------------------------------------------------------------
procedure Succ (Count : in out Notice_Io.Count) is
begin
if (Natural (Count) < Natural (Notice_Io.Count'Last)) then
Count := Notice_Io.Count'Succ (Count);
end if;
end Succ;
--------------------------------------------------------------------------
procedure Pred (Count : in out Notice_Io.Count) is
begin
if (Natural (Count) > Natural (Notice_Io.Count'First)) then
Count := Notice_Io.Count'Pred (Count);
end if;
end Pred;
--------------------------------------------------------------------------
procedure Put (The_Element : Request.Element;
Action : Actions := Performed;
Status : States := Unlock) is
Count : Request_Io.Count;
R_Data : Request_Data;
begin
R_Data.The_Element := The_Element;
Request.Add_Handler (Umps_Defs.Any_Behaviors, R_Data.The_Element);
R_Data.State := Status;
R_Data.Action := Action;
Count := Request_Io.Size (Request_File);
Succ (Count);
Request_Io.Write (Request_File, R_Data, Count);
exception
when Request_Io.Use_Error =>
raise Too_Many_Requests_Error;
when Request_Io.Mode_Error =>
raise Internal_Error;
when Request_Io.Device_Error =>
raise Device_Error;
end Put;
--------------------------------------------------------------------------
procedure Put (The_Element : Notice.Element) is
Count : Notice_Io.Count;
N_Data : Notice_Data;
begin
N_Data.The_Element := The_Element;
Notice.Add_Handler (Umps_Defs.Any_Behaviors, N_Data.The_Element);
Count := Notice_Io.Size (Notice_File);
Succ (Count);
Notice_Io.Write (Notice_File, N_Data, Count);
exception
when Notice_Io.Use_Error =>
raise Too_Many_Requests_Error;
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Put;
--------------------------------------------------------------------------
procedure Next (Iter : in out Iter_Request) is
Element : Request.Element;
R_Data : Request_Data;
function Is_Field_Equal is new Request.Is_Equal (Field => Iter.Field);
begin
Succ (Iter.Count);
Request_Io.Set_Index (Request_File, Iter.Count);
Search_Next_Element:
while (not Request_Io.End_Of_File (Request_File)) loop
Request_Io.Read (Request_File, R_Data);
if ((Iter.State = States'(Both) or else
R_Data.State = Iter.State) and then
(Iter.Action = Actions'(Both) or else
R_Data.Action = Iter.Action)) then
Element := Iter.Condition_Data;
if (Request.Sender (Element) = Umps_Defs.Any_Behaviors) then
Request.Add_Sender
(Request.Sender (R_Data.The_Element), Element);
end if;
exit Search_Next_Element when
Is_Field_Equal (R_Data.The_Element, Element);
end if;
Succ (Iter.Count);
end loop Search_Next_Element;
exception
when Notice_Io.End_Error =>
raise Internal_Error;
when Notice_Io.Data_Error =>
raise Integrity_Error;
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Next;
--------------------------------------------------------------------------
procedure Next (Iter : in out Iter_Notice) is
Element : Notice.Element;
N_Data : Notice_Data;
function Is_Field_Equal is new Notice.Is_Equal (Field => Iter.Field);
begin
Succ (Iter.Count);
Notice_Io.Set_Index (Notice_File, Iter.Count);
Search_Next_Element:
while (not Notice_Io.End_Of_File (Notice_File)) loop
Notice_Io.Read (Notice_File, N_Data);
Element := Iter.Condition_Data;
if (Notice.Sender (Element) = Umps_Defs.Any_Behaviors) then
Notice.Add_Sender
(Notice.Sender (N_Data.The_Element), Element);
end if; -- They must have the same behavior number
exit Search_Next_Element when Is_Field_Equal
(N_Data.The_Element, Element);
Succ (Iter.Count);
end loop Search_Next_Element;
exception
when Notice_Io.End_Error =>
raise Internal_Error;
when Notice_Io.Data_Error =>
raise Integrity_Error;
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Next;
--------------------------------------------------------------------------
procedure Init (Iter : in out Iter_Request;
On : Request.Element;
Field : Slot.Fields := Slot.On_Value;
Action : Actions := Interested;
State : States := Unlock;
Behavior : Umps_Defs.Behavior_Number :=
Umps_Defs.Any_Behaviors) is
begin
Iter.Condition_Data := On;
Request.Add_Sender (Behavior, Into => Iter.Condition_Data);
Request.Add_Handler (Umps_Defs.Any_Behaviors,
Into => Iter.Condition_Data);
Iter.Count := Request_Io.Count'First;
Iter.Field := Field;
Iter.State := State;
Iter.Action := Action;
Next (Iter);
end Init;
--------------------------------------------------------------------------
procedure Init (Iter : in out Iter_Notice;
On : Notice.Element;
Field : Slot.Fields := Slot.On_Value;
Behavior : Umps_Defs.Behavior_Number :=
Umps_Defs.Any_Behaviors
) is
begin
Iter.Condition_Data := On;
Notice.Add_Sender (Behavior, Into => Iter.Condition_Data);
Notice.Add_Handler (Umps_Defs.Any_Behaviors,
Into => Iter.Condition_Data);
Iter.Count := Notice_Io.Count'First;
Iter.Field := Field;
Next (Iter);
end Init;
--------------------------------------------------------------------------
function Done (Iter : Iter_Request) return Boolean is
begin
return (Natural (Iter.Count) > Natural
(Request_Io.Size (Request_File)));
end Done;
--------------------------------------------------------------------------
function Done (Iter : Iter_Notice) return Boolean is
begin
return (Natural (Iter.Count) > Natural (Notice_Io.Size (Notice_File)));
end Done;
--------------------------------------------------------------------------
procedure Value (Iter : Iter_Request;
The_Element : out Request.Element;
Action : out Actions;
State : out States) is
R_Data : Request_Data;
begin
if (not Done (Iter)) then
Request_Io.Read (Request_File, R_Data, Iter.Count);
The_Element := R_Data.The_Element;
Action := R_Data.Action;
State := R_Data.State;
else
raise Iterator_Error;
end if;
exception
when Request_Io.End_Error =>
raise Internal_Error;
when Request_Io.Data_Error =>
raise Integrity_Error;
when Request_Io.Mode_Error =>
raise Internal_Error;
when Request_Io.Device_Error =>
raise Device_Error;
end Value;
--------------------------------------------------------------------------
procedure Value (Iter : Iter_Notice; The_Element : out Notice.Element) is
N_Data : Notice_Data;
begin
if (not Done (Iter)) then
Notice_Io.Read (Notice_File, N_Data, Iter.Count);
The_Element := N_Data.The_Element;
else
raise Iterator_Error;
end if;
exception
when Notice_Io.End_Error =>
raise Internal_Error;
when Notice_Io.Data_Error =>
raise Integrity_Error;
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Value;
--------------------------------------------------------------------------
procedure Replace (Iter : Iter_Request;
The_Element : Request.Element;
With_Action : Actions := Performed;
With_State : States := Unlock) is
R_Data : Request_Data;
begin
R_Data.The_Element := The_Element;
R_Data.Action := With_Action;
R_Data.State := With_State;
Request_Io.Write (Request_File, R_Data, Iter.Count);
exception
when Request_Io.Use_Error =>
raise Internal_Error;
-- It's a rewrite
when Request_Io.Mode_Error =>
raise Internal_Error;
when Request_Io.Device_Error =>
raise Device_Error;
end Replace;
--------------------------------------------------------------------------
procedure Replace (Iter : Iter_Notice; The_Element : Notice.Element) is
N_Data : Notice_Data;
begin
N_Data.The_Element := The_Element;
Notice_Io.Write (File => Notice_File, Item => N_Data, To => Iter.Count);
exception
when Notice_Io.Use_Error =>
raise Internal_Error;
-- It's a rewrite
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Replace;
--------------------------------------------------------------------------
procedure Display (R_Data : Request_Data; String_Before : String := "") is
begin
Text_Io.Put_Line (String_Before & "State => " &
States'Image (R_Data.State));
Text_Io.Put_Line (String_Before & "Action => " &
Actions'Image (R_Data.Action));
Request.Display (R_Data.The_Element, String_Before & " ");
end Display;
--------------------------------------------------------------------------
procedure Display (N_Data : Notice_Data; String_Before : String := "") is
begin
Notice.Display (N_Data.The_Element, String_Before);
end Display;
--------------------------------------------------------------------------
procedure Display_Requests (String_Before : String := "") is
begin
if (Natural (Request_Io.Size (Request_File)) = 0) then
Text_Io.Put_Line (String_Before & "<empty>");
return;
end if;
Display_All:
declare
R_Data : Request_Data;
begin
Request_Io.Set_Index (Request_File,
Request_Io.Positive_Count'First);
Read_And_Display_All:
while (not Request_Io.End_Of_File (Request_File)) loop
Request_Io.Read (Request_File, R_Data);
Display (R_Data, String_Before);
end loop Read_And_Display_All;
exception
when Request_Io.End_Error =>
raise Internal_Error;
when Request_Io.Data_Error =>
raise Integrity_Error;
when Request_Io.Mode_Error =>
raise Internal_Error;
when Request_Io.Device_Error =>
raise Device_Error;
end Display_All;
end Display_Requests;
--------------------------------------------------------------------------
procedure Display_Notices (String_Before : String := "") is
begin
if (Natural (Notice_Io.Size (Notice_File)) = 0) then
Text_Io.Put_Line (String_Before & "<empty>");
return;
end if;
Display_All:
declare
Element : Notice_Data;
begin
Notice_Io.Set_Index (Notice_File,
Notice_Io.Positive_Count'First);
Read_And_Display_All:
while (not Notice_Io.End_Of_File (Notice_File)) loop
Notice_Io.Read (Notice_File, Element);
Display (Element, String_Before);
end loop Read_And_Display_All;
exception
when Notice_Io.End_Error =>
raise Internal_Error;
when Notice_Io.Data_Error =>
raise Integrity_Error;
when Notice_Io.Mode_Error =>
raise Internal_Error;
when Notice_Io.Device_Error =>
raise Device_Error;
end Display_All;
end Display_Notices;
--------------------------------------------------------------------------
procedure Display is
begin
Text_Io.New_Line;
Text_Io.New_Line;
Text_Io.Put_Line ("-- Requests :");
Display_Requests (" ");
Text_Io.Put_Line ("-- End Requests");
Text_Io.New_Line;
Text_Io.New_Line;
Text_Io.Put_Line ("-- Notices : ");
Display_Notices (" ");
Text_Io.Put_Line ("-- End Notices");
end Display;
--------------------------------------------------------------------------
procedure Open_Anyway_Request_File is
begin
Request_Io.Open (File => Request_File,
Mode => Request_Io.Inout_File,
Name => File_Request_Name);
exception
when Request_Io.Name_Error =>
Creating_Files:
declare
begin
Request_Io.Create (File => Request_File,
Mode => Request_Io.Inout_File,
Name => File_Request_Name);
exception
when Request_Io.Status_Error =>
raise Already_Open_Error;
when Request_Io.Name_Error | Request_Io.Use_Error =>
raise Internal_Error;
end Creating_Files;
when Request_Io.Status_Error =>
raise Already_Open_Error;
when Request_Io.Use_Error =>
raise Internal_Error;
end Open_Anyway_Request_File;
--------------------------------------------------------------------------
procedure Open_Anyway_Notice_File is
begin
Notice_Io.Open (File => Notice_File,
Mode => Notice_Io.Inout_File,
Name => File_Notice_Name);
exception
when Notice_Io.Name_Error =>
Creating_Files:
declare
begin
Notice_Io.Create (File => Notice_File,
Mode => Notice_Io.Inout_File,
Name => File_Notice_Name);
exception
when Notice_Io.Status_Error =>
raise Already_Open_Error;
when Notice_Io.Name_Error | Notice_Io.Use_Error =>
raise Internal_Error;
end Creating_Files;
when Notice_Io.Status_Error =>
raise Already_Open_Error;
when Notice_Io.Use_Error =>
raise Internal_Error;
end Open_Anyway_Notice_File;
--------------------------------------------------------------------------
procedure Destroy is
begin
Request_Io.Open (File => Request_File,
Mode => Request_Io.Inout_File,
Name => File_Request_Name);
Notice_Io.Open (File => Notice_File,
Mode => Notice_Io.Inout_File,
Name => File_Notice_Name);
raise Already_Open_Error;
exception
when Already_Open_Error | Request_Io.Status_Error =>
Deleting_Files:
declare
begin
Request_Io.Delete (Request_File);
Notice_Io.Delete (Notice_File);
exception
when Request_Io.Status_Error =>
null;
when Request_Io.Use_Error =>
raise Internal_Error;
end Deleting_Files;
when Request_Io.Device_Error =>
raise Device_Error;
when Request_Io.Name_Error | Request_Io.Use_Error =>
null;
end Destroy;
--------------------------------------------------------------------------
procedure Open is
begin
Open_Anyway_Request_File;
Open_Anyway_Notice_File;
end Open;
--------------------------------------------------------------------------
procedure Close is
begin
Open_Anyway_Request_File;
Open_Anyway_Notice_File;
raise Already_Open_Error;
exception
when Already_Open_Error =>
Request_Io.Close (Request_File);
Notice_Io.Close (Notice_File);
end Close;
end Database;
------------------------------------------------------------------------------