|
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: 9845 (0x2675)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─ ⟦129cab021⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─ ⟦6f12a12be⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─ ⟦d65440be7⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦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;