|
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: 12288 (0x3000)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Actions, package body Model, package body Module, package body Requirement, seg_010751
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Action;
with Asa_Definitions;
with Calendar;
with Directory;
with Gateway_Object;
with Gateways;
with Hierarchy;
with Logger;
with Object_Class;
with Profile;
with Remote_Operations;
with Simple_Status;
with String_Utilities;
with Unix_Definitions;
pragma Elaborate (Asa_Definitions);
package body Actions is
package Asas renames Asa_Definitions.Switches;
package Asap renames Asa_Definitions.Properties;
package Dir renames Directory;
package Dna renames Directory.Naming;
package Gwo renames Gateway_Object;
package Hchy renames Hierarchy;
package Ro renames Remote_Operations;
package Ss renames Simple_Status;
package Su renames String_Utilities;
package Unix renames Unix_Definitions;
--
-- The following task keeps this package elaborated as long as its
-- STOP entry is not called.
--
Switch_Registration : Asas.Register;
Default_Timeout : constant := 60.0;
-- ---------------------
-- ( ) Gateway utilities
-- ---------------------
function Root_Of (Gateway : in Dir.Object; Action_Id : in Action.Id)
return Dir.Object is
E : Dir.Error_Status;
Gateway_Data : Dir.Statistics.Object_Data;
Result : Dir.Object;
use Dir;
begin
Result := Gateway;
loop
Dir.Statistics.Get_Object_Data (The_Object => Result,
The_Data => Gateway_Data,
Status => E,
Action_Id => Action_Id);
exit when Dir.Get_Class
(Dir.Statistics.Object_Parent (Gateway_Data)) =
Object_Class.Library;
Result := Dir.Statistics.Object_Parent (Gateway_Data);
end loop;
return Result;
end Root_Of;
-- ------------
-- ( ) Currency
-- ------------
procedure Accept_Changes (Gateway_Object : in Dir.Object;
In_Context : in Ro.Context;
Model : in String;
Comments : in String;
Work_Order : in String;
Action_Id : in Action.Id;
Has_Destroyed_Gateway : out Boolean) is
Build_Time : Calendar.Time;
Root_Gateway : Dir.Object;
Root_Iterator : Hchy.Module_Iterator;
Root_Module : Hchy.Module;
The_State : Gateways.State;
begin
--
-- Compute module hierarchy for the associated model.
--
Logger.Note ("Building module hierarchy for model " & Model);
Hchy.Build (Model => Model,
In_Context => In_Context,
Root => Root_Module,
Build_Time => Build_Time);
Root_Iterator := Hchy.Make (Root_Module);
Root_Gateway := Root_Of (Gateway_Object, Action_Id => Action_Id);
Gateways.Initialize (The_State => The_State,
Action_Id => Action_Id,
Work_Order => Work_Order);
--
-- Delete those gateways that no longer have corresponding
-- modules.
--
Gateways.Reduce (Gateway_Name =>
Dir.Naming.Get_Full_Name (Root_Gateway),
Candidate_Modules => Root_Iterator,
Comments => Comments,
The_State => The_State);
--
-- Create gateways for the new modules.
--
Gateways.Augment
(For_Module => Root_Module,
In_Library => Dir.Naming.Get_Full_Name
(Dir.Control_Point.Associated_Control_Point
(Root_Gateway)),
Host => Ro.Machine (In_Context),
Model => Model,
Update_Time => Build_Time,
Comments => Comments,
The_State => The_State);
Gateways.Finalize (The_State);
Has_Destroyed_Gateway :=
Dir.Naming.Get_Full_Name (Gateway_Object) =
'[' & Dir.Error_Status'Image (Dir.Version_Error) & ']';
end Accept_Changes;
function Is_Up_To_Date (Handle : Dc.Gateway_Handle;
In_Context : in Ro.Context) return Boolean is
Remote_Update_Time : Calendar.Time;
S : Ss.Condition;
use Calendar;
begin
Ro.Update_Time (Of_File => Asap.Data_Context (Handle) &
Unix.Context_Separator &
Asap.Data_Name (Handle),
In_Context => In_Context,
Result => Remote_Update_Time,
Status => S,
Options => "");
if Ss.Error (S) then
--
-- If the remote file does not exist, we assume that the
-- gateway is up to date.
--
return True;
end if;
return Remote_Update_Time <= Asap.Asa_Update_Time (Handle);
end Is_Up_To_Date;
-- ---------------------
-- ( ) Command execution
-- ---------------------
procedure Execute (Command : in String;
Interactive : in Boolean;
In_Context : in Ro.Context;
Timeout : in Ro.Command_Timeout := Default_Timeout) is
--
-- Interactive commands do require the definition of the X Window
-- display. Also, it is not necessary to log messages indicating
-- what is going on during such commands.
--
type State_Record is
record
null;
end record;
The_Display : constant String := Asas.Remote_Display;
Setenv_Display : constant String := Unix.Setenv &
' ' &
Unix.Display &
' ' &
The_Display;
S : Ss.Condition;
The_State : State_Record;
procedure Process_Output (Text : String;
Severity : Profile.Msg_Kind;
State : in out State_Record;
Response : in out Ro.Command_Response) is
begin
if Interactive then
Logger.Debug (Text);
else
Logger.Note (Text);
end if;
Response := Ro.Nil;
end Process_Output;
procedure Read_Input (State : in out State_Record;
Buffer : out String;
Last : out Natural;
Response : in out Ro.Command_Response) is
begin
Last := 0;
Response := Ro.Abort_Command;
Logger.Error ("Attempt to read input during command execution");
end Read_Input;
procedure Timeout_Handler (State : in out State_Record;
Response : in out Ro.Command_Response) is
begin
Response := Ro.Abort_Command;
Logger.Error ("Timeout expired during command execution");
end Timeout_Handler;
procedure Execute is new Ro.Execution_Generic
(Execution_State => State_Record,
Process_Output => Process_Output,
Read_Input => Read_Input,
Timeout_Handler => Timeout_Handler);
begin
if Interactive then
if The_Display /= "" then
Logger.Debug ("Executing command """ & Setenv_Display & '"');
Execute (Command => Setenv_Display,
In_Context => In_Context,
State => The_State,
Status => S,
Timeout => Default_Timeout);
Logger.Status (S, Interactive => True);
end if;
end if;
if Interactive then
Logger.Debug ("Executing command """ & Command & '"');
else
Logger.Note ("Executing command """ & Command & '"');
end if;
Execute (Command => Command,
In_Context => In_Context,
State => The_State,
Status => S,
Timeout => Timeout);
Logger.Status (S, Interactive => Interactive);
end Execute;
-- ------------------
-- ( ) Image creation
-- ------------------
function Check_Writeable (H : in Gwo.Handle) return Ss.Condition is
Gateway_Object : constant Dir.Object := Gwo.Directory_Object (H);
Gateway_Full_Name : constant String :=
Dna.Get_Full_Name (Gateway_Object);
S : Ss.Condition;
The_Handle : Dc.Gateway_Handle := H;
begin
case Gateways.Cmvc_Control (Gateway_Full_Name) is
when Gateways.Not_Controlled |
Gateways.Controlled_Checked_Out =>
if Gwo.Is_Main_Object_Open_For_Update (H) then
Ss.Initialize (S);
else
Gwo.Re_Open_Main_Object_For_Update
(The_Handle, Errors => S);
end if;
return S;
when Gateways.Controlled_Checked_In =>
Ss.Create_Condition
(Status => S,
Error_Type => "",
Message =>
"Unable to obtain gateway object " & Gateway_Full_Name &
"; it must be checked-out before it can be edited",
Severity => Ss.Problem);
return S;
end case;
end Check_Writeable;
-- ---------
-- ( ) Stubs
-- ---------
package body Model is separate;
package body Module is separate;
package body Requirement is separate;
end Actions;
nblk1=b
nid=0
hdr6=16
[0x00] rec0=26 rec1=00 rec2=01 rec3=000
[0x01] rec0=19 rec1=00 rec2=02 rec3=010
[0x02] rec0=1b rec1=00 rec2=03 rec3=052
[0x03] rec0=1b rec1=00 rec2=04 rec3=024
[0x04] rec0=18 rec1=00 rec2=05 rec3=03a
[0x05] rec0=1c rec1=00 rec2=06 rec3=06c
[0x06] rec0=1c rec1=00 rec2=07 rec3=018
[0x07] rec0=18 rec1=00 rec2=08 rec3=036
[0x08] rec0=18 rec1=00 rec2=09 rec3=03c
[0x09] rec0=1c rec1=00 rec2=0a rec3=026
[0x0a] rec0=1c rec1=00 rec2=0b rec3=000
tail 0x2170c8a64823076b1ae13 0x42a00088462060003