|
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: 241048 (0x3ad98)
Types: TextFile
Notes: R1k Text-file segment
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦5a81ac88f⟧ »Space Info Vol 1«
└─⟦a7b39883d⟧
└─⟦this⟧
%LSAMODULE:
requirement_1,
requirement_2,
requirement_3,
requirement_4,
requirement_5,
requirement_6,
requirement_7,
requirement_8,
requirement_9;
ENDANNOTATION_TYPES
ANNOTATION
requirement_1 : string;
requirement_2 : string;
requirement_3 : string;
requirement_4 : string;
requirement_5 : string;
requirement_6 : string;
requirement_7 : string;
requirement_8 : string;
requirement_9 : string;
END--
-- This script returns an output file describing the files associated to
-- the specified model.
--
outfile : output;
root : Tmodule;
--
feature (Tmodule) associated () is
local
sons : set [Tmodule];
son : Tmodule;
do
outfile.fprint_f ("%s ", current.bodyf);
if current.is_valued ("description") then
outfile.fprint_f ("%s ", current.descf);
end;
sons := current.sons;
for son in sons do
son.associated;
end;
end;
--
outfile.create ("**OUTPUT**");
outfile.open_write;
root := modelc_load ("**MODEL**",
"**ANNOTATIONS**",
"**ANNOTATION_TYPES**",
"M",
false);
root.associated;
outfile.fprint_f ("\n");
outfile.close;
--
-- This script returns an output file describing the hierarchy of the
-- specified model. The syntax of this file is as follows:
--
-- A -- model identifier
-- M -- A's node number
-- ... -- A's comments
-- ... -- requirements 1 to 9 for A
-- 2 -- number of sons of A
-- B -- identifier of A's first son
-- M1 -- B's node number
-- ... -- B's comments
-- ... -- requirements 1 to 9 for B
-- 0 -- number of sons of B
-- C -- identifier of A's second son
-- M2 -- C's node number
-- ... -- C's comments
-- ... -- requirements 1 to 9 for C
-- 1 -- number of sons of C
-- D -- identifier of C's unique son
-- M21 -- D's node number
-- ... -- D's comments
-- ... -- requirements 1 to 9 for D
-- 0 -- number of sons of D
--
-- This syntax has been chosen to make sure that we can parse the module
-- identifiers even if they contain funny characters. This information
-- will be used to create the following gateway structure:
--
-- A
-- .B
-- .C
-- .D
--
outfile : output;
root : Tmodule;
--
feature (Tmodule) annotation (s : string) is
local
do
if current.is_valued (s) then
outfile.fprint_f ("%s\n", current.stgann (s));
else
outfile.fprint_f ("\n");
end;
end;
--
feature (Tmodule) hierarchy () is
local
sons : set [Tmodule];
son : Tmodule;
do
outfile.fprint_f ("%s\n", current.ident);
outfile.fprint_f ("%s\n", current.node);
outfile.fprint_f ("%s\n", current.comment);
current.annotation ("requirement_1");
current.annotation ("requirement_2");
current.annotation ("requirement_3");
current.annotation ("requirement_4");
current.annotation ("requirement_5");
current.annotation ("requirement_6");
current.annotation ("requirement_7");
current.annotation ("requirement_8");
current.annotation ("requirement_9");
sons := current.sons;
outfile.fprint_f ("%d\n", sons.card);
for son in sons do
son.hierarchy;
end;
end;
--
outfile.create ("**OUTPUT**");
outfile.open_write;
root := modelc_load ("**MODEL**",
"**ANNOTATIONS**",
"**ANNOTATION_TYPES**",
"M",
false);
root.hierarchy;
outfile.close;
class ASA_MODEL (4668792) is
type EDIT_ACTION (1) is (WS_ONLY,
WS_ELSE_LOCAL,
WS_ELSE_MESSAGE,
LOCAL,
MESSAGE_ONLY);
PARENT_NAME : STRING (editable);
CONNECTED : BOOLEAN (editable;
default => TRUE);
ACTIVATION.SERVER_NAME : STRING (constant;
non_display;
default => """!Projects.Asa_Integration.Gateways'Spec_View.Units"".Asa_Integration_Server");
CREATE.DIRECTORY_SUBCLASS : STRING (constant;
non_display;
default => "Diagram");
CREATE.INITIAL_SUBOBJECTS : STRING (constant;
non_display;
default => "");
EDIT.BANNER : STRING (constant;
non_display;
default => "Text");
EDIT.HEADER : STRING (constant;
non_display;
default => "");
EDIT.OBJECT : STRING (constant;
non_display;
default => "Null");
EDIT.WS_MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.DISPLAY_ACTION : EDIT_ACTION (non_display;
default => WS_ONLY);
DATA.CONTEXT : STRING (editable;
default => "");
DATA.HOST : STRING (editable;
default => "");
DATA.NAME : STRING (editable;
default => "");
ASA.COMMENT : STRING (default => "");
ASA.DEPENDENTS_1 : STRING (non_display;
default => "");
ASA.DEPENDENTS_2 : STRING (non_display;
default => "");
ASA.DEPENDENTS_3 : STRING (non_display;
default => "");
ASA.DEPENDENTS_4 : STRING (non_display;
default => "");
ASA.DEPENDENTS_5 : STRING (non_display;
default => "");
ASA.DEPENDENTS_6 : STRING (non_display;
default => "");
ASA.DEPENDENTS_7 : STRING (non_display;
default => "");
ASA.DEPENDENTS_8 : STRING (non_display;
default => "");
ASA.DEPENDENTS_9 : STRING (non_display;
default => "");
ASA.ID : NATURAL (default => 1);
ASA.LAST_ID : NATURAL (non_display;
default => 0);
ASA.LAST_REQUIREMENT_ID : NATURAL (non_display;
default => 9);
ASA.NODE_NUMBER : STRING (constant;
default => "M");
ASA.REQUIREMENT_1 : STRING (editable;
default => "");
ASA.REQUIREMENT_2 : STRING (editable;
default => "");
ASA.REQUIREMENT_3 : STRING (editable;
default => "");
ASA.REQUIREMENT_4 : STRING (editable;
default => "");
ASA.REQUIREMENT_5 : STRING (editable;
default => "");
ASA.REQUIREMENT_6 : STRING (editable;
default => "");
ASA.REQUIREMENT_7 : STRING (editable;
default => "");
ASA.REQUIREMENT_8 : STRING (editable;
default => "");
ASA.REQUIREMENT_9 : STRING (editable;
default => "");
ASA.UPDATE_TIME : DATE (non_display);
IO.FORM_MAP : STRING (constant;
non_display;
default => "others => raise USE_ERROR;");
DISPATCH.MAP : STRING (non_display;
constant;
default =>
"Image_Name => External;" &
"Build_Image => External;" &
"Post_Commit => Not_Supported;" &
"Semanticize => Not_Supported;" &
"Complete => Not_Supported;" &
"Edit => Not_Supported;" &
"Definition => Default;" &
"Enclosing => Not_Supported;" &
"Elide => Not_Supported;" &
"Expand => Not_Supported;" &
"Undo => Not_Supported;" &
"Redo => Not_Supported;" &
"Promote => Not_Supported;" &
"Demote => Not_Supported;" &
"Format => Not_Supported;" &
"Revert => Not_Supported;" &
"Sort_Image => Not_Supported;" &
"Delete => External;" &
"Pre_Check_In => External;" &
"Post_Check_In => Default;" &
"Pre_Check_Out => Default;" &
"Post_Check_Out => Default;" &
"Pre_Cmvc_Copy => External;" &
"Post_Cmvc_Copy => External;" &
"Pre_Make_Controlled => External;" &
"Output => Not_Supported;" &
"Input => External;");
end ASA_MODELclass ASA_MODULE (4668791) is
type EDIT_ACTION (1) is (WS_ONLY,
WS_ELSE_LOCAL,
WS_ELSE_MESSAGE,
LOCAL,
MESSAGE_ONLY);
PARENT_NAME : STRING (editable);
CONNECTED : BOOLEAN (editable;
default => TRUE);
CREATE.DIRECTORY_SUBCLASS : STRING (constant;
non_display;
default => "Diagram");
CREATE.INITIAL_SUBOBJECTS : STRING (constant;
non_display;
default => "");
EDIT.BANNER : STRING (constant;
non_display;
default => "Text");
EDIT.HEADER : STRING (constant;
non_display;
default => "");
EDIT.OBJECT : STRING (constant;
non_display;
default => "Null");
EDIT.WS_MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.DISPLAY_ACTION : EDIT_ACTION (non_display;
default => WS_ONLY);
DATA.CONTEXT : STRING (constant;
non_display;
default => "<PARENT>");
DATA.HOST : STRING (constant;
non_display;
default => "<PARENT>");
DATA.NAME : STRING (constant;
non_display;
default => "<PARENT>");
ASA.COMMENT : STRING (default => "");
ASA.DEPENDENTS_1 : STRING (non_display;
default => "");
ASA.DEPENDENTS_2 : STRING (non_display;
default => "");
ASA.DEPENDENTS_3 : STRING (non_display;
default => "");
ASA.DEPENDENTS_4 : STRING (non_display;
default => "");
ASA.DEPENDENTS_5 : STRING (non_display;
default => "");
ASA.DEPENDENTS_6 : STRING (non_display;
default => "");
ASA.DEPENDENTS_7 : STRING (non_display;
default => "");
ASA.DEPENDENTS_8 : STRING (non_display;
default => "");
ASA.DEPENDENTS_9 : STRING (non_display;
default => "");
ASA.ID : NATURAL (default => 1);
ASA.LAST_REQUIREMENT_ID : NATURAL (non_display;
default => 9);
ASA.NODE_NUMBER : STRING (editable;
default => "");
ASA.REQUIREMENT_1 : STRING (editable;
default => "");
ASA.REQUIREMENT_2 : STRING (editable;
default => "");
ASA.REQUIREMENT_3 : STRING (editable;
default => "");
ASA.REQUIREMENT_4 : STRING (editable;
default => "");
ASA.REQUIREMENT_5 : STRING (editable;
default => "");
ASA.REQUIREMENT_6 : STRING (editable;
default => "");
ASA.REQUIREMENT_7 : STRING (editable;
default => "");
ASA.REQUIREMENT_8 : STRING (editable;
default => "");
ASA.REQUIREMENT_9 : STRING (editable;
default => "");
ASA.UPDATE_TIME : DATE (constant;
non_display;
default => "<PARENT>");
IO.FORM_MAP : STRING (constant;
non_display;
default => "others => raise USE_ERROR;");
DISPATCH.MAP : STRING (non_display;
constant;
default =>
"Image_Name => External;" &
"Build_Image => External;" &
"Post_Commit => Not_Supported;" &
"Semanticize => Not_Supported;" &
"Complete => Not_Supported;" &
"Edit => Not_Supported;" &
"Definition => Default;" &
"Enclosing => Not_Supported;" &
"Elide => Not_Supported;" &
"Expand => Not_Supported;" &
"Undo => Not_Supported;" &
"Redo => Not_Supported;" &
"Promote => Not_Supported;" &
"Demote => Not_Supported;" &
"Format => Not_Supported;" &
"Revert => Not_Supported;" &
"Sort_Image => Not_Supported;" &
"Delete => External;" &
"Pre_Check_In => External;" &
"Post_Check_In => Default;" &
"Pre_Check_Out => Default;" &
"Post_Check_Out => Default;" &
"Pre_Cmvc_Copy => Default;" &
"Post_Cmvc_Copy => Default;" &
"Pre_Make_Controlled => External;" &
"Output => Not_Supported;" &
"Input => External;");
end ASA_MODULE
class ASA_REQUIREMENT (4668793) is
type EDIT_ACTION (1) is (WS_ONLY,
WS_ELSE_LOCAL,
WS_ELSE_MESSAGE,
LOCAL,
MESSAGE_ONLY);
type KIND (2) is (FUNCTIONAL,
PERFORMANCE,
EXTERNAL_INTERFACE,
OPERATIONAL,
RESOURCE,
QUALIFICATION_TESTING,
ACCEPTANCE_TESTING,
DOCUMENTATION,
QUALITY,
SAFETY,
RELIABILITY,
MAINTAINABILITY,
DEVELOPMENT_AND_VERIFICATION,
DESIGN_AND_PROGRAMMING,
REUSE_AND_COMMONALITY);
PARENT_NAME : STRING (editable);
CONNECTED : BOOLEAN (editable;
default => TRUE);
CREATE.DIRECTORY_SUBCLASS : STRING (constant;
non_display;
default => "Text");
CREATE.INITIAL_SUBOBJECTS : STRING (constant;
non_display;
default => "");
EDIT.ALLOW_EDIT : BOOLEAN (constant;
non_display;
default => TRUE);
EDIT.BANNER : STRING (constant;
non_display;
default => "Text");
EDIT.HEADER : STRING (constant;
non_display;
default => "");
EDIT.OBJECT : STRING (constant;
non_display;
default => "");
EDIT.WS_MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.MESSAGE_TEXT : STRING (constant;
non_display;
default => "");
EDIT.DISPLAY_ACTION : EDIT_ACTION (non_display;
default => LOCAL);
DATA.CONTEXT : STRING (constant;
non_display;
default => "<PARENT>");
DATA.HOST : STRING (constant;
non_display;
default => "<PARENT>");
DATA.NAME : STRING (constant;
non_display;
default => "<PARENT>");
ASA.DEPENDENTS : STRING (non_display;
default => "");
ASA.ID : NATURAL (default => 1);
ASA.REQUIREMENT_KIND : KIND (default => PERFORMANCE);
ASA.REQUIREMENT_TEXT : STRING (editable;
default => "");
ASA.UPDATE_TIME : DATE (constant;
non_display;
default => "<PARENT>");
IO.FORM_MAP : STRING (constant;
non_display;
default => "Io_Open (Input) => External;" &
"Io_Read_Bytes (Input) => External;" &
"Io_Read_String (Input) => External;" &
"Io_End_Of_File (Input) => External;" &
"Io_Reset (Input) => External;" &
"Io_Close (Input) => External;" &
"Io_Create => raise USE_ERROR;" &
"Io_Delete => raise USE_ERROR;" &
"Io_Write_Bytes => raise USE_ERROR;" &
"Io_Write_String => raise USE_ERROR;" &
"others => External;");
DISPATCH.MAP : STRING (non_display;
constant;
default =>
"Image_Name => External;" &
"Build_Image => External;" &
"Post_Commit => External;" &
"Semanticize => Default;" &
"Complete => Default;" &
"Edit => External;" &
"Definition => Default;" &
"Enclosing => Default;" &
"Elide => Default;" &
"Expand => Default;" &
"Undo => Default;" &
"Redo => Default;" &
"Promote => Default;" &
"Demote => Default;" &
"Format => Default;" &
"Revert => Default;" &
"Sort_Image => Default;" &
"Delete => Default;" &
"Pre_Check_In => Default;" &
"Post_Check_In => Default;" &
"Pre_Check_Out => Default;" &
"Post_Check_Out => Default;" &
"Pre_Cmvc_Copy => Default;" &
"Post_Cmvc_Copy => Default;" &
"Pre_Make_Controlled => Default;" &
"Output => Default;" &
"Input => Default;");
end ASA_REQUIREMENT
procedure INSTALL (RESPONSE : in STRING := "<PROFILE>");with ARCHIVE;
with ASA_DEFINITIONS;
with DIRECTORY_TOOLS;
with IO;
with GATEWAY_CLASS;
procedure INSTALL (RESPONSE : in STRING := "<PROFILE>") is
PROCEDURE_NAME : constant STRING := "INSTALL";
package DNA renames DIRECTORY_TOOLS.NAMING;
package DTO renames DIRECTORY_TOOLS;
ACTIVATE_FILE : IO.FILE_TYPE;
GATEWAY_CLASS_DEFINITIONS : constant STRING :=
DNA.FULL_NAME ("\" & PROCEDURE_NAME &
"$$^$$'VIEW.UNITS.GATEWAY_DEFINITIONS");
GATEWAY_CLASSES : constant STRING := "!MACHINE.GATEWAY_CLASSES";
FILE_DEFINITIONS : constant STRING :=
DNA.FULL_NAME ("\" & PROCEDURE_NAME & "$$^$$'VIEW.UNITS.FILES");
begin
for C in ASA_DEFINITIONS.GATEWAY_CLASS loop
GATEWAY_CLASS.DEACTIVATE
(GATEWAY_CLASS_NAME => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C),
RESPONSE => RESPONSE);
end loop;
for C in ASA_DEFINITIONS.GATEWAY_CLASS loop
ARCHIVE.COPY (OBJECTS => GATEWAY_CLASS_DEFINITIONS & '.' &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C),
USE_PREFIX => GATEWAY_CLASSES & '.' &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C) &
".GATEWAY_DEFINITION",
FOR_PREFIX => GATEWAY_CLASS_DEFINITIONS & '.' &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C),
OPTIONS => "REPLACE",
RESPONSE => RESPONSE);
GATEWAY_CLASS.BUILD (GATEWAY_CLASS_DIRECTORY =>
GATEWAY_CLASSES & '.' &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C),
GATEWAY_TEXT_DESCRIPTION => "GATEWAY_DEFINITION",
GATEWAY_BINARY_DESCRIPTION => "GATEWAY_CLASS",
RESPONSE => RESPONSE);
end loop;
for C in ASA_DEFINITIONS.GATEWAY_CLASS loop
IO.CREATE (FILE => ACTIVATE_FILE,
MODE => IO.OUT_FILE,
NAME => GATEWAY_CLASSES & '.' &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C) &
".ACTIVATE_ON_BOOT");
IO.CLOSE (ACTIVATE_FILE);
GATEWAY_CLASS.ACTIVATE
(GATEWAY_CLASS_NAME => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (C),
RESPONSE => RESPONSE);
end loop;
ARCHIVE.COPY (OBJECTS => FILE_DEFINITIONS & ".@",
USE_PREFIX => ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY,
FOR_PREFIX => FILE_DEFINITIONS,
OPTIONS => "REPLACE",
RESPONSE => RESPONSE);
end INSTALL;
with ACTION;
with DEVICE_INDEPENDENT_IO;
with DIRECTORY;
with DTIA_CLIENT;
with PROFILE;
package ACTIONS is
package DC renames DTIA_CLIENT;
package MODEL is
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY);
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT);
procedure PRE_CHECK_IN (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
procedure PRE_MAKE_CONTROLLED (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SAVE_SOURCE : BOOLEAN;
ALLOW_CONTROLLED : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
procedure PRE_CMVC_COPY (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RELEASE : BOOLEAN;
CONTROLLED : BOOLEAN;
JOINED : BOOLEAN;
SOURCE_VIEW : DIRECTORY.OBJECT;
DESTINATION_VIEW : DIRECTORY.OBJECT;
FIRST_CALL : BOOLEAN;
DO_NOT_COPY : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
procedure POST_CMVC_COPY (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SOURCE_OBJECT : DIRECTORY.OBJECT;
RELEASE : BOOLEAN;
CONTROLLED : BOOLEAN;
JOINED : BOOLEAN;
SOURCE_VIEW : DIRECTORY.OBJECT;
DESTINATION_VIEW : DIRECTORY.OBJECT;
FIRST_CALL : BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
procedure TERMINATE_SERVER (REASON : in DC.TERMINATION_CONDITION);
end MODEL;
package MODULE is
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY);
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT);
procedure PRE_CHECK_IN (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
procedure PRE_MAKE_CONTROLLED (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SAVE_SOURCE : BOOLEAN;
ALLOW_CONTROLLED : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS);
end MODULE;
package REQUIREMENT is
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY);
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT);
procedure POST_COMMIT (HANDLE : DC.GATEWAY_HANDLE;
IMAGE : DC.IMAGE_ID);
procedure EDIT (HANDLE : DC.GATEWAY_HANDLE;
IMAGE : DC.IMAGE_ID;
S : DC.SELECTION;
C : DC.CURSOR;
VISIBLE : BOOLEAN;
ALLOW_EDIT : out BOOLEAN);
procedure IO_OPEN (FILE : in out DEVICE_INDEPENDENT_IO.FILE_TYPE;
MODE : DEVICE_INDEPENDENT_IO.FILE_MODE;
HANDLE : DC.GATEWAY_HANDLE;
FORM : STRING;
ACTION_ID : ACTION.ID);
end REQUIREMENT;
end ACTIONS;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;with ASAOPEN;
with DEVICE_INDEPENDENT_IO;
with JOB_SEGMENT;
with GATEWAY_OBJECT;
separate (ACTIONS)
package body MODEL is
package ASAC renames ASA_DEFINITIONS.COMMANDS;
package DIIO renames DEVICE_INDEPENDENT_IO;
ANNOTATIONS : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".ANNOTATIONS";
ANNOTATION_TYPES : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".ANNOTATION_TYPES";
ASSOCIATED : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".ASSOCIATED";
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY) is
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (HANDLE);
S : SS.CONDITION;
begin
SHOW_PROPERTY_IMAGE := FALSE;
ID := (I1 => DIR.UNIQUE (GATEWAY_OBJECT), I2 => 0);
NO_IMAGE := TRUE;
if not READ_ONLY then
S := CHECK_WRITEABLE (HANDLE);
LOGGER.STATUS (S);
end if;
exception
when PROFILE.ERROR =>
LOGGER.ERROR ("Image construction is quitting after errors",
RAISE_ERROR => FALSE);
end IMAGE_NAME;
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT) is
ACTION_ID : ACTION.ID;
C : RO.CONTEXT;
DIRECTORY_EXISTS : BOOLEAN;
FILE_EXISTS : BOOLEAN;
HAS_DESTROYED_GATEWAY : BOOLEAN;
S : SS.CONDITION;
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (HANDLE);
GATEWAY_FULL_NAME : constant STRING :=
DIR.NAMING.GET_FULL_NAME (GATEWAY_OBJECT);
HOST : constant STRING := ASAP.DATA_HOST (HANDLE);
MODEL : constant STRING := ASAP.DATA_CONTEXT (HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (HANDLE);
use GATEWAYS;
begin
NO_IMAGE := TRUE;
UNDERLYING_OBJECT := GATEWAY_OBJECT;
if not READ_ONLY then
if SS.ERROR (CHECK_WRITEABLE (HANDLE)) then
return;
end if;
end if;
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
if not IS_UP_TO_DATE (HANDLE, IN_CONTEXT => C) then
case ASAS.ACTION_WHEN_OUT_OF_DATE is
when ASAS.ABANDON =>
LOGGER.NEGATIVE
("The gateway object " & GATEWAY_FULL_NAME &
" may not be up-to-date. Use Asa.Accept_Changes " &
"to update it");
when ASAS.ACCEPT_CHANGES =>
LOGGER.POSITIVE
("The gateway object " & GATEWAY_FULL_NAME &
" may not be up-to-date. Changes are being accepted");
GWO.CLOSE (HANDLE, S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ACTION_ID := ACTION.START;
ACCEPT_CHANGES
(GATEWAY_OBJECT => GATEWAY_OBJECT,
IN_CONTEXT => C,
MODEL => MODEL,
COMMENTS => "Automatic Accept_Changes issued by " &
"Build_Image from object " &
GATEWAY_FULL_NAME,
WORK_ORDER => "<DEFAULT>",
ACTION_ID => ACTION_ID,
HAS_DESTROYED_GATEWAY => HAS_DESTROYED_GATEWAY);
ACTION.FINISH (THE_ACTION => ACTION_ID, DO_COMMIT => TRUE);
if HAS_DESTROYED_GATEWAY then
LOGGER.ERROR
("Gateway object " & GATEWAY_FULL_NAME &
" has been destroyed while accepting changes. " &
"Unable to create an image for it.");
else
GWO.OPEN_OBJECT (OBJECT => GATEWAY_FULL_NAME,
SLOT => GWO.MAIN_SLOT,
H => HANDLE,
ERRORS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
end if;
when ASAS.CONTINUE =>
LOGGER.WARNING ("The gateway object " & GATEWAY_FULL_NAME &
" may not be up-to-date.");
end case;
end if;
--
-- Before calling asaedit we check the existence of the file,
-- because asaedit won't tell much it they do not exist.
--
RO.FILE_EXISTS (THE_FILE => ASAP.DATA_CONTEXT (HANDLE),
IN_CONTEXT => C,
STATUS => S,
EXISTS => DIRECTORY_EXISTS);
LOGGER.STATUS (S);
if DIRECTORY_EXISTS then
if READ_ONLY then
RO.FILE_EXISTS
(THE_FILE =>
ASAP.DATA_CONTEXT (HANDLE) & UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (HANDLE),
IN_CONTEXT => C,
STATUS => S,
EXISTS => FILE_EXISTS);
LOGGER.STATUS (S);
if not FILE_EXISTS then
LOGGER.NEGATIVE ("Remote file " & ASAP.DATA_CONTEXT (HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (HANDLE) & " does not exist");
end if;
end if;
else
LOGGER.NEGATIVE ("Remote directory " &
ASAP.DATA_CONTEXT (HANDLE) & " does not exist");
end if;
declare
REMOTE_ANNOTATIONS : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.ANNOTATIONS_EXTENSION);
REMOTE_ANNOTATION_TYPES : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.ANNOTATION_TYPES_EXTENSION);
ASAEDIT_COMMAND : constant STRING :=
ASAS.BIN_DIRECTORY (ASAP.DATA_HOST (HANDLE)) &
UNIX.CONTEXT_SEPARATOR &
ASAC.ASAEDIT &
' ' &
ASAP.DATA_CONTEXT (HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (HANDLE) &
' ' &
ASAC.START_NODE &
' ' &
ASAP.ASA_NODE_NUMBER (HANDLE) &
' ' &
ASAC.NO_WARNINGS &
' ' &
ASAC.ANNOTATIONS &
' ' &
REMOTE_ANNOTATIONS &
' ' &
ASAC.ANNOTATION_TYPES &
' ' &
REMOTE_ANNOTATION_TYPES;
RM_COMMAND : constant STRING := UNIX.REMOVE &
' ' &
REMOTE_ANNOTATIONS &
' ' &
REMOTE_ANNOTATION_TYPES;
begin
LOGGER.NOTE ("Copying file " & ANNOTATIONS &
" to " & REMOTE_ANNOTATIONS);
RO.PUT (FROM_FILE => ANNOTATIONS,
TO_FILE => REMOTE_ANNOTATIONS,
IN_CONTEXT => C,
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
LOGGER.NOTE ("Copying file " & ANNOTATION_TYPES &
" to " & REMOTE_ANNOTATION_TYPES);
RO.PUT (FROM_FILE => ANNOTATION_TYPES,
TO_FILE => REMOTE_ANNOTATION_TYPES,
IN_CONTEXT => C,
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
if READ_ONLY then
EXECUTE (COMMAND => ASAEDIT_COMMAND &
' ' &
ASAC.READ_ONLY &
UNIX.COMMAND_SEPARATOR &
RM_COMMAND,
INTERACTIVE => TRUE,
IN_CONTEXT => C,
TIMEOUT => RO.WAIT_FOREVER);
else
EXECUTE (COMMAND => ASAEDIT_COMMAND &
UNIX.COMMAND_SEPARATOR &
RM_COMMAND,
INTERACTIVE => TRUE,
IN_CONTEXT => C,
TIMEOUT => RO.WAIT_FOREVER);
end if;
end;
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR ("Image construction is quitting after errors",
RAISE_ERROR => FALSE);
end BUILD_IMAGE;
--[bug]
-- Due to a bug in DISPATCH, the CMVC operations are called with an
-- handle that it not open under the action used for the operation.
-- To avoid locking problems, we immediately close the handle and
-- reopen the same object with the appropriate action. However there
-- is still an interesting issue: when the handle is reopen for the
-- post operation (with a new action), a locking error may be
-- detected, and the post operation may be called with a closed
-- handle. We have to live with this...
--
function REOPEN (HANDLE : in GWO.HANDLE; ACTION_ID : in ACTION.ID)
return GWO.HANDLE is
RESULT : GWO.HANDLE;
S : SS.CONDITION;
THE_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (HANDLE);
begin
GWO.CLOSE (HANDLE);
GWO.OPEN_MAIN_OBJECT (OBJECT => THE_OBJECT,
H => RESULT,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
return RESULT;
end REOPEN;
procedure PRE_CHECK_IN (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
THE_HANDLE : DC.GATEWAY_HANDLE := REOPEN (HANDLE, ACTION_ID);
C : RO.CONTEXT;
HAS_DESTROYED_GATEWAY : BOOLEAN;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION_ID;
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (THE_HANDLE);
GATEWAY_FULL_NAME : constant STRING :=
DIR.NAMING.GET_FULL_NAME (GATEWAY_OBJECT);
HOST : constant STRING := ASAP.DATA_HOST (THE_HANDLE);
MODEL : constant STRING := ASAP.DATA_CONTEXT (THE_HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (THE_HANDLE);
begin
PROFILE.SET (RESPONSE);
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
if not IS_UP_TO_DATE (THE_HANDLE, IN_CONTEXT => C) then
LOGGER.POSITIVE ("Accepting changes from model " & MODEL);
GWO.CLOSE (THE_HANDLE, S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ACCEPT_CHANGES (GATEWAY_OBJECT => GATEWAY_OBJECT,
IN_CONTEXT => C,
MODEL => MODEL,
COMMENTS => "Automatic Accept_Changes issued by " &
"Check_In from object " &
GATEWAY_FULL_NAME,
WORK_ORDER => "<DEFAULT>",
ACTION_ID => ACTION_ID,
HAS_DESTROYED_GATEWAY => HAS_DESTROYED_GATEWAY);
if HAS_DESTROYED_GATEWAY then
LOGGER.WARNING ("The gateway object " & GATEWAY_FULL_NAME &
" has been destroyed while accepting " &
"changes. Cmvc.Check_In is unable to proceed");
ACTION.FINISH (THE_ACTION => THE_ACTION, DO_COMMIT => TRUE);
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => TRUE);
return;
end if;
end if;
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => FALSE);
exception
when PROFILE.ERROR =>
ERRORS := (WARNINGS => 0, ERRORS => 1, FATAL => FALSE);
end PRE_CHECK_IN;
procedure PRE_CMVC_COPY (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RELEASE : BOOLEAN;
CONTROLLED : BOOLEAN;
JOINED : BOOLEAN;
SOURCE_VIEW : DIRECTORY.OBJECT;
DESTINATION_VIEW : DIRECTORY.OBJECT;
FIRST_CALL : BOOLEAN;
DO_NOT_COPY : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
THE_HANDLE : DC.GATEWAY_HANDLE := REOPEN (HANDLE, ACTION_ID);
C : RO.CONTEXT;
HAS_DESTROYED_GATEWAY : BOOLEAN;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION_ID;
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (THE_HANDLE);
GATEWAY_FULL_NAME : constant STRING :=
DIR.NAMING.GET_FULL_NAME (GATEWAY_OBJECT);
HOST : constant STRING := ASAP.DATA_HOST (THE_HANDLE);
MODEL : constant STRING := ASAP.DATA_CONTEXT (THE_HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (THE_HANDLE);
begin
PROFILE.SET (RESPONSE);
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
if not IS_UP_TO_DATE (THE_HANDLE, IN_CONTEXT => C) then
LOGGER.POSITIVE ("Accepting changes from model " & MODEL);
GWO.CLOSE (THE_HANDLE, S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ACCEPT_CHANGES (GATEWAY_OBJECT => GATEWAY_OBJECT,
IN_CONTEXT => C,
MODEL => MODEL,
COMMENTS => "Automatic Accept_Changes issued by " &
"view copy" & GATEWAY_FULL_NAME,
WORK_ORDER => "<DEFAULT>",
ACTION_ID => ACTION_ID,
HAS_DESTROYED_GATEWAY => HAS_DESTROYED_GATEWAY);
end if;
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => FALSE);
DO_NOT_COPY := FALSE;
exception
when PROFILE.ERROR =>
ERRORS := (WARNINGS => 0, ERRORS => 1, FATAL => FALSE);
DO_NOT_COPY := TRUE;
end PRE_CMVC_COPY;
procedure POST_CMVC_COPY (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SOURCE_OBJECT : DIRECTORY.OBJECT;
RELEASE : BOOLEAN;
CONTROLLED : BOOLEAN;
JOINED : BOOLEAN;
SOURCE_VIEW : DIRECTORY.OBJECT;
DESTINATION_VIEW : DIRECTORY.OBJECT;
FIRST_CALL : BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
THE_HANDLE : DC.GATEWAY_HANDLE := REOPEN (HANDLE, ACTION_ID);
ARCHIVE_FILE : DIIO.FILE_TYPE;
C : RO.CONTEXT;
S : SS.CONDITION;
type ACCESS_STRING is access STRING;
pragma SEGMENTED_HEAP (ACCESS_STRING);
CONTEXT : constant STRING := ASAP.DATA_CONTEXT (THE_HANDLE);
HOST : constant STRING := ASAP.DATA_HOST (THE_HANDLE);
MODEL : constant STRING := CONTEXT & UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (THE_HANDLE);
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (THE_HANDLE);
ARCHIVE_FILE_NAME : constant STRING :=
DNA.GET_FULL_NAME (GATEWAY_OBJECT) & ".Archive";
REMOTE_TARFILE : constant STRING :=
UNIX.TEMPORARY_FILENAME (UNIX.TARFILE_EXTENSION);
CD_COMMAND : constant STRING := UNIX.CHANGE_DIRECTORY &
' ' &
CONTEXT;
TAR_COMMAND : constant STRING := UNIX.TAPE_ARCHIVE &
' ' &
UNIX.CREATE &
UNIX.ARCHIVE_FILE &
' ' &
REMOTE_TARFILE &
' ' &
MODEL;
RM_COMMAND : constant STRING := UNIX.REMOVE &
' ' &
REMOTE_TARFILE;
MY_STATE : ACCESS_STRING;
procedure PROCESS (STATE : in out ACCESS_STRING;
LINE : in STRING) is
begin
pragma ASSERT (STATE = null);
STATE := new STRING'(LINE);
pragma HEAP (JOB_SEGMENT.GET);
end PROCESS;
procedure EXECUTE_SCRIPT is
new ASAOPEN.EXECUTE (STATE_RECORD => ACCESS_STRING,
PROCESS => PROCESS);
begin
if RELEASE then
PROFILE.SET (RESPONSE);
--
-- Acquire a connection.
--
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S);
--
-- Find the associated files.
--
EXECUTE_SCRIPT (IN_CONTEXT => C,
MODEL => MODEL,
TEMPLATE_NAME => ASSOCIATED,
STATE => MY_STATE,
STATUS => S);
LOGGER.STATUS (S);
--
-- Archive all the files, from the appropriate directory.
--
EXECUTE (COMMAND => CD_COMMAND &
UNIX.COMMAND_SEPARATOR &
TAR_COMMAND &
' ' &
MY_STATE.all,
INTERACTIVE => FALSE,
IN_CONTEXT => C,
TIMEOUT => DEFAULT_TIMEOUT);
--
-- Upload the tar file.
--
DIIO.CREATE (FILE => ARCHIVE_FILE,
MODE => DIIO.OUT_FILE,
NAME => ARCHIVE_FILE_NAME,
ACTION_ID => GWO.ACTION_ID (THE_HANDLE));
RO.GET (FROM_FILE => REMOTE_TARFILE,
IN_CONTEXT => C,
TO_FILE => ARCHIVE_FILE,
STATUS => S);
LOGGER.STATUS (S);
DIIO.CLOSE (FILE => ARCHIVE_FILE);
--
-- Delete the remote tarfile.
--
EXECUTE (COMMAND => RM_COMMAND,
INTERACTIVE => FALSE,
IN_CONTEXT => C,
TIMEOUT => DEFAULT_TIMEOUT);
--
-- Release the connection.
--
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S);
end if;
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => FALSE);
exception
when PROFILE.ERROR =>
ERRORS := (WARNINGS => 0, ERRORS => 1, FATAL => TRUE);
end POST_CMVC_COPY;
procedure PRE_MAKE_CONTROLLED (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SAVE_SOURCE : BOOLEAN;
ALLOW_CONTROLLED : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
THE_HANDLE : DC.GATEWAY_HANDLE := REOPEN (HANDLE, ACTION_ID);
C : RO.CONTEXT;
HAS_DESTROYED_GATEWAY : BOOLEAN;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION_ID;
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (THE_HANDLE);
GATEWAY_FULL_NAME : constant STRING :=
DIR.NAMING.GET_FULL_NAME (GATEWAY_OBJECT);
HOST : constant STRING := ASAP.DATA_HOST (THE_HANDLE);
MODEL : constant STRING := ASAP.DATA_CONTEXT (THE_HANDLE) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (THE_HANDLE);
begin
PROFILE.SET (RESPONSE);
ALLOW_CONTROLLED := TRUE;
if SAVE_SOURCE then
LOGGER.NEGATIVE (ASA_DEFINITIONS.ASA &
" gateway objects cannot be source-controlled");
ERRORS := (WARNINGS => 0, ERRORS => 1, FATAL => FALSE);
else
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
if not IS_UP_TO_DATE (THE_HANDLE, IN_CONTEXT => C) then
LOGGER.POSITIVE ("Accepting changes from model " & MODEL);
GWO.CLOSE (THE_HANDLE, S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ACCEPT_CHANGES (GATEWAY_OBJECT => GATEWAY_OBJECT,
IN_CONTEXT => C,
MODEL => MODEL,
COMMENTS => "Automatic Accept_Changes issued by " &
"Cmvc.Make_Controlled from object " &
GATEWAY_FULL_NAME,
WORK_ORDER => "<DEFAULT>",
ACTION_ID => ACTION_ID,
HAS_DESTROYED_GATEWAY => HAS_DESTROYED_GATEWAY);
if HAS_DESTROYED_GATEWAY then
LOGGER.WARNING ("The gateway object " & GATEWAY_FULL_NAME &
" has been destroyed while accepting " &
"changes. Cmvc.Make_Controlled is " &
"unable to proceed");
ACTION.FINISH (THE_ACTION => THE_ACTION, DO_COMMIT => TRUE);
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => TRUE);
return;
end if;
end if;
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => TRUE);
ERRORS := (WARNINGS => 0, ERRORS => 0, FATAL => FALSE);
end if;
exception
when PROFILE.ERROR =>
ERRORS := (WARNINGS => 0, ERRORS => 1, FATAL => FALSE);
end PRE_MAKE_CONTROLLED;
procedure TERMINATE_SERVER (REASON : in DC.TERMINATION_CONDITION) is
begin
if REASON = DC.GATEWAY_CLASS_DEACTIVATED then
SWITCH_REGISTRATION.STOP;
end if;
end TERMINATE_SERVER;
end MODEL;
separate (ACTIONS)
package body MODULE is
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY) is
begin
MODEL.IMAGE_NAME (HANDLE => HANDLE,
VISIBLE => VISIBLE,
READ_ONLY => READ_ONLY,
NO_IMAGE => NO_IMAGE,
SHOW_PROPERTY_IMAGE => SHOW_PROPERTY_IMAGE,
ID => ID);
end IMAGE_NAME;
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT) is
begin
MODEL.BUILD_IMAGE (HANDLE => HANDLE,
VISIBLE => VISIBLE,
IN_PLACE => IN_PLACE,
FIRST_TIME => FIRST_TIME,
READ_ONLY => READ_ONLY,
IMAGE => IMAGE,
NO_IMAGE => NO_IMAGE,
UNDERLYING_OBJECT => UNDERLYING_OBJECT);
end BUILD_IMAGE;
procedure PRE_CHECK_IN (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
begin
MODEL.PRE_CHECK_IN (HANDLE => HANDLE,
SUBOBJECT => SUBOBJECT,
RESPONSE => RESPONSE,
ACTION_ID => ACTION_ID,
ERRORS => ERRORS);
end PRE_CHECK_IN;
procedure PRE_MAKE_CONTROLLED (HANDLE : DC.GATEWAY_HANDLE;
SUBOBJECT : DIRECTORY.OBJECT;
SAVE_SOURCE : BOOLEAN;
ALLOW_CONTROLLED : out BOOLEAN;
RESPONSE : PROFILE.RESPONSE_PROFILE;
ACTION_ID : ACTION.ID;
ERRORS : in out DC.ERROR_COUNTS) is
begin
MODEL.PRE_MAKE_CONTROLLED (HANDLE => HANDLE,
SUBOBJECT => SUBOBJECT,
SAVE_SOURCE => SAVE_SOURCE,
ALLOW_CONTROLLED => ALLOW_CONTROLLED,
RESPONSE => RESPONSE,
ACTION_ID => ACTION_ID,
ERRORS => ERRORS);
end PRE_MAKE_CONTROLLED;
end MODULE;
with IO_EXCEPTIONS;
with LOGGER;
with REQUIREMENTS;
with STRING_UTILITIES;
separate (ACTIONS)
package body REQUIREMENT is
package DCP renames DIRECTORY.CONTROL_POINT;
package DIIO renames DEVICE_INDEPENDENT_IO;
package DNA renames DIRECTORY.NAMING;
package GWO renames GATEWAY_OBJECT;
function FORMATTED_IMAGE
(R : in REQUIREMENTS.REQUIREMENT_KIND) return STRING is
CAPITALIZE_NEXT : BOOLEAN := TRUE;
OFFSET : constant := CHARACTER'POS ('a') - CHARACTER'POS ('A');
THE_IMAGE : constant STRING := REQUIREMENTS.REQUIREMENT_KIND'IMAGE (R);
THE_FORMATTED_IMAGE : STRING (THE_IMAGE'RANGE);
begin
for I in THE_IMAGE'RANGE loop
if THE_IMAGE (I) = '_' then
THE_FORMATTED_IMAGE (I) := ' ';
CAPITALIZE_NEXT := TRUE;
elsif CAPITALIZE_NEXT then
THE_FORMATTED_IMAGE (I) := THE_IMAGE (I);
CAPITALIZE_NEXT := FALSE;
else
THE_FORMATTED_IMAGE (I) :=
CHARACTER'VAL (CHARACTER'POS (THE_IMAGE (I)) + OFFSET);
end if;
end loop;
return THE_FORMATTED_IMAGE;
end FORMATTED_IMAGE;
function IMAGE_CONTENTS (IMAGE : in DC.IMAGE_ID;
CONTENTS_BEFORE : in STRING;
FIRST_LINE_TO_EXAMINE : in POSITIVE;
LAST_LINE_TO_EXAMINE : in NATURAL) return STRING is
begin
if FIRST_LINE_TO_EXAMINE > LAST_LINE_TO_EXAMINE then
return CONTENTS_BEFORE;
else
return IMAGE_CONTENTS
(IMAGE => IMAGE,
CONTENTS_BEFORE =>
CONTENTS_BEFORE & ASCII.LF &
DC.LINE_CONTENTS
(ID => IMAGE, LINE => FIRST_LINE_TO_EXAMINE),
FIRST_LINE_TO_EXAMINE => FIRST_LINE_TO_EXAMINE + 1,
LAST_LINE_TO_EXAMINE => LAST_LINE_TO_EXAMINE);
end if;
end IMAGE_CONTENTS;
function IMAGE_CONTENTS (IMAGE : in DC.IMAGE_ID)
return STRING is
LAST_LINE : NATURAL := DC.LAST_LINE (IMAGE);
begin
if LAST_LINE = 0 then
return "";
else
return IMAGE_CONTENTS (IMAGE => IMAGE,
CONTENTS_BEFORE => DC.LINE_CONTENTS
(ID => IMAGE, LINE => 1),
FIRST_LINE_TO_EXAMINE => 2,
LAST_LINE_TO_EXAMINE => LAST_LINE);
end if;
end IMAGE_CONTENTS;
function RELATIVE_NAME
(FULL_NAME : in STRING; RELATIVE_TO : in STRING) return STRING is
begin
pragma ASSERT (FULL_NAME'LENGTH >= RELATIVE_TO'LENGTH and then
FULL_NAME (FULL_NAME'FIRST ..
FULL_NAME'FIRST + RELATIVE_TO'LENGTH - 1) =
RELATIVE_TO);
return FULL_NAME
(FULL_NAME'FIRST + RELATIVE_TO'LENGTH + 1 -- Skip the '.'
.. FULL_NAME'LAST);
end RELATIVE_NAME;
procedure IMAGE_NAME (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
READ_ONLY : BOOLEAN;
NO_IMAGE : out BOOLEAN;
SHOW_PROPERTY_IMAGE : out BOOLEAN;
ID : out DC.IMAGE_IDENTITY) is
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (HANDLE);
S : SS.CONDITION;
begin
SHOW_PROPERTY_IMAGE := FALSE;
ID := (I1 => DIR.UNIQUE (GATEWAY_OBJECT), I2 => 0);
NO_IMAGE := FALSE;
if not READ_ONLY then
S := CHECK_WRITEABLE (HANDLE);
LOGGER.STATUS (S);
end if;
exception
when PROFILE.ERROR =>
NO_IMAGE := TRUE;
LOGGER.ERROR ("Image construction is quitting after errors",
RAISE_ERROR => FALSE);
end IMAGE_NAME;
procedure BUILD_IMAGE (HANDLE : DC.GATEWAY_HANDLE;
VISIBLE : BOOLEAN;
IN_PLACE : BOOLEAN;
FIRST_TIME : BOOLEAN;
READ_ONLY : in out BOOLEAN;
IMAGE : DC.IMAGE_ID;
NO_IMAGE : out BOOLEAN;
UNDERLYING_OBJECT : out DIRECTORY.OBJECT) is
E : DIR.ERROR_STATUS;
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (HANDLE);
GATEWAY_FULL_NAME : constant STRING := DNA.GET_FULL_NAME (GATEWAY_OBJECT);
PARENT_LIBRARY : DIR.OBJECT;
begin
UNDERLYING_OBJECT := DIR.NIL;
if not READ_ONLY then
if SS.ERROR (CHECK_WRITEABLE (HANDLE)) then
NO_IMAGE := TRUE;
return;
end if;
end if;
DCP.PARENT_LIBRARY (THE_OBJECT => GATEWAY_OBJECT,
THE_LIBRARY => PARENT_LIBRARY,
STATUS => E);
LOGGER.STATUS (E);
DC.REPLACE_HEADER
(IMAGE => IMAGE,
HEADER => STRING_UTILITIES.CAPITALIZE
(RELATIVE_NAME (FULL_NAME => GATEWAY_FULL_NAME,
RELATIVE_TO => DNA.GET_FULL_NAME
(PARENT_LIBRARY))) &
" : " & FORMATTED_IMAGE
(ASAP.ASA_REQUIREMENT_KIND (HANDLE)) & ';');
DC.REPLACE_LINES (IMAGE => IMAGE,
STARTING_LINE => 1,
NUMBER_OF_LINES => DC.LAST_LINE (IMAGE),
NEW_TEXT => ASAP.ASA_REQUIREMENT_TEXT (HANDLE));
NO_IMAGE := FALSE;
exception
when PROFILE.ERROR =>
NO_IMAGE := TRUE;
LOGGER.ERROR ("Image construction is quitting after errors",
RAISE_ERROR => FALSE);
end BUILD_IMAGE;
procedure POST_COMMIT (HANDLE : DC.GATEWAY_HANDLE;
IMAGE : DC.IMAGE_ID) is
S : SS.CONDITION;
THE_HANDLE : DC.GATEWAY_HANDLE := HANDLE;
begin
if not GWO.IS_MAIN_OBJECT_OPEN_FOR_UPDATE (HANDLE) then
GWO.RE_OPEN_MAIN_OBJECT_FOR_UPDATE (THE_HANDLE, ERRORS => S);
LOGGER.STATUS (S);
end if;
ASAP.SET_ASA_REQUIREMENT_TEXT (THE_HANDLE,
VALUE => IMAGE_CONTENTS (IMAGE));
exception
when PROFILE.ERROR =>
LOGGER.ERROR ("Image has not been committed", RAISE_ERROR => FALSE);
end POST_COMMIT;
procedure EDIT (HANDLE : DC.GATEWAY_HANDLE;
IMAGE : DC.IMAGE_ID;
S : DC.SELECTION;
C : DC.CURSOR;
VISIBLE : BOOLEAN;
ALLOW_EDIT : out BOOLEAN) is
ST : SS.CONDITION;
begin
ST := CHECK_WRITEABLE (HANDLE);
LOGGER.STATUS (ST);
ALLOW_EDIT := TRUE;
exception
when PROFILE.ERROR =>
ALLOW_EDIT := FALSE;
LOGGER.ERROR ("Edit is quitting after errors", RAISE_ERROR => FALSE);
end EDIT;
procedure IO_OPEN (FILE : in out DEVICE_INDEPENDENT_IO.FILE_TYPE;
MODE : DEVICE_INDEPENDENT_IO.FILE_MODE;
HANDLE : DC.GATEWAY_HANDLE;
FORM : STRING;
ACTION_ID : ACTION.ID) is
use DIIO;
begin
pragma ASSERT (MODE = DIIO.IN_FILE);
DIIO.CREATE (FILE,
MODE => DIIO.OUT_FILE,
NAME => "",
ACTION_ID => ACTION_ID);
DIIO.WRITE (FILE,
ITEM => ASAP.ASA_REQUIREMENT_TEXT (HANDLE));
DIIO.RESET (FILE,
MODE => DIIO.IN_FILE);
end IO_OPEN;
end REQUIREMENT;with REQUIREMENTS;
package ASA is
procedure CREATE_REQUIREMENT (FOR_OBJECT : in STRING := "<CURSOR>";
NAME : in STRING := ">>Requirement Name<<";
KIND : in REQUIREMENTS.NON_FUNCTIONAL :=
REQUIREMENTS.PERFORMANCE;
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
procedure COPY_REQUIREMENT (REQUIREMENT : in STRING := "<REGION>";
TO_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
procedure MOVE_REQUIREMENT (REQUIREMENT : in STRING := "<REGION>";
TO_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
procedure ACCEPT_CHANGES (IN_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
procedure CREATE_MODEL (MODEL : in STRING := ">>ASA Model Name<<";
HOST : in STRING := ">>Machine Name<<";
INTO_VIEW : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
procedure IMPORT_MODEL (MODEL : in STRING := ">>ASA Model Name<<";
HOST : in STRING := ">>Machine Name<<";
INTO_VIEW : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>");
end ASA;with ACTION;
with ASA_DEFINITIONS;
with CALENDAR;
with DEBUG_TOOLS;
with DIRECTORY;
with GATEWAYS;
with GATEWAY_OBJECT;
with HIERARCHY;
with LOGGER;
with OBJECT_CLASS;
with OBJECT_SUBCLASS;
with PROFILE;
with SIMPLE_STATUS;
with UNIX_DEFINITIONS;
package body ASA is
PACKAGE_NAME : constant STRING := "Asa.";
package ASAP renames ASA_DEFINITIONS.PROPERTIES;
package DIR renames DIRECTORY;
package DCP renames DIRECTORY.CONTROL_POINT;
package DNA renames DIRECTORY.NAMING;
package GWO renames GATEWAY_OBJECT;
package HCHY renames HIERARCHY;
package SS renames SIMPLE_STATUS;
package UNIX renames UNIX_DEFINITIONS;
function MUST_RAISE_ERROR return BOOLEAN is
use PROFILE;
begin
return PROFILE.REACTION = PROFILE.PROPAGATE or else
PROFILE.REACTION = PROFILE.RAISE_ERROR;
end MUST_RAISE_ERROR;
procedure CHECK_REQUIREMENT_NAME (REQUIREMENT_NAME : in STRING;
ACTION_ID : in ACTION.ID;
IS_A_REQUIREMENT : out BOOLEAN;
REQUIREMENT_OBJECT : out DIR.OBJECT;
REQUIREMENT_HANDLE : out GWO.HANDLE) is
E : DIR.ERROR_STATUS;
HANDLE : GWO.HANDLE;
N : DNA.NAME_STATUS;
OBJECT : DIR.OBJECT;
S : SS.CONDITION;
use ASA_DEFINITIONS;
use DNA;
begin
DNA.RESOLVE (NAME => REQUIREMENT_NAME,
THE_OBJECT => OBJECT,
STATUS => N);
if N /= DNA.SUCCESSFUL then
IS_A_REQUIREMENT := FALSE;
REQUIREMENT_OBJECT := DIR.NIL;
REQUIREMENT_HANDLE := GWO.NULL_HANDLE;
elsif DIR.IS_GATEWAY (OBJECT) then
GWO.OPEN_MAIN_OBJECT (OBJECT => OBJECT,
H => HANDLE,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) or else ASAP.CLASS (HANDLE) /=
ASA_DEFINITIONS.ASA_REQUIREMENT then
IS_A_REQUIREMENT := FALSE;
REQUIREMENT_OBJECT := OBJECT;
REQUIREMENT_HANDLE := GWO.NULL_HANDLE;
else
IS_A_REQUIREMENT := TRUE;
REQUIREMENT_OBJECT := OBJECT;
REQUIREMENT_HANDLE := HANDLE;
end if;
end if;
end CHECK_REQUIREMENT_NAME;
procedure CHECK_VIEW_NAME (VIEW_NAME : in STRING;
ACTION_ID : in ACTION.ID;
IS_A_COMBINED_VIEW : out BOOLEAN;
VIEW_OBJECT : out DIR.OBJECT) is
E : DIR.ERROR_STATUS;
N : DNA.NAME_STATUS;
OBJECT : DIR.OBJECT;
VIEW : DIR.OBJECT;
VIEW_SUBCLASS : DIR.SUBCLASS;
use DIR;
use DNA;
begin
DNA.RESOLVE (NAME => VIEW_NAME,
THE_OBJECT => OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
if N /= DNA.SUCCESSFUL then
IS_A_COMBINED_VIEW := FALSE;
VIEW_OBJECT := DIR.NIL;
else
if DCP.IS_WORLD (OBJECT) then
VIEW := OBJECT;
else
DCP.PARENT_WORLD
(THE_OBJECT => OBJECT, THE_WORLD => VIEW, STATUS => E);
if E /= SUCCESSFUL then
IS_A_COMBINED_VIEW := FALSE;
VIEW_OBJECT := DIR.NIL;
end if;
end if;
VIEW_SUBCLASS := DIR.GET_SUBCLASS (VIEW);
IS_A_COMBINED_VIEW := VIEW_SUBCLASS =
OBJECT_SUBCLASS.COMBINED_VIEW_SUBCLASS;
VIEW_OBJECT := VIEW;
end if;
end CHECK_VIEW_NAME;
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;
procedure CREATE_REQUIREMENT (FOR_OBJECT : in STRING := "<CURSOR>";
NAME : in STRING := ">>Requirement Name<<";
KIND : in REQUIREMENTS.NON_FUNCTIONAL :=
REQUIREMENTS.PERFORMANCE;
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Create_Requirement";
S : SS.CONDITION;
THE_ACTION : ACTION.ID;
THE_STATE : GATEWAYS.STATE;
begin
PROFILE.SET (RESPONSE, S);
THE_ACTION := ACTION.START;
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
GATEWAYS.CREATE (IN_GATEWAY => FOR_OBJECT,
REQUIREMENT_NAME => NAME,
REQUIREMENT_KIND => KIND,
REQUIREMENT_TEXT => "",
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end CREATE_REQUIREMENT;
procedure COPY_REQUIREMENT (REQUIREMENT : in STRING := "<REGION>";
TO_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Copy_Requirement";
GATEWAY : GWO.HANDLE;
GATEWAY_OBJECT : DIR.OBJECT;
IS_A_REQUIREMENT : BOOLEAN;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION.START;
THE_STATE : GATEWAYS.STATE;
begin
PROFILE.SET (RESPONSE, S);
CHECK_REQUIREMENT_NAME (REQUIREMENT_NAME => REQUIREMENT,
ACTION_ID => THE_ACTION,
IS_A_REQUIREMENT => IS_A_REQUIREMENT,
REQUIREMENT_OBJECT => GATEWAY_OBJECT,
REQUIREMENT_HANDLE => GATEWAY);
if not IS_A_REQUIREMENT then
if DIR.IS_NIL (GATEWAY_OBJECT) then
LOGGER.NEGATIVE (REQUIREMENT & " is not a gateway of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT));
else
LOGGER.NEGATIVE (DNA.GET_FULL_NAME (GATEWAY_OBJECT) &
" is not a gateway of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT));
end if;
end if;
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
GATEWAYS.CREATE (IN_GATEWAY => TO_OBJECT,
REQUIREMENT_NAME => DNA.GET_SIMPLE_NAME (GATEWAY_OBJECT),
REQUIREMENT_KIND => ASAP.ASA_REQUIREMENT_KIND (GATEWAY),
REQUIREMENT_TEXT => ASAP.ASA_REQUIREMENT_TEXT (GATEWAY),
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end COPY_REQUIREMENT;
procedure MOVE_REQUIREMENT (REQUIREMENT : in STRING := "<REGION>";
TO_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Move_Requirement";
GATEWAY : GWO.HANDLE;
GATEWAY_OBJECT : DIR.OBJECT;
IS_A_REQUIREMENT : BOOLEAN;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION.START;
THE_STATE : GATEWAYS.STATE;
begin
PROFILE.SET (RESPONSE, S);
CHECK_REQUIREMENT_NAME (REQUIREMENT_NAME => REQUIREMENT,
ACTION_ID => THE_ACTION,
IS_A_REQUIREMENT => IS_A_REQUIREMENT,
REQUIREMENT_OBJECT => GATEWAY_OBJECT,
REQUIREMENT_HANDLE => GATEWAY);
if not IS_A_REQUIREMENT then
if DIR.IS_NIL (GATEWAY_OBJECT) then
LOGGER.NEGATIVE (REQUIREMENT & " is not a gateway of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT));
else
LOGGER.NEGATIVE (DNA.GET_FULL_NAME (GATEWAY_OBJECT) &
" is not a gateway of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT));
end if;
end if;
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
GATEWAYS.CREATE (IN_GATEWAY => TO_OBJECT,
REQUIREMENT_NAME => DNA.GET_SIMPLE_NAME (GATEWAY_OBJECT),
REQUIREMENT_KIND => ASAP.ASA_REQUIREMENT_KIND (GATEWAY),
REQUIREMENT_TEXT => ASAP.ASA_REQUIREMENT_TEXT (GATEWAY),
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.DESTROY (GATEWAY_NAME => DNA.GET_FULL_NAME (GATEWAY_OBJECT),
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end MOVE_REQUIREMENT;
procedure ACCEPT_CHANGES (IN_OBJECT : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Accept_Changes";
BUILD_TIME : CALENDAR.TIME;
E : DIR.ERROR_STATUS;
ENCLOSING_LIBRARY : DIR.OBJECT;
GATEWAY : GWO.HANDLE;
GATEWAY_OBJECT : DIR.OBJECT;
ROOT_ITERATOR : HCHY.MODULE_ITERATOR;
ROOT_MODULE : HCHY.MODULE;
S : SS.CONDITION;
THE_ACTION : ACTION.ID := ACTION.START;
THE_STATE : GATEWAYS.STATE;
begin
PROFILE.SET (RESPONSE, S);
--
-- Open the specified gateway.
--
GWO.OPEN_MAIN_OBJECT (OBJECT => IN_OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => THE_ACTION,
ERRORS => S);
LOGGER.STATUS (S);
GATEWAY_OBJECT := GWO.DIRECTORY_OBJECT (GATEWAY);
DCP.PARENT_LIBRARY (THE_OBJECT => GATEWAY_OBJECT,
THE_LIBRARY => ENCLOSING_LIBRARY,
STATUS => E);
LOGGER.STATUS (E);
declare
HOST : constant STRING := ASAP.DATA_HOST (GATEWAY);
MODEL : constant STRING := ASAP.DATA_CONTEXT (GATEWAY) &
UNIX.CONTEXT_SEPARATOR &
ASAP.DATA_NAME (GATEWAY);
begin
--
-- Compute module hierarchy for the associated model.
--
LOGGER.NOTE ("Building module hierarchy for model " & MODEL);
HCHY.BUILD (MODEL => MODEL,
HOST => HOST,
ROOT => ROOT_MODULE,
BUILD_TIME => BUILD_TIME);
ROOT_ITERATOR := HCHY.MAKE (ROOT_MODULE);
GWO.CLOSE (GATEWAY, ERRORS => S);
LOGGER.STATUS (S);
--
-- Find the root of the gateway tree.
--
GATEWAY_OBJECT := ROOT_OF (GATEWAY => GATEWAY_OBJECT,
ACTION_ID => THE_ACTION);
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
--
-- Delete those gateways that no longer have corresponding
-- modules.
--
GATEWAYS.REDUCE (GATEWAY_NAME => DNA.GET_FULL_NAME (GATEWAY_OBJECT),
CANDIDATE_MODULES => ROOT_ITERATOR,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
--
-- Create gateways for the new modules.
--
GATEWAYS.AUGMENT (FOR_MODULE => ROOT_MODULE,
IN_LIBRARY => DNA.GET_FULL_NAME (ENCLOSING_LIBRARY),
HOST => HOST,
MODEL => MODEL,
UPDATE_TIME => BUILD_TIME,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
end;
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end ACCEPT_CHANGES;
procedure CREATE_MODEL (MODEL : in STRING := ">>ASA Model Name<<";
HOST : in STRING := ">>Machine Name<<";
INTO_VIEW : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Create_Model";
S : SS.CONDITION;
BUILD_TIME : CALENDAR.TIME;
IS_A_COMBINED_VIEW : BOOLEAN;
ROOT_MODULE : HCHY.MODULE;
THE_ACTION : ACTION.ID := ACTION.START;
THE_STATE : GATEWAYS.STATE;
VIEW : DIR.OBJECT;
use DIR;
begin
PROFILE.SET (RESPONSE, S);
CHECK_VIEW_NAME (VIEW_NAME => INTO_VIEW,
ACTION_ID => THE_ACTION,
IS_A_COMBINED_VIEW => IS_A_COMBINED_VIEW,
VIEW_OBJECT => VIEW);
if not IS_A_COMBINED_VIEW then
if DIR.IS_NIL (VIEW) then
LOGGER.NEGATIVE (INTO_VIEW & " is not a combined view");
else
LOGGER.NEGATIVE (DNA.GET_FULL_NAME (VIEW) &
" is not a combined view");
end if;
end if;
ROOT_MODULE := HCHY.MAKE (IDENTIFIER => UNIX.SIMPLE_NAME (MODEL));
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
GATEWAYS.CREATE (FOR_MODULE => ROOT_MODULE,
IN_LIBRARY => DNA.GET_FULL_NAME (VIEW) & ".Units",
HOST => HOST,
MODEL => MODEL,
UPDATE_TIME => BUILD_TIME,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end CREATE_MODEL;
procedure IMPORT_MODEL (MODEL : in STRING := ">>ASA Model Name<<";
HOST : in STRING := ">>Machine Name<<";
INTO_VIEW : in STRING := "<CURSOR>";
COMMENTS : in STRING := "";
WORK_ORDER : in STRING := "<DEFAULT>";
RESPONSE : in STRING := "<PROFILE>") is
SUBPROGRAM_NAME : constant STRING := "Import_Model";
S : SS.CONDITION;
BUILD_TIME : CALENDAR.TIME;
IS_A_COMBINED_VIEW : BOOLEAN;
ROOT_MODULE : HCHY.MODULE;
THE_ACTION : ACTION.ID := ACTION.START;
THE_STATE : GATEWAYS.STATE;
VIEW : DIR.OBJECT;
use DIR;
begin
PROFILE.SET (RESPONSE, S);
CHECK_VIEW_NAME (VIEW_NAME => INTO_VIEW,
ACTION_ID => THE_ACTION,
IS_A_COMBINED_VIEW => IS_A_COMBINED_VIEW,
VIEW_OBJECT => VIEW);
if not IS_A_COMBINED_VIEW then
if DIR.IS_NIL (VIEW) then
LOGGER.NEGATIVE (INTO_VIEW & " is not a combined view");
else
LOGGER.NEGATIVE (DNA.GET_FULL_NAME (VIEW) &
" is not a combined view");
end if;
end if;
LOGGER.NOTE ("Building module hierarchy for model " & MODEL);
HCHY.BUILD (MODEL => MODEL,
HOST => HOST,
ROOT => ROOT_MODULE,
BUILD_TIME => BUILD_TIME);
GATEWAYS.INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => WORK_ORDER);
GATEWAYS.CREATE (FOR_MODULE => ROOT_MODULE,
IN_LIBRARY => DNA.GET_FULL_NAME (VIEW) & ".Units",
HOST => HOST,
MODEL => MODEL,
UPDATE_TIME => BUILD_TIME,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GATEWAYS.FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION, DO_COMMIT => TRUE);
exception
when PROFILE.ERROR =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" is quitting after errors",
RAISE_ERROR => MUST_RAISE_ERROR);
when others =>
LOGGER.ERROR (PACKAGE_NAME & SUBPROGRAM_NAME &
" aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
RAISE_ERROR => MUST_RAISE_ERROR);
ACTION.FINISH (THE_ACTION, DO_COMMIT => FALSE);
end IMPORT_MODEL;
end ASA;--
-- This package provides DTIA-based services to execute asaopen scripts
-- and analyze their output.
--
-- Given that it is not possible to pass parameters to asaopen when
-- executing a script, a macro-expansion process is needed to substitute
-- character strings in the asaopen scripts.
--
-- Text files residing on the R1000 are thus template files that must be
-- processed for symbol substitution before they can be sent to the
-- remote machine for execution with asaopen. The type SYMBOL below
-- specifies the symbols that can appear in asaopen scripts. To be
-- processed by the macro-expander, symbols must be delimited by
-- SEPARATOR, below.
--
-- The generic procedure EXECUTE must be instantiated with a
-- procedure PROCESS, called on each line of the result. The
-- STATE_RECORD is used to propagate user-specific information.
--
-- To easily distinguish the junk output produced by the activation of
-- asaopen from the useful output of the script itself, it is expected
-- that the script will write its output on a file whose name must be
-- denoted by the symbol OUTPUT. The output file will then be uploaded
-- for analysis on the R1000.
--
with REMOTE_OPERATIONS;
with SIMPLE_STATUS;
package ASAOPEN is
generic
type STATE_RECORD is private;
with procedure PROCESS (STATE : in out STATE_RECORD;
LINE : in STRING);
procedure EXECUTE (IN_CONTEXT : in REMOTE_OPERATIONS.CONTEXT;
MODEL : in STRING;
TEMPLATE_NAME : in STRING;
STATE : in out STATE_RECORD;
STATUS : out SIMPLE_STATUS.CONDITION);
private
type SYMBOL is (ANNOTATIONS, ANNOTATION_TYPES, MODEL, OUTPUT);
SEPARATOR : constant STRING := "**";
end ASAOPEN;with ASA_DEFINITIONS;
with DEBUG_TOOLS;
with DEVICE_INDEPENDENT_IO;
with DIRECTORY_TOOLS;
with IO;
with LOGGER;
with PROFILE;
with REMOTE_OPERATIONS;
with STRING_UTILITIES;
with UNIX_DEFINITIONS;
pragma ELABORATE (ASA_DEFINITIONS);
package body ASAOPEN is
package ASAC renames ASA_DEFINITIONS.COMMANDS;
package ASAS renames ASA_DEFINITIONS.SWITCHES;
package DIO renames DEVICE_INDEPENDENT_IO;
package DNA renames DIRECTORY_TOOLS.NAMING;
package RO renames REMOTE_OPERATIONS;
package SS renames SIMPLE_STATUS;
package SU renames STRING_UTILITIES;
package UNIX renames UNIX_DEFINITIONS;
LOCAL_ANNOTATIONS : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".ANNOTATIONS";
LOCAL_ANNOTATION_TYPES : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".ANNOTATION_TYPES";
TEMPLATE_ERROR : exception;
function "-" (S1 : in STRING; S2 : in STRING) return STRING is
begin
pragma ASSERT (S1'LENGTH >= S2'LENGTH and then
S1 (S1'LAST - S2'LENGTH + 1 .. S1'LAST) = S2);
return S1 (S1'FIRST .. S1'LAST - S2'LENGTH);
end "-";
-- ------------------------------
-- ( ) Body of external procedure
-- ------------------------------
procedure EXECUTE (IN_CONTEXT : in REMOTE_OPERATIONS.CONTEXT;
MODEL : in STRING;
TEMPLATE_NAME : in STRING;
STATE : in out STATE_RECORD;
STATUS : out SIMPLE_STATUS.CONDITION) is
-- ----------------
-- ( . ) Local data
-- ----------------
S : SS.CONDITION;
ERROR_FILE : IO.FILE_TYPE; -- The remote stderr and stdout.
NULL_INPUT_FILE : DIO.FILE_TYPE;
OUTPUT_FILE : IO.FILE_TYPE; -- The result of executing the script.
SCRIPT_FILE : IO.FILE_TYPE;
TEMPLATE_FILE : IO.FILE_TYPE;
REMOTE_ANNOTATIONS : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.ANNOTATIONS_EXTENSION);
REMOTE_ANNOTATION_TYPES : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.ANNOTATION_TYPES_EXTENSION);
REMOTE_OUTPUT : constant STRING := UNIX.TEMPORARY_FILENAME ("");
REMOTE_PROCESSED_MODEL : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.MODEL_EXTENSION);
REMOTE_SCRIPT : constant STRING :=
UNIX.TEMPORARY_FILENAME (ASAC.ASAOPEN_EXTENSION);
--[bugs]
-- Due to a bug in ASA, the .opn extension cannot be included on
-- the command line.
-- Due to a bug in REMOTE_OPERATIONS.EXECUTE, we put a leading
-- space to make sure that the lower bound of the command string
-- is 1.
--
ASAOPEN_COMMAND : constant STRING :=
' ' &
ASAS.BIN_DIRECTORY (RO.MACHINE (IN_CONTEXT)) &
UNIX.CONTEXT_SEPARATOR &
ASAC.ASAOPEN &
' ' &
(REMOTE_SCRIPT - ASAC.ASAOPEN_EXTENSION);
RM_COMMAND : constant STRING := UNIX.REMOVE &
' ' &
REMOTE_ANNOTATIONS &
' ' &
REMOTE_ANNOTATION_TYPES &
' ' &
REMOTE_OUTPUT &
' ' &
REMOTE_SCRIPT &
' ' &
REMOTE_PROCESSED_MODEL;
SED_COMMAND : constant STRING :=
UNIX.STREAM_EDITOR &
' ' &
UNIX.EDIT &
' ' &
"'/&requirement_[1-9] '""'""'.*'""'""'/s/ /_/g'" &
' ' &
UNIX.EDIT &
' ' &
"'/&requirement_[1-9] '""'""'[^'""'""']*$/,/'""'""';/s/ /_/g'" &
' ' &
UNIX.EDIT &
' ' &
"'/&requirement_[1-9]/s/_*\(&requirement_[1-9]\)_*'""'""'/ \1 '""'""'/'" &
' ' &
UNIX.EDIT &
' ' &
"""s/_*;/;/""" &
' ' &
MODEL &
' ' &
UNIX.OUTPUT_REDIRECT &
' ' &
REMOTE_PROCESSED_MODEL;
-- ------------------------
-- ( . ) Template expansion
-- ------------------------
procedure EXPAND (TEMPLATE_FILE : in IO.FILE_TYPE;
SCRIPT_FILE : in IO.FILE_TYPE) is
use IO;
pragma ASSERT (IO.IS_OPEN (TEMPLATE_FILE) and then
IO.MODE (TEMPLATE_FILE) = IO.IN_FILE and then
IO.IS_OPEN (SCRIPT_FILE) and then
IO.MODE (SCRIPT_FILE) = IO.OUT_FILE);
--
-- A line is decomposed into symbol fields and constant fields.
-- Fields are separated by the separator. The first field of a
-- line is always a constant field. BOUNDARY is the first
-- character of the current field.
--
type FIELD is (CONSTANT_FIELD, SYMBOL_FIELD);
CURRENT_FIELD : FIELD;
BOUNDARY : NATURAL;
THE_SYMBOL : SYMBOL;
begin
while not IO.END_OF_FILE (TEMPLATE_FILE) loop
declare
LINE : constant STRING := IO.GET_LINE (TEMPLATE_FILE);
begin
CURRENT_FIELD := CONSTANT_FIELD;
BOUNDARY := LINE'FIRST;
for I in LINE'FIRST .. LINE'LAST - SEPARATOR'LENGTH + 1 loop
if LINE (I .. I + SEPARATOR'LENGTH - 1) = SEPARATOR then
case CURRENT_FIELD is
when CONSTANT_FIELD =>
--
-- Found the initial symbol separator. First write
-- the text preceding it.
--
IO.PUT (SCRIPT_FILE, LINE (BOUNDARY .. I - 1));
CURRENT_FIELD := SYMBOL_FIELD;
BOUNDARY := I + SEPARATOR'LENGTH;
when SYMBOL_FIELD =>
--
-- Found the final symbol separator. Write the
-- value of the symbol.
--
THE_SYMBOL := SYMBOL'VALUE
(LINE (BOUNDARY .. I - 1));
case THE_SYMBOL is
when ANNOTATIONS =>
IO.PUT (SCRIPT_FILE, REMOTE_ANNOTATIONS);
when ANNOTATION_TYPES =>
IO.PUT (SCRIPT_FILE, REMOTE_ANNOTATION_TYPES);
when ASAOPEN.MODEL =>
IO.PUT (SCRIPT_FILE, REMOTE_PROCESSED_MODEL);
when OUTPUT =>
IO.PUT (SCRIPT_FILE, REMOTE_OUTPUT);
end case;
CURRENT_FIELD := CONSTANT_FIELD;
BOUNDARY := I + SEPARATOR'LENGTH;
end case;
end if;
end loop;
IO.PUT_LINE (SCRIPT_FILE, LINE (BOUNDARY .. LINE'LAST));
end;
end loop;
exception
when others =>
raise TEMPLATE_ERROR;
end EXPAND;
begin
--
-- Create a script file to hold the expanded asaopen text. Open
-- the template, expand it, close it. Reset the script file to
-- read mode.
--
IO.CREATE (FILE => SCRIPT_FILE,
MODE => IO.OUT_FILE,
NAME => "");
IO.OPEN (FILE => TEMPLATE_FILE,
MODE => IO.IN_FILE,
NAME => TEMPLATE_NAME);
LOGGER.NOTE ("Expanding template file " & IO.NAME (TEMPLATE_FILE) &
" into " & IO.NAME (SCRIPT_FILE));
EXPAND (TEMPLATE_FILE => TEMPLATE_FILE,
SCRIPT_FILE => SCRIPT_FILE);
IO.CLOSE (TEMPLATE_FILE);
IO.RESET (FILE => SCRIPT_FILE,
MODE => IO.IN_FILE);
--
-- Download the script file and close it.
--
LOGGER.NOTE ("Copying file " & IO.NAME (SCRIPT_FILE) &
" to " & REMOTE_SCRIPT);
RO.PUT (FROM_FILE => IO.CONVERT (SCRIPT_FILE),
TO_FILE => REMOTE_SCRIPT,
IN_CONTEXT => IN_CONTEXT,
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
IO.CLOSE (SCRIPT_FILE);
--
-- Download the annotation files.
--
LOGGER.NOTE ("Copying file " & LOCAL_ANNOTATIONS &
" to " & REMOTE_ANNOTATIONS);
RO.PUT (FROM_FILE => LOCAL_ANNOTATIONS,
TO_FILE => REMOTE_ANNOTATIONS,
IN_CONTEXT => IN_CONTEXT,
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
LOGGER.NOTE ("Copying file " & LOCAL_ANNOTATION_TYPES &
" to " & REMOTE_ANNOTATION_TYPES);
RO.PUT (FROM_FILE => LOCAL_ANNOTATION_TYPES,
TO_FILE => REMOTE_ANNOTATION_TYPES,
IN_CONTEXT => IN_CONTEXT,
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
--
-- Create error files.
--
IO.CREATE (FILE => ERROR_FILE,
MODE => IO.OUT_FILE,
NAME => "");
--[bug]
-- Due to a bug in asaopen, the blanks are stripped from the
-- requirements' text. Before calling asaopen, we run sed on the
-- model file to change every space into an underscore. The
-- reverse transformation will be made by package HIERARCHY.
--
LOGGER.NOTE ("Executing command """ & SED_COMMAND & '"');
RO.EXECUTE (COMMAND => SED_COMMAND,
IN_CONTEXT => IN_CONTEXT,
INPUT => NULL_INPUT_FILE,
OUTPUT => IO.CONVERT (ERROR_FILE),
ERROR => IO.CONVERT (ERROR_FILE),
STATUS => S,
TIMEOUT => RO.WAIT_FOREVER);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
--
-- Execute asaopen on the downloaded script file. Do not separate
-- output and error flows.
--
LOGGER.NOTE ("Executing command """ & ASAOPEN_COMMAND & '"');
RO.EXECUTE (COMMAND => ASAOPEN_COMMAND,
IN_CONTEXT => IN_CONTEXT,
INPUT => NULL_INPUT_FILE,
OUTPUT => IO.CONVERT (ERROR_FILE),
ERROR => IO.CONVERT (ERROR_FILE),
STATUS => S,
TIMEOUT => RO.WAIT_FOREVER);
--
-- Process the error file.
--
IO.RESET (FILE => ERROR_FILE,
MODE => IO.IN_FILE);
while not IO.END_OF_FILE (ERROR_FILE) loop
LOGGER.DEBUG (IO.GET_LINE (ERROR_FILE));
end loop;
LOGGER.STATUS (S, INTERACTIVE => FALSE);
--
-- Upload the result of execution.
--
IO.CREATE (FILE => OUTPUT_FILE,
MODE => IO.OUT_FILE,
NAME => "");
LOGGER.NOTE ("Copying file " & REMOTE_OUTPUT &
" to " & IO.NAME (OUTPUT_FILE));
RO.GET (FROM_FILE => REMOTE_OUTPUT,
IN_CONTEXT => IN_CONTEXT,
TO_FILE => IO.CONVERT (OUTPUT_FILE),
STATUS => S);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
--
-- Clean up temporary files.
--
IO.RESET (FILE => ERROR_FILE,
MODE => IO.OUT_FILE);
LOGGER.NOTE ("Executing command """ & RM_COMMAND & '"');
RO.EXECUTE (COMMAND => RM_COMMAND,
IN_CONTEXT => IN_CONTEXT,
INPUT => NULL_INPUT_FILE,
OUTPUT => IO.CONVERT (ERROR_FILE),
ERROR => IO.CONVERT (ERROR_FILE),
STATUS => S,
TIMEOUT => RO.WAIT_FOREVER);
--
-- Process the error file and close it.
--
IO.RESET (FILE => ERROR_FILE,
MODE => IO.IN_FILE);
while not IO.END_OF_FILE (ERROR_FILE) loop
declare
THE_LINE : constant STRING := IO.GET_LINE (ERROR_FILE);
begin
if SU.LOCATE (FRAGMENT => "ERROR", WITHIN => THE_LINE) = 0 then
LOGGER.DEBUG (THE_LINE);
else
LOGGER.ERROR (THE_LINE);
end if;
end;
end loop;
IO.CLOSE (ERROR_FILE);
LOGGER.STATUS (S, INTERACTIVE => FALSE);
--
-- Process the output file and close it.
--
IO.RESET (FILE => OUTPUT_FILE,
MODE => IO.IN_FILE);
while not IO.END_OF_FILE (OUTPUT_FILE) loop
PROCESS (STATE => STATE,
LINE => IO.GET_LINE (OUTPUT_FILE));
end loop;
IO.CLOSE (OUTPUT_FILE);
STATUS := S;
exception
when PROFILE.ERROR =>
SS.CREATE_CONDITION
(STATUS => S,
ERROR_TYPE => "",
MESSAGE => "asaopen execution is quitting after errors",
SEVERITY => SS.PROBLEM);
STATUS := S;
when TEMPLATE_ERROR =>
SS.CREATE_CONDITION
(STATUS => S,
ERROR_TYPE => "Asaopen",
MESSAGE => "syntax error in template or template not found",
SEVERITY => SS.PROBLEM);
STATUS := S;
when others =>
SS.CREATE_CONDITION (STATUS => S,
ERROR_TYPE => "Asaopen",
MESSAGE => "execution aborted by exception " &
DEBUG_TOOLS.GET_EXCEPTION_NAME,
SEVERITY => SS.PROBLEM);
STATUS := S;
end EXECUTE;
end ASAOPEN;with CALENDAR;
with GATEWAY_OBJECT;
with REQUIREMENTS;
with UNIX_DEFINITIONS;
package ASA_DEFINITIONS is
-- Product name.
ASA : constant STRING := "ASA";
-- Gateway classes.
type GATEWAY_CLASS is (ASA_MODEL, ASA_MODULE, ASA_REQUIREMENT);
MAIN_CLASS_DIRECTORY : constant STRING :=
"!MACHINE.GATEWAY_CLASSES." & GATEWAY_CLASS'IMAGE (ASA_MODEL);
package COMMANDS is
package UNIX renames UNIX_DEFINITIONS;
-- Asaedit command and options.
ASAEDIT : constant STRING := "asaedit";
ANNOTATIONS_EXTENSION : constant STRING :=
UNIX.EXTENSION_SEPARATOR & "ann";
ANNOTATION_TYPES_EXTENSION : constant STRING :=
UNIX.EXTENSION_SEPARATOR & "aty";
MODEL_EXTENSION : constant STRING := UNIX.EXTENSION_SEPARATOR & "lsa";
ANNOTATIONS : constant STRING := "-ann";
ANNOTATION_TYPES : constant STRING := "-aty";
ASA : constant STRING := "-asa";
COUPLING : constant STRING := "-mcag";
DEVICE : constant STRING := "-dev";
GEODE : constant STRING := "-geode";
NODE : constant STRING := "-node";
NO_COMMENTS : constant STRING := "-ncom";
NO_FACTORIZE : constant STRING := "-nfact";
NO_LABELS : constant STRING := "-nlabel";
NO_LIMITS : constant STRING := "-nlimit";
NO_WARNINGS : constant STRING := "-nw";
OPTIONS : constant STRING := "-config";
READ_ONLY : constant STRING := "-read";
SHOW_ANNOTATIONS : constant STRING := "-seeann";
START_NODE : constant STRING := "-startnode";
UNDO : constant STRING := "-undo";
-- Asaopen command and options.
ASAOPEN : constant STRING := "asaopen";
ASAOPEN_EXTENSION : constant STRING := UNIX.EXTENSION_SEPARATOR & "opn";
LISTING : constant STRING := "-list";
end COMMANDS;
package PROPERTIES is
package GWO renames GATEWAY_OBJECT;
function ASA_COMMENT (H : in GWO.HANDLE) return STRING;
function ASA_DEPENDENTS (H : in GWO.HANDLE) return STRING;
function ASA_DEPENDENTS
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING;
function ASA_ID (H : in GWO.HANDLE) return POSITIVE;
function ASA_LAST_ID (H : in GWO.HANDLE) return NATURAL;
function ASA_LAST_REQUIREMENT_ID (H : in GWO.HANDLE) return NATURAL;
function ASA_NODE_NUMBER (H : in GWO.HANDLE) return STRING;
function ASA_REQUIREMENT
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING;
function ASA_REQUIREMENT_KIND (H : in GWO.HANDLE)
return REQUIREMENTS.NON_FUNCTIONAL;
function ASA_REQUIREMENT_TEXT (H : in GWO.HANDLE) return STRING;
function ASA_UPDATE_TIME (H : in GWO.HANDLE) return CALENDAR.TIME;
function CLASS (H : in GWO.HANDLE) return GATEWAY_CLASS;
function DATA_CONTEXT (H : in GWO.HANDLE) return STRING;
function DATA_HOST (H : in GWO.HANDLE) return STRING;
function DATA_NAME (H : in GWO.HANDLE) return STRING;
procedure SET_ASA_COMMENT (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_ASA_DEPENDENTS (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_ASA_DEPENDENTS
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER;
VALUE : in STRING);
procedure SET_ASA_ID (H : in GWO.HANDLE;
VALUE : in POSITIVE);
procedure SET_ASA_LAST_ID (H : in GWO.HANDLE;
VALUE : in NATURAL);
procedure SET_ASA_LAST_REQUIREMENT_ID (H : in GWO.HANDLE;
VALUE : in NATURAL);
procedure SET_ASA_NODE_NUMBER (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_ASA_REQUIREMENT
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER;
VALUE : in STRING);
procedure SET_ASA_REQUIREMENT_KIND
(H : in GWO.HANDLE;
VALUE : in REQUIREMENTS.NON_FUNCTIONAL);
procedure SET_ASA_REQUIREMENT_TEXT (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_ASA_UPDATE_TIME (H : in GWO.HANDLE;
VALUE : in CALENDAR.TIME);
procedure SET_DATA_CONTEXT (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_DATA_HOST (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_DATA_NAME (H : in GWO.HANDLE;
VALUE : in STRING);
procedure SET_PARENT_NAME (H : in GWO.HANDLE;
VALUE : in STRING);
private
ASA_COMMENT_N : constant STRING := ASA & ".COMMENT";
ASA_DEPENDENTS_F_N : constant STRING := ASA & ".DEPENDENTS_";
ASA_DEPENDENTS_NF_N : constant STRING := ASA & ".DEPENDENTS";
ASA_ID_N : constant STRING := ASA & ".ID";
ASA_LAST_ID_N : constant STRING := ASA & ".LAST_ID";
ASA_LAST_REQUIREMENT_ID_N : constant STRING :=
ASA & ".LAST_REQUIREMENT_ID";
ASA_NODE_NUMBER_N : constant STRING := ASA & ".NODE_NUMBER";
ASA_REQUIREMENT_N : constant STRING := ASA & ".REQUIREMENT_";
ASA_REQUIREMENT_KIND_N : constant STRING := ASA & ".REQUIREMENT_KIND";
ASA_REQUIREMENT_TEXT_N : constant STRING := ASA & ".REQUIREMENT_TEXT";
ASA_UPDATE_TIME_N : constant STRING := ASA & ".UPDATE_TIME";
CLASS_NAME_N : constant STRING := "CLASS_NAME";
DATA_CONTEXT_N : constant STRING := "DATA.CONTEXT";
DATA_HOST_N : constant STRING := "DATA.HOST";
DATA_NAME_N : constant STRING := "DATA.NAME";
PARENT_NAME_N : constant STRING := "PARENT_NAME";
end PROPERTIES;
package SWITCHES is
type ACTION is (ABANDON, ACCEPT_CHANGES, CONTINUE);
type CONTROL_LEVEL is (CONTROL_NONE,
CONTROL_MODEL,
CONTROL_MODULES,
CONTROL_ALL);
function ACTION_WHEN_OUT_OF_DATE return ACTION;
function BIN_DIRECTORY (HOST : in STRING) return STRING;
function CMVC_CONTROL_LEVEL return CONTROL_LEVEL;
function REMOTE_DISPLAY return STRING;
--
-- Exactly one task of the following type MUST be declared in a
-- library package by the gateway server. This object declaration
-- must NOT be part of the transitive closure of any user program:
-- such a program would not terminate.
--
task type REGISTER is
entry STOP;
end REGISTER;
private
ACTION_WHEN_OUT_OF_DATE_N : constant STRING := "ACTION_WHEN_OUT_OF_DATE";
BIN_DIRECTORIES_N : constant STRING := "BIN_DIRECTORIES";
CMVC_CONTROL_LEVEL_N : constant STRING := "CMVC_CONTROL_LEVEL";
REMOTE_DISPLAY_N : constant STRING := "REMOTE_DISPLAY";
end SWITCHES;
end ASA_DEFINITIONS;package body ASA_DEFINITIONS is
package body PROPERTIES is separate;
package body SWITCHES is separate;
end ASA_DEFINITIONS;with DIRECTORY;
with GATEWAY_PROPERTY;
with LOGGER;
with TIME_UTILITIES;
separate (ASA_DEFINITIONS)
package body PROPERTIES is
package DNA renames DIRECTORY.NAMING;
package GWP renames GATEWAY_PROPERTY;
package TU renames TIME_UTILITIES;
procedure ERROR (H : in GWO.HANDLE; PROPERTY_NAME : in STRING) is
begin
LOGGER.ERROR ("Error detected while setting property " &
PROPERTY_NAME & " of object " &
DNA.GET_FULL_NAME (GWO.DIRECTORY_OBJECT (H)));
end ERROR;
function ASA_COMMENT (H : in GWO.HANDLE) return STRING is
begin
return GWO.VALUE (H,
PROPERTY_NAME => ASA_COMMENT_N);
end ASA_COMMENT;
function ASA_DEPENDENTS (H : in GWO.HANDLE) return STRING is
begin
return GWP.VALUE (H,
PROPERTY_NAME => ASA_DEPENDENTS_NF_N);
end ASA_DEPENDENTS;
function ASA_DEPENDENTS
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING is
NUMBER_IMAGE : constant STRING :=
REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (NUMBER);
begin
return
GWP.VALUE
(H,
PROPERTY_NAME =>
ASA_DEPENDENTS_F_N &
NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 .. NUMBER_IMAGE'LAST));
end ASA_DEPENDENTS;
function ASA_ID (H : in GWO.HANDLE) return POSITIVE is
begin
return POSITIVE'VALUE (GWP.VALUE (H,
PROPERTY_NAME => ASA_ID_N));
end ASA_ID;
function ASA_LAST_ID (H : in GWO.HANDLE) return NATURAL is
begin
return NATURAL'VALUE (GWP.VALUE (H, PROPERTY_NAME => ASA_LAST_ID_N));
end ASA_LAST_ID;
function ASA_LAST_REQUIREMENT_ID (H : in GWO.HANDLE) return NATURAL is
begin
return NATURAL'VALUE (GWP.VALUE
(H, PROPERTY_NAME => ASA_LAST_REQUIREMENT_ID_N));
end ASA_LAST_REQUIREMENT_ID;
function ASA_NODE_NUMBER (H : in GWO.HANDLE) return STRING is
begin
return GWP.VALUE (H,
PROPERTY_NAME => ASA_NODE_NUMBER_N);
end ASA_NODE_NUMBER;
function ASA_REQUIREMENT
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING is
NUMBER_IMAGE : constant STRING :=
REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (NUMBER);
begin
return
GWO.VALUE
(H,
PROPERTY_NAME =>
ASA_REQUIREMENT_N &
NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 .. NUMBER_IMAGE'LAST));
end ASA_REQUIREMENT;
function ASA_REQUIREMENT_KIND (H : in GWO.HANDLE)
return REQUIREMENTS.NON_FUNCTIONAL is
begin
return REQUIREMENTS.REQUIREMENT_KIND'VALUE
(GWP.VALUE (H,
PROPERTY_NAME => ASA_REQUIREMENT_KIND_N));
end ASA_REQUIREMENT_KIND;
function ASA_REQUIREMENT_TEXT (H : in GWO.HANDLE) return STRING is
begin
return GWO.VALUE (H,
PROPERTY_NAME => ASA_REQUIREMENT_TEXT_N);
end ASA_REQUIREMENT_TEXT;
function ASA_UPDATE_TIME (H : in GWO.HANDLE) return CALENDAR.TIME is
begin
return TU.CONVERT_TIME
(TU.VALUE (GWP.VALUE (H, PROPERTY_NAME => ASA_UPDATE_TIME_N)));
end ASA_UPDATE_TIME;
function CLASS (H : in GWO.HANDLE) return GATEWAY_CLASS is
begin
return GATEWAY_CLASS'VALUE (GWP.VALUE (H,
PROPERTY_NAME => CLASS_NAME_N));
end CLASS;
function DATA_CONTEXT (H : in GWO.HANDLE) return STRING is
begin
return GWP.VALUE (H, PROPERTY_NAME => DATA_CONTEXT_N);
end DATA_CONTEXT;
function DATA_HOST (H : in GWO.HANDLE) return STRING is
begin
return GWP.VALUE (H, PROPERTY_NAME => DATA_HOST_N);
end DATA_HOST;
function DATA_NAME (H : in GWO.HANDLE) return STRING is
begin
return GWP.VALUE (H, PROPERTY_NAME => DATA_NAME_N);
end DATA_NAME;
procedure SET_ASA_COMMENT (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_COMMENT_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_DEPENDENTS_NF_N);
end if;
end SET_ASA_COMMENT;
procedure SET_ASA_DEPENDENTS (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_DEPENDENTS_NF_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_DEPENDENTS_NF_N);
end if;
end SET_ASA_DEPENDENTS;
procedure SET_ASA_DEPENDENTS
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER;
VALUE : in STRING) is
NUMBER_IMAGE : constant STRING :=
REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (NUMBER);
S : BOOLEAN;
begin
GWP.SET_VALUE
(H,
PROPERTY_NAME =>
ASA_DEPENDENTS_F_N &
NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 .. NUMBER_IMAGE'LAST),
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_DEPENDENTS_F_N & NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 ..
NUMBER_IMAGE'LAST));
end if;
end SET_ASA_DEPENDENTS;
procedure SET_ASA_ID (H : in GWO.HANDLE;
VALUE : in POSITIVE) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_ID_N,
NEW_VALUE => POSITIVE'IMAGE (VALUE),
SUCCESS => S);
if not S then
ERROR (H, ASA_ID_N);
end if;
end SET_ASA_ID;
procedure SET_ASA_LAST_ID (H : in GWO.HANDLE;
VALUE : in NATURAL) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_LAST_ID_N,
NEW_VALUE => NATURAL'IMAGE (VALUE),
SUCCESS => S);
if not S then
ERROR (H, ASA_LAST_ID_N);
end if;
end SET_ASA_LAST_ID;
procedure SET_ASA_LAST_REQUIREMENT_ID (H : in GWO.HANDLE;
VALUE : in NATURAL) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_LAST_REQUIREMENT_ID_N,
NEW_VALUE => NATURAL'IMAGE (VALUE),
SUCCESS => S);
if not S then
ERROR (H, ASA_LAST_REQUIREMENT_ID_N);
end if;
end SET_ASA_LAST_REQUIREMENT_ID;
procedure SET_ASA_NODE_NUMBER (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_NODE_NUMBER_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_NODE_NUMBER_N);
end if;
end SET_ASA_NODE_NUMBER;
procedure SET_ASA_REQUIREMENT
(H : in GWO.HANDLE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER;
VALUE : in STRING) is
NUMBER_IMAGE : constant STRING :=
REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (NUMBER);
S : BOOLEAN;
begin
GWP.SET_VALUE
(H,
PROPERTY_NAME =>
ASA_REQUIREMENT_N &
NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 .. NUMBER_IMAGE'LAST),
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_REQUIREMENT_N & NUMBER_IMAGE (NUMBER_IMAGE'FIRST + 1 ..
NUMBER_IMAGE'LAST));
end if;
end SET_ASA_REQUIREMENT;
procedure SET_ASA_REQUIREMENT_KIND
(H : in GWO.HANDLE;
VALUE : in REQUIREMENTS.NON_FUNCTIONAL) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_REQUIREMENT_KIND_N,
NEW_VALUE => REQUIREMENTS.REQUIREMENT_KIND'IMAGE (VALUE),
SUCCESS => S);
if not S then
ERROR (H, ASA_REQUIREMENT_KIND_N);
end if;
end SET_ASA_REQUIREMENT_KIND;
procedure SET_ASA_REQUIREMENT_TEXT (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_REQUIREMENT_TEXT_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, ASA_REQUIREMENT_TEXT_N);
end if;
end SET_ASA_REQUIREMENT_TEXT;
procedure SET_ASA_UPDATE_TIME
(H : in GWO.HANDLE; VALUE : in CALENDAR.TIME) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => ASA_UPDATE_TIME_N,
NEW_VALUE => TU.IMAGE (TU.CONVERT_TIME (VALUE)),
SUCCESS => S);
if not S then
ERROR (H, ASA_UPDATE_TIME_N);
end if;
end SET_ASA_UPDATE_TIME;
procedure SET_DATA_CONTEXT (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => DATA_CONTEXT_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, DATA_CONTEXT_N);
end if;
end SET_DATA_CONTEXT;
procedure SET_DATA_HOST (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => DATA_HOST_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, DATA_HOST_N);
end if;
end SET_DATA_HOST;
procedure SET_DATA_NAME (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => DATA_NAME_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, DATA_NAME_N);
end if;
end SET_DATA_NAME;
procedure SET_PARENT_NAME (H : in GWO.HANDLE;
VALUE : in STRING) is
S : BOOLEAN;
begin
GWP.SET_VALUE (H,
PROPERTY_NAME => PARENT_NAME_N,
NEW_VALUE => VALUE,
SUCCESS => S);
if not S then
ERROR (H, PARENT_NAME_N);
end if;
end SET_PARENT_NAME;
end PROPERTIES;
with PARAMETER_PARSER;
with STRING_UTILITIES;
with SWITCH_IMPLEMENTATION;
separate (ASA_DEFINITIONS)
package body SWITCHES is
package SI renames SWITCH_IMPLEMENTATION;
type OPTION_ID is range 0 .. 1;
-- ---------------------------
-- ( ) Action when out-of-date
-- ---------------------------
package ACTION_WHEN_OUT_OF_DATE_FORMALS is
new SI.DISCRETE_SWITCH_FORMALS (ACTION);
function ACTION_WHEN_OUT_OF_DATE_IMAGE
(VALUE : in ACTION) return SI.SWITCH_VALUE_IMAGE is
begin
return STRING_UTILITIES.CAPITALIZE (ACTION'IMAGE (VALUE));
end ACTION_WHEN_OUT_OF_DATE_IMAGE;
function ACTION_WHEN_OUT_OF_DATE return ACTION is
THE_HANDLE : SI.HANDLE;
begin
SI.SWITCH_FILE.OPEN_SESSION_SWITCHES (THE_HANDLE);
declare
VALUE : constant ACTION :=
ACTION'VALUE
(SI.IMAGE (THE_HANDLE,
NAME => ASA & '.' & ACTION_WHEN_OUT_OF_DATE_N));
begin
SI.SWITCH_FILE.CLOSE (THE_HANDLE);
return VALUE;
end;
end ACTION_WHEN_OUT_OF_DATE;
-- -------------------
-- ( ) Bin directories
-- -------------------
package PP is new PARAMETER_PARSER (OPTION_ID => OPTION_ID);
function BIN_DIRECTORY (HOST : in STRING) return STRING is
ITER : PP.ITERATOR;
S : BOOLEAN;
THE_HANDLE : SI.HANDLE;
begin
SI.SWITCH_FILE.OPEN_SESSION_SWITCHES (THE_HANDLE);
PP.DEFINE (OPTION => OPTION_ID'LAST,
NAME => HOST,
KIND => PP.UNSPECIFIED,
DEFAULT_VALUE => "",
ALLOW_NAME_PREFIX => FALSE);
PP.PARSE (PARAMETER =>
SI.VALUE (THE_HANDLE, NAME => ASA & '.' & BIN_DIRECTORIES_N),
OPTIONS => ITER,
SUCCESS => S);
SI.SWITCH_FILE.CLOSE (THE_HANDLE);
return PP.GET_IMAGE (ITER, NAME => OPTION_ID'LAST);
end BIN_DIRECTORY;
-- -----------------
-- ( ) Control level
-- -----------------
package CMVC_CONTROL_LEVEL_FORMALS is
new SI.DISCRETE_SWITCH_FORMALS (CONTROL_LEVEL);
function CMVC_CONTROL_LEVEL_IMAGE
(VALUE : in CONTROL_LEVEL) return SI.SWITCH_VALUE_IMAGE is
begin
return STRING_UTILITIES.CAPITALIZE (CONTROL_LEVEL'IMAGE (VALUE));
end CMVC_CONTROL_LEVEL_IMAGE;
function CMVC_CONTROL_LEVEL return CONTROL_LEVEL is
THE_HANDLE : SI.HANDLE;
begin
SI.SWITCH_FILE.OPEN_SESSION_SWITCHES (THE_HANDLE);
declare
VALUE : constant CONTROL_LEVEL :=
CONTROL_LEVEL'VALUE
(SI.IMAGE (THE_HANDLE,
NAME => ASA & '.' & CMVC_CONTROL_LEVEL_N));
begin
SI.SWITCH_FILE.CLOSE (THE_HANDLE);
return VALUE;
end;
end CMVC_CONTROL_LEVEL;
-- ------------------
-- ( ) Remote display
-- ------------------
function REMOTE_DISPLAY return STRING is
THE_HANDLE : SI.HANDLE;
begin
SI.SWITCH_FILE.OPEN_SESSION_SWITCHES (THE_HANDLE);
declare
VALUE : constant STRING :=
SI.VALUE (THE_HANDLE, NAME => ASA & '.' & REMOTE_DISPLAY_N);
begin
SI.SWITCH_FILE.CLOSE (THE_HANDLE);
return VALUE;
end;
end REMOTE_DISPLAY;
-- -----------------------
-- ( ) Switch registration
-- -----------------------
task body REGISTER is
package ASA_SWITCHES is
new SI.REGISTERED_CLASS (CLASS_NAME => ASA,
ALLOW_REDEFINITION => TRUE);
-- -----------------------------
-- ( . ) Action when out-of-date
-- -----------------------------
function ACTION_WHEN_OUT_OF_DATE_HELP
(NAME : SI.SWITCH_VALUE_NAME;
IMAGE : SI.SWITCH_VALUE_IMAGE) return STRING is
begin
return "One of the literals " & ACTION'IMAGE (ABANDON) &
", " & ACTION'IMAGE (ACCEPT_CHANGES) & " or " &
ACTION'IMAGE (CONTINUE) & ". Specifies what " &
"must be the bevahiour of gateway operations when " &
"the information contained in a gateway is " &
"suspected to be obsolete";
end ACTION_WHEN_OUT_OF_DATE_HELP;
package ASA_GENERIC_ACTION_WHEN_OUT_OF_DATE is
new ASA_SWITCHES.GENERIC_SWITCH
(SWITCH_TYPE => ACTION,
SWITCH_TYPE_ACCESS =>
ACTION_WHEN_OUT_OF_DATE_FORMALS.ACCESS_TYPE,
IMAGE => ACTION_WHEN_OUT_OF_DATE_IMAGE,
VALUE => ACTION_WHEN_OUT_OF_DATE_FORMALS.VALUE,
DIAGNOSIS => ACTION_WHEN_OUT_OF_DATE_FORMALS.DIAGNOSIS,
TYPE_NAME => "Asa_Action",
KIND => SI.GENERIC_VALUE);
package ASA_ACTION_WHEN_OUT_OF_DATE is
new ASA_GENERIC_ACTION_WHEN_OUT_OF_DATE.SWITCH
(CATEGORY => 'S',
SWITCH_NAME => ACTION_WHEN_OUT_OF_DATE_N,
DEFAULT_VALUE => ABANDON,
HELP => ACTION_WHEN_OUT_OF_DATE_HELP,
ASSIGNED => SI.NOT_INTERESTING);
-- ---------------------
-- ( . ) Bin directories
-- ---------------------
function BIN_DIRECTORIES_HELP
(NAME : SI.SWITCH_VALUE_NAME;
IMAGE : SI.SWITCH_VALUE_IMAGE) return STRING is
begin
return "A comma separated list of pairs HOST => PATHNAME " &
"specifying, for each remote host, the directory " &
"holding the ASA executables";
end BIN_DIRECTORIES_HELP;
procedure BIN_DIRECTORIES_ASSIGNED
(FILE : STRING; IMAGE : SI.SWITCH_VALUE_IMAGE) is
begin
null;
--[improve]
-- Should be improved some day to check and normalize the
-- switch value.
--
end BIN_DIRECTORIES_ASSIGNED;
package ASA_BIN_DIRECTORIES is
new ASA_SWITCHES.TEXT_SWITCH (CATEGORY => 'S',
SWITCH_NAME => BIN_DIRECTORIES_N,
DEFAULT_VALUE => "",
HELP => BIN_DIRECTORIES_HELP,
ASSIGNED => BIN_DIRECTORIES_ASSIGNED);
-- ----------------------
-- ( ) CMVC control level
-- ----------------------
function CMVC_CONTROL_LEVEL_HELP
(NAME : SI.SWITCH_VALUE_NAME;
IMAGE : SI.SWITCH_VALUE_IMAGE) return STRING is
begin
return "One of the literals " & CONTROL_LEVEL'IMAGE (CONTROL_NONE) &
", " & CONTROL_LEVEL'IMAGE (CONTROL_MODEL) & ", " &
CONTROL_LEVEL'IMAGE (CONTROL_MODULES) & " or " &
CONTROL_LEVEL'IMAGE (CONTROL_ALL) & ". Specifies what " &
"gateway objects are to be made controlled at creation";
end CMVC_CONTROL_LEVEL_HELP;
package ASA_GENERIC_CMVC_CONTROL_LEVEL is
new ASA_SWITCHES.GENERIC_SWITCH
(SWITCH_TYPE => CONTROL_LEVEL,
SWITCH_TYPE_ACCESS => CMVC_CONTROL_LEVEL_FORMALS.ACCESS_TYPE,
IMAGE => CMVC_CONTROL_LEVEL_IMAGE,
VALUE => CMVC_CONTROL_LEVEL_FORMALS.VALUE,
DIAGNOSIS => CMVC_CONTROL_LEVEL_FORMALS.DIAGNOSIS,
TYPE_NAME => "Asa_Control_Level",
KIND => SI.GENERIC_VALUE);
package ASA_CMVC_CONTROL_LEVEL is
new ASA_GENERIC_CMVC_CONTROL_LEVEL.SWITCH
(CATEGORY => 'S',
SWITCH_NAME => CMVC_CONTROL_LEVEL_N,
DEFAULT_VALUE => CONTROL_NONE,
HELP => CMVC_CONTROL_LEVEL_HELP,
ASSIGNED => SI.NOT_INTERESTING);
-- --------------------
-- ( . ) Remote display
-- --------------------
function REMOTE_DISPLAY_HELP
(NAME : SI.SWITCH_VALUE_NAME;
IMAGE : SI.SWITCH_VALUE_IMAGE) return STRING is
begin
return "Indicate on what X Window display the ASAEDIT editor is " &
"to show its images.";
end REMOTE_DISPLAY_HELP;
package ASA_REMOTE_DISPLAY is
new ASA_SWITCHES.TEXT_SWITCH (CATEGORY => 'S',
SWITCH_NAME => REMOTE_DISPLAY_N,
DEFAULT_VALUE => "",
HELP => REMOTE_DISPLAY_HELP,
ASSIGNED => SI.NOT_INTERESTING);
begin
accept STOP;
end REGISTER;
end SWITCHES;
procedure ASA_INTEGRATION_SERVER (RESPONSE : in STRING := "<PROFILE>");with ASA_DEFINITIONS;
with ACTIONS;
with DEVICE_INDEPENDENT_IO;
with DTIA_CLIENT;
with JOB_MANAGER;
with LOG;
with LOGGER;
with PROFILE;
with SIMPLE_STATUS;
procedure ASA_INTEGRATION_SERVER (RESPONSE : in STRING := "<PROFILE>") is
package DC renames DTIA_CLIENT;
S : SIMPLE_STATUS.CONDITION;
task WAITER is
entry STOP;
end WAITER;
task body WAITER is
begin
accept STOP;
end WAITER;
procedure TERMINATE_MODEL_SERVER (REASON : in DC.TERMINATION_CONDITION) is
begin
ACTIONS.MODEL.TERMINATE_SERVER (REASON);
if REASON = DC.GATEWAY_CLASS_DEACTIVATED then
WAITER.STOP;
end if;
end TERMINATE_MODEL_SERVER;
procedure TERMINATE_NO_SERVER (REASON : in DC.TERMINATION_CONDITION) is
begin
null;
end TERMINATE_NO_SERVER;
package MODEL_REGISTRATION is
new DC.DTIA_CLIENT_OPERATIONS
(CLASS_NAME => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODEL),
SESSION_SERVER => FALSE,
IMAGE_NAME => ACTIONS.MODEL.IMAGE_NAME,
BUILD_IMAGE => ACTIONS.MODEL.BUILD_IMAGE,
PRE_CHECK_IN => ACTIONS.MODEL.PRE_CHECK_IN,
PRE_MAKE_CONTROLLED => ACTIONS.MODEL.PRE_MAKE_CONTROLLED,
PRE_CMVC_COPY => ACTIONS.MODEL.PRE_CMVC_COPY,
POST_CMVC_COPY => ACTIONS.MODEL.POST_CMVC_COPY,
TERMINATE_SERVER => TERMINATE_MODEL_SERVER);
package MODULE_REGISTRATION is
new DC.DTIA_CLIENT_OPERATIONS
(CLASS_NAME => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODULE),
SESSION_SERVER => FALSE,
IMAGE_NAME => ACTIONS.MODULE.IMAGE_NAME,
BUILD_IMAGE => ACTIONS.MODULE.BUILD_IMAGE,
PRE_CHECK_IN => ACTIONS.MODULE.PRE_CHECK_IN,
PRE_MAKE_CONTROLLED => ACTIONS.MODULE.PRE_MAKE_CONTROLLED,
TERMINATE_SERVER => TERMINATE_NO_SERVER);
package REQUIREMENT_REGISTRATION is
new DC.DTIA_CLIENT_OPERATIONS
(CLASS_NAME => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT),
SESSION_SERVER => FALSE,
IMAGE_NAME => ACTIONS.REQUIREMENT.IMAGE_NAME,
BUILD_IMAGE => ACTIONS.REQUIREMENT.BUILD_IMAGE,
POST_COMMIT => ACTIONS.REQUIREMENT.POST_COMMIT,
EDIT => ACTIONS.REQUIREMENT.EDIT,
IO_OPEN => ACTIONS.REQUIREMENT.IO_OPEN,
IO_READ_BYTES => DEVICE_INDEPENDENT_IO.READ,
IO_READ_STRING => DEVICE_INDEPENDENT_IO.READ,
IO_END_OF_FILE => DEVICE_INDEPENDENT_IO.END_OF_FILE,
IO_RESET => DEVICE_INDEPENDENT_IO.RESET,
IO_CLOSE => DEVICE_INDEPENDENT_IO.CLOSE,
TERMINATE_SERVER => TERMINATE_NO_SERVER);
begin
LOG.SET_OUTPUT ("!Machine.Error_Logs.Asa_Integration_Server_Log");
PROFILE.SET (RESPONSE, S);
MODEL_REGISTRATION.CHECK_IF_REGISTRATION_SUCCEEDED (S);
if SIMPLE_STATUS.ERROR (S) then
LOGGER.ERROR ("Unable to register class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODEL) & " because " &
SIMPLE_STATUS.DISPLAY_MESSAGE (S));
else
LOGGER.POSITIVE
("Registration of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (ASA_DEFINITIONS.ASA_MODEL) &
" succeeded");
end if;
MODULE_REGISTRATION.CHECK_IF_REGISTRATION_SUCCEEDED (S);
if SIMPLE_STATUS.ERROR (S) then
LOGGER.ERROR ("Unable to register class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODULE) & " because " &
SIMPLE_STATUS.DISPLAY_MESSAGE (S));
else
LOGGER.POSITIVE
("Registration of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (ASA_DEFINITIONS.ASA_MODULE) &
" succeeded");
end if;
REQUIREMENT_REGISTRATION.CHECK_IF_REGISTRATION_SUCCEEDED (S);
if SIMPLE_STATUS.ERROR (S) then
LOGGER.ERROR ("Unable to register class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT) & " because " &
SIMPLE_STATUS.DISPLAY_MESSAGE (S));
else
LOGGER.POSITIVE ("Registration of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT) & " succeeded");
end if;
JOB_MANAGER.SET_NAME (NAME => ASA_DEFINITIONS.ASA & " Integration Server");
end ASA_INTEGRATION_SERVER;with ACTION;
with CALENDAR;
with HIERARCHY;
with REQUIREMENTS;
pragma PRIVATE_EYES_ONLY;
with CMVC_IMPLEMENTATION;
with STATE_OPERATIONS;
package GATEWAYS is
type CMVC_CONTROL_KIND is (NOT_CONTROLLED,
CONTROLLED_CHECKED_IN,
CONTROLLED_CHECKED_OUT);
function CMVC_CONTROL (GATEWAY_NAME : in STRING) return CMVC_CONTROL_KIND;
type STATE is private;
procedure INITIALIZE (THE_STATE : out STATE;
ACTION_ID : in ACTION.ID;
WORK_ORDER : in STRING);
procedure FINALIZE (THE_STATE : in out STATE);
procedure AUGMENT (FOR_MODULE : in HIERARCHY.MODULE;
IN_LIBRARY : in STRING;
HOST : in STRING;
MODEL : in STRING;
UPDATE_TIME : in CALENDAR.TIME;
COMMENTS : in STRING;
THE_STATE : in out STATE);
procedure CREATE (FOR_MODULE : in HIERARCHY.MODULE;
IN_LIBRARY : in STRING;
HOST : in STRING;
MODEL : in STRING;
UPDATE_TIME : in CALENDAR.TIME;
COMMENTS : in STRING;
THE_STATE : in out STATE);
procedure CREATE (IN_GATEWAY : in STRING;
REQUIREMENT_NAME : in STRING;
REQUIREMENT_KIND : in REQUIREMENTS.NON_FUNCTIONAL;
REQUIREMENT_TEXT : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE);
procedure DESTROY (GATEWAY_NAME : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE);
procedure REDUCE (GATEWAY_NAME : in STRING;
CANDIDATE_MODULES : in out HIERARCHY.MODULE_ITERATOR;
COMMENTS : in STRING;
THE_STATE : in out STATE);
private
type STATE is
record
CMVC : STATE_OPERATIONS.STATE;
CONFIGURATION : CMVC_IMPLEMENTATION.CONFIGURATION;
end record;
end GATEWAYS;with ACTION;
with ASA_DEFINITIONS;
with CALENDAR;
with CMVC_IMPLEMENTATION_ERRORS;
with DATABASE_OPERATIONS;
with DIANA;
with DIRECTORY_OPERATIONS;
with DIRECTORY;
with ERROR_MESSAGES;
with HIERARCHY;
with JOB_SEGMENT;
with LOGGER;
with PROFILE;
with GATEWAY_OBJECT;
with RELOCATION;
with SIMPLE_STATUS;
with STRING_UTILITIES;
with SYSTEM;
with UNIX_DEFINITIONS;
package body GATEWAYS is
package ASAP renames ASA_DEFINITIONS.PROPERTIES;
package ASAS renames ASA_DEFINITIONS.SWITCHES;
package CMVCE renames CMVC_IMPLEMENTATION_ERRORS;
package CMVCI renames CMVC_IMPLEMENTATION;
package DCP renames DIRECTORY.CONTROL_POINT;
package DIR renames DIRECTORY;
package DNA renames DIRECTORY.NAMING;
package DOO renames DIRECTORY.OBJECT_OPERATIONS;
package GWO renames GATEWAY_OBJECT;
package HCHY renames HIERARCHY;
package SS renames SIMPLE_STATUS;
package SU renames STRING_UTILITIES;
package UNIX renames UNIX_DEFINITIONS;
function CREATION_MESSAGE (GATEWAY : in GWO.HANDLE) return STRING is
begin
return "Created gateway object " &
DNA.GET_FULL_NAME (GWO.DIRECTORY_OBJECT (GATEWAY)) &
" of class " &
ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE (ASAP.CLASS (GATEWAY));
end CREATION_MESSAGE;
function SAME_PROPERTIES (MODULE : in HCHY.MODULE; GATEWAY : in GWO.HANDLE)
return BOOLEAN is
SAME_REQUIREMENTS : BOOLEAN := TRUE;
begin
for R in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER loop
if ASAP.ASA_REQUIREMENT (H => GATEWAY, NUMBER => R) /=
HCHY.REQUIREMENT (M => MODULE, NUMBER => R) then
SAME_REQUIREMENTS := FALSE;
exit;
end if;
end loop;
return SAME_REQUIREMENTS and then ASAP.ASA_NODE_NUMBER (GATEWAY) =
HCHY.NODE_NUMBER (MODULE) and then
ASAP.ASA_COMMENT (GATEWAY) = HCHY.COMMENT (MODULE);
end SAME_PROPERTIES;
function TREE_SIZE (ROOTED_AT : in HCHY.MODULE) return POSITIVE is
CHILDREN : HCHY.MODULE_ITERATOR := HCHY.CHILDREN_OF (ROOTED_AT);
RESULT : POSITIVE := 1;
begin
while not HCHY.DONE (CHILDREN) loop
RESULT := RESULT + TREE_SIZE (HCHY.VALUE (CHILDREN));
HCHY.NEXT (CHILDREN);
end loop;
return RESULT;
end TREE_SIZE;
-- ----------------
-- ( ) CMVC support
-- ----------------
function RELATIVE_NAME
(FULL_NAME : in STRING; RELATIVE_TO : in STRING) return STRING is
begin
pragma ASSERT (FULL_NAME'LENGTH >= RELATIVE_TO'LENGTH and then
FULL_NAME (FULL_NAME'FIRST ..
FULL_NAME'FIRST + RELATIVE_TO'LENGTH - 1) =
RELATIVE_TO);
return FULL_NAME
(FULL_NAME'FIRST + RELATIVE_TO'LENGTH + 1 -- Skip the '.'
.. FULL_NAME'LAST);
end RELATIVE_NAME;
procedure GET_CMVC_CONTROL (OBJECT : in DIR.OBJECT;
THE_STATE : in out STATE;
CONTROL : out CMVC_CONTROL_KIND) is
E : DIR.ERROR_STATUS;
N : DNA.NAME_STATUS;
S : CMVCI.ERROR_STATUS;
CONFIGURATION_OBJECT : DIR.OBJECT;
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
THE_CONFIGURATION : CMVCI.CONFIGURATION renames THE_STATE.CONFIGURATION;
THE_ELEMENT : CMVCI.ELEMENT;
THE_VERSION_SET : CMVCI.VERSION_SET;
VIEW_OBJECT : DIR.OBJECT;
use CMVCE;
begin
DCP.PARENT_WORLD (THE_OBJECT => OBJECT,
THE_WORLD => VIEW_OBJECT,
STATUS => E);
LOGGER.STATUS (E);
--
-- Make sure the configuration associated to the current view is
-- open.
--
if CMVCI.IS_NIL (THE_CONFIGURATION) then
DNA.RESOLVE (NAME => DNA.GET_FULL_NAME (VIEW_OBJECT) &
"^$$.Configurations." &
DNA.GET_SIMPLE_NAME (VIEW_OBJECT),
THE_OBJECT => CONFIGURATION_OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
LOGGER.STATUS (N);
THE_CONFIGURATION := DATABASE_OPERATIONS.OPEN_CONFIGURATION
(FOR_CONFIG_OBJECT => CONFIGURATION_OBJECT,
S => THE_STATE.CMVC);
end if;
--
-- Look at the CMVC database to see if the object being operated
-- on is controlled.
--
CMVCI.ELEMENT_OPERATIONS.OPEN
(ELEMENT_NAME =>
RELATIVE_NAME (FULL_NAME => DNA.GET_FULL_NAME (OBJECT),
RELATIVE_TO => DNA.GET_FULL_NAME (VIEW_OBJECT)),
ELEM => THE_ELEMENT,
STATUS => S,
DB => CMVCI.CONFIGURATION_OPERATIONS.DATABASE_OF (THE_CONFIGURATION));
if S = CMVCE.NO_SUCH_ELEMENT then
CONTROL := NOT_CONTROLLED;
return;
elsif CMVCI.IS_BAD (S) then
LOGGER.STATUS (S);
end if;
CMVCI.VERSION_SET_OPERATIONS.OPEN (ELEM => THE_ELEMENT,
SET => THE_VERSION_SET,
STATUS => S,
CONFIG => THE_CONFIGURATION);
if S = CMVCE.ELEMENT_NOT_IN_CONFIGURATION then
CONTROL := NOT_CONTROLLED;
elsif CMVCI.HISTORY_OPERATIONS.IS_CHECKED_OUT (THE_VERSION_SET) then
CONTROL := CONTROLLED_CHECKED_OUT;
else
CONTROL := CONTROLLED_CHECKED_IN;
end if;
end GET_CMVC_CONTROL;
procedure MAKE_CONTROLLED (GATEWAY : in out GWO.HANDLE;
SAVE_SOURCE : in BOOLEAN;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (GATEWAY);
begin
DATABASE_OPERATIONS.CONTROL_PARENT (THE_OBJECT => GATEWAY_OBJECT,
SET => RELOCATION.NULL_PARAMETER,
THE_STATE => THE_STATE.CMVC);
DATABASE_OPERATIONS.CREATE_OR_ADD_ELEMENT
(THE_OBJECT => GATEWAY_OBJECT,
VERSION_SET_NAME => "<AUTO_GENERATE>",
SAVE_SOURCE => SAVE_SOURCE,
COMMENTS => COMMENTS,
COMMAND => "MAKE_CONTROLLED",
THE_STATE => THE_STATE.CMVC);
exception
when CONSTRAINT_ERROR =>
LOGGER.WARNING ("Gateway object " &
DNA.GET_FULL_NAME (GATEWAY_OBJECT) &
" could not be controlled because its parent isn't");
end MAKE_CONTROLLED;
generic
with procedure DO_UPDATE (GATEWAY : in GWO.HANDLE);
procedure UPDATER (GATEWAY : in out GWO.HANDLE;
COMMENTS : in STRING;
THE_STATE : in out STATE);
procedure UPDATER (GATEWAY : in out GWO.HANDLE;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
GATEWAY_OBJECT : constant DIR.OBJECT := GWO.DIRECTORY_OBJECT (GATEWAY);
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
GATEWAY_CMVC_CONTROL : CMVC_CONTROL_KIND;
S : SS.CONDITION;
begin
GET_CMVC_CONTROL (OBJECT => GATEWAY_OBJECT,
THE_STATE => THE_STATE,
CONTROL => GATEWAY_CMVC_CONTROL);
if GATEWAY_CMVC_CONTROL = CONTROLLED_CHECKED_IN then
DATABASE_OPERATIONS.CHECK_OUT
(OBJECTS => DIRECTORY_OPERATIONS.SINGLETON
(GATEWAY_OBJECT, THE_STATE.CMVC),
EXPECTED_CHECK_IN_TIME => CALENDAR.CLOCK,
COMMENTS => COMMENTS,
ALLOW_DEMOTION => FALSE,
ALLOW_ACCEPT_CHANGES => TRUE,
THE_STATE => THE_STATE.CMVC);
end if;
if not GWO.IS_MAIN_OBJECT_OPEN_FOR_UPDATE (GATEWAY) then
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_OBJECT,
H => GATEWAY,
UPDATE => TRUE,
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
end if;
DO_UPDATE (GATEWAY);
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
if GATEWAY_CMVC_CONTROL = CONTROLLED_CHECKED_IN then
DATABASE_OPERATIONS.CHECK_IN (THE_OBJECT => GATEWAY_OBJECT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE.CMVC);
end if;
end UPDATER;
-- -------------------------------
-- ( ) Individual gateway creation
-- -------------------------------
procedure CREATE_MODEL_GATEWAY (GATEWAY_NAME : in STRING;
LAST_ID : in NATURAL;
FOR_MODULE : in HCHY.MODULE;
HOST : in STRING;
MODEL : in STRING;
UPDATE_TIME : in CALENDAR.TIME;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
S : SS.CONDITION;
GATEWAY : GWO.HANDLE;
use ASAS;
begin
GWO.CREATE (NAME => GATEWAY_NAME,
H => GATEWAY,
GATEWAY_CLASS => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODEL),
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
ASAP.SET_ASA_ID (H => GATEWAY,
VALUE => 1);
ASAP.SET_ASA_LAST_ID (H => GATEWAY,
VALUE => LAST_ID);
ASAP.SET_ASA_NODE_NUMBER (H => GATEWAY,
VALUE => HCHY.NODE_NUMBER (FOR_MODULE));
ASAP.SET_ASA_COMMENT (H => GATEWAY,
VALUE => HCHY.COMMENT (FOR_MODULE));
ASAP.SET_ASA_UPDATE_TIME (H => GATEWAY,
VALUE => UPDATE_TIME);
ASAP.SET_DATA_CONTEXT (H => GATEWAY,
VALUE => UNIX.ENCLOSING_DIRECTORY (MODEL));
ASAP.SET_DATA_HOST (H => GATEWAY,
VALUE => HOST);
ASAP.SET_DATA_NAME (H => GATEWAY,
VALUE => UNIX.LOCAL_NAME (MODEL));
for R in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER loop
ASAP.SET_ASA_REQUIREMENT
(H => GATEWAY,
NUMBER => R,
VALUE => HCHY.REQUIREMENT (FOR_MODULE, NUMBER => R));
end loop;
LOGGER.POSITIVE (CREATION_MESSAGE (GATEWAY));
if ASAS.CMVC_CONTROL_LEVEL >= ASAS.CONTROL_MODEL then
MAKE_CONTROLLED (GATEWAY => GATEWAY,
SAVE_SOURCE => FALSE,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end if;
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
end CREATE_MODEL_GATEWAY;
procedure CREATE_MODULE_GATEWAY (GATEWAY_NAME : in STRING;
PARENT_NAME : in STRING;
ID : in POSITIVE;
FOR_MODULE : in HCHY.MODULE;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
S : SS.CONDITION;
GATEWAY : GWO.HANDLE;
use ASAS;
begin
GWO.CREATE (NAME => GATEWAY_NAME,
H => GATEWAY,
GATEWAY_CLASS => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_MODULE),
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
ASAP.SET_ASA_ID (H => GATEWAY,
VALUE => ID);
ASAP.SET_ASA_NODE_NUMBER (H => GATEWAY,
VALUE => HCHY.NODE_NUMBER (FOR_MODULE));
ASAP.SET_ASA_COMMENT (H => GATEWAY,
VALUE => HCHY.COMMENT (FOR_MODULE));
ASAP.SET_PARENT_NAME (H => GATEWAY,
VALUE => PARENT_NAME);
for R in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER loop
ASAP.SET_ASA_REQUIREMENT
(H => GATEWAY,
NUMBER => R,
VALUE => HCHY.REQUIREMENT (FOR_MODULE, NUMBER => R));
end loop;
LOGGER.POSITIVE (CREATION_MESSAGE (GATEWAY));
if ASAS.CMVC_CONTROL_LEVEL >= ASAS.CONTROL_MODULES then
MAKE_CONTROLLED (GATEWAY => GATEWAY,
SAVE_SOURCE => FALSE,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end if;
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
end CREATE_MODULE_GATEWAY;
procedure CREATE_REQUIREMENT_GATEWAY
(GATEWAY_NAME : in STRING;
PARENT_NAME : in STRING;
ID : in POSITIVE;
REQUIREMENT_KIND : in REQUIREMENTS.NON_FUNCTIONAL;
REQUIREMENT_TEXT : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
S : SS.CONDITION;
GATEWAY : GWO.HANDLE;
use ASAS;
begin
GWO.CREATE (NAME => GATEWAY_NAME,
H => GATEWAY,
GATEWAY_CLASS => ASA_DEFINITIONS.GATEWAY_CLASS'IMAGE
(ASA_DEFINITIONS.ASA_REQUIREMENT),
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
ASAP.SET_ASA_ID (H => GATEWAY,
VALUE => ID);
ASAP.SET_PARENT_NAME (H => GATEWAY,
VALUE => PARENT_NAME);
ASAP.SET_ASA_REQUIREMENT_KIND (H => GATEWAY, VALUE => REQUIREMENT_KIND);
ASAP.SET_ASA_REQUIREMENT_TEXT (H => GATEWAY, VALUE => REQUIREMENT_TEXT);
LOGGER.POSITIVE (CREATION_MESSAGE (GATEWAY));
if ASAS.CMVC_CONTROL_LEVEL >= ASAS.CONTROL_ALL then
MAKE_CONTROLLED (GATEWAY => GATEWAY,
SAVE_SOURCE => TRUE,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end if;
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
end CREATE_REQUIREMENT_GATEWAY;
-- --------------------
-- ( ) Module hierarchy
-- --------------------
procedure CREATE (FOR_MODULE : in HCHY.MODULE;
IN_LIBRARY : in STRING;
ROOT_ID : in POSITIVE;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
CHILDREN : HCHY.MODULE_ITERATOR := HCHY.CHILDREN_OF (FOR_MODULE);
CHILD : HCHY.MODULE;
PARENT : constant HCHY.MODULE := HCHY.PARENT_OF (FOR_MODULE);
NB_OF_CHILDREN : constant NATURAL := HCHY.SIZE (CHILDREN);
NEXT_ID : POSITIVE := ROOT_ID + 1;
use HIERARCHY;
begin
CREATE_MODULE_GATEWAY
(GATEWAY_NAME => IN_LIBRARY & '.' & HCHY.FULL_NAME (FOR_MODULE),
PARENT_NAME => IN_LIBRARY & '.' & HCHY.FULL_NAME (PARENT),
ID => ROOT_ID,
FOR_MODULE => FOR_MODULE,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
for C in 1 .. NB_OF_CHILDREN loop
CHILD := HCHY.VALUE (CHILDREN);
CREATE (FOR_MODULE => CHILD,
IN_LIBRARY => IN_LIBRARY,
ROOT_ID => NEXT_ID,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
NEXT_ID := NEXT_ID + TREE_SIZE (CHILD);
HCHY.NEXT (CHILDREN);
end loop;
end CREATE;
procedure AUGMENT (FOR_MODULE : in HIERARCHY.MODULE;
IN_LIBRARY : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
GATEWAY_FULL_NAME : constant STRING :=
IN_LIBRARY & '.' & HCHY.FULL_NAME (FOR_MODULE);
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
CHILDREN : HCHY.MODULE_ITERATOR;
GATEWAY : GWO.HANDLE;
ROOT_GATEWAY : GWO.HANDLE;
ROOT_MODULE : HCHY.MODULE;
ID : POSITIVE;
S : SS.CONDITION;
procedure DO_SET_PROPERTIES (GATEWAY : in GWO.HANDLE) is
begin
ASAP.SET_ASA_NODE_NUMBER (GATEWAY,
VALUE => HCHY.NODE_NUMBER (FOR_MODULE));
ASAP.SET_ASA_COMMENT (GATEWAY, VALUE => HCHY.COMMENT (FOR_MODULE));
for R in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER loop
ASAP.SET_ASA_REQUIREMENT
(H => GATEWAY,
NUMBER => R,
VALUE => HCHY.REQUIREMENT (FOR_MODULE, NUMBER => R));
end loop;
LOGGER.POSITIVE ("Updated properties of " & IN_LIBRARY &
'.' & HCHY.FULL_NAME (FOR_MODULE));
end DO_SET_PROPERTIES;
procedure SET_PROPERTIES is new UPDATER (DO_SET_PROPERTIES);
procedure DO_SET_LAST_ID (GATEWAY : in GWO.HANDLE) is
begin
ID := ASAP.ASA_LAST_ID (GATEWAY) + 1;
ASAP.SET_ASA_LAST_ID (H => GATEWAY, VALUE => ID);
end DO_SET_LAST_ID;
procedure SET_LAST_ID is new UPDATER (DO_SET_LAST_ID);
use HCHY;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_FULL_NAME,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
--
-- This is a new module. Create a gateway object to represent
-- it. Extract the id from the root and update the last id.
--
ROOT_MODULE := FOR_MODULE;
while HCHY.PARENT_OF (ROOT_MODULE) /= HCHY.NIL loop
ROOT_MODULE := HCHY.PARENT_OF (ROOT_MODULE);
end loop;
declare
ROOT_FULL_NAME : constant STRING :=
IN_LIBRARY & '.' & HCHY.FULL_NAME (ROOT_MODULE);
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => ROOT_FULL_NAME,
H => ROOT_GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
SET_LAST_ID (GATEWAY => ROOT_GATEWAY,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GWO.CLOSE (ROOT_GATEWAY, S);
LOGGER.STATUS (S);
CREATE (FOR_MODULE => FOR_MODULE,
IN_LIBRARY => IN_LIBRARY,
ROOT_ID => ID,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end;
elsif not SAME_PROPERTIES (MODULE => FOR_MODULE,
GATEWAY => GATEWAY) then
--
-- There is already a gateway object representing this module,
-- but same property has changed.
--
SET_PROPERTIES (GATEWAY => GATEWAY,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
else
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
end if;
CHILDREN := HCHY.CHILDREN_OF (FOR_MODULE);
while not HCHY.DONE (CHILDREN) loop
AUGMENT (FOR_MODULE => HCHY.VALUE (CHILDREN),
IN_LIBRARY => IN_LIBRARY,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
HCHY.NEXT (CHILDREN);
end loop;
end AUGMENT;
procedure DESTROY (GATEWAY_OBJECT : in DIR.OBJECT;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
CHANGE_IMPACT : DIR.ADA.ROOTS;
E : DIR.ERROR_STATUS;
ERRORS : ERROR_MESSAGES.ERRORS;
GATEWAY_CMVC_CONTROL : CMVC_CONTROL_KIND;
MODIFIED_UNITS : DIANA.TEMP_SEQ;
begin
GET_CMVC_CONTROL (OBJECT => GATEWAY_OBJECT,
THE_STATE => THE_STATE,
CONTROL => GATEWAY_CMVC_CONTROL);
if GATEWAY_CMVC_CONTROL >= CONTROLLED_CHECKED_OUT then
DATABASE_OPERATIONS.CHECK_IN (THE_OBJECT => GATEWAY_OBJECT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE.CMVC);
end if;
if GATEWAY_CMVC_CONTROL >= CONTROLLED_CHECKED_IN then
DATABASE_OPERATIONS.MAKE_UNCONTROLLED (THE_OBJECT => GATEWAY_OBJECT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE.CMVC);
end if;
DOO.DESTROY (THE_OBJECT => GATEWAY_OBJECT,
ERRORS => ERRORS,
CHANGE_IMPACT => CHANGE_IMPACT,
MODIFIED_UNITS => MODIFIED_UNITS,
STATUS => E,
LIMIT_TYPE => DIR.ANY_OBJECT,
ACTION_ID => ACTION_ID);
LOGGER.STATUS (E);
end DESTROY;
procedure REDUCE (GATEWAY_OBJECT : in DIR.OBJECT;
CANDIDATE_MODULES : in out HIERARCHY.MODULE_ITERATOR;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
HEAP : SYSTEM.SEGMENT renames THE_STATE.CMVC.HEAP;
E : DIR.ERROR_STATUS;
N : DNA.NAME_STATUS;
CANDIDATE_CHILDREN : HCHY.MODULE_ITERATOR;
CANDIDATE_MODULE : HCHY.MODULE;
GATEWAY_CHILD : DIR.OBJECT;
GATEWAY_CHILDREN : DNA.ITERATOR;
GATEWAY_OBJECT_FULL_NAME : constant STRING :=
DNA.GET_FULL_NAME (GATEWAY_OBJECT);
GATEWAY_OBJECT_SIMPLE_NAME : constant STRING :=
DNA.GET_SIMPLE_NAME (GATEWAY_OBJECT);
MUST_REMAIN : BOOLEAN;
use DNA;
begin
MUST_REMAIN := FALSE;
while not HCHY.DONE (CANDIDATE_MODULES) loop
CANDIDATE_MODULE := HCHY.VALUE (CANDIDATE_MODULES);
if SU.EQUAL (GATEWAY_OBJECT_SIMPLE_NAME,
HCHY.SIMPLE_NAME (CANDIDATE_MODULE)) then
MUST_REMAIN := TRUE;
exit;
end if;
HCHY.NEXT (CANDIDATE_MODULES);
end loop;
if MUST_REMAIN then
--
-- There is a module for this gateway object, so it must be
-- kept.
--
LOGGER.NOTE ("Gateway " & GATEWAY_OBJECT_FULL_NAME &
" corresponds to module " &
HCHY.FULL_NAME (CANDIDATE_MODULE));
DNA.RESOLVE (ITER => GATEWAY_CHILDREN,
SOURCE => GATEWAY_OBJECT_FULL_NAME & ".@'C(~Text)",
STATUS => N,
HEAP => HEAP,
ACTION_ID => ACTION_ID);
if N /= DNA.UNDEFINED then
LOGGER.STATUS (N);
while not DNA.DONE (GATEWAY_CHILDREN) loop
CANDIDATE_CHILDREN := HCHY.CHILDREN_OF (CANDIDATE_MODULE);
DNA.GET_OBJECT (ITER => GATEWAY_CHILDREN,
THE_OBJECT => GATEWAY_CHILD,
STATUS => E);
LOGGER.STATUS (E);
REDUCE (GATEWAY_OBJECT => GATEWAY_CHILD,
CANDIDATE_MODULES => CANDIDATE_CHILDREN,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
DNA.NEXT (GATEWAY_CHILDREN);
end loop;
end if;
else
--
-- There is no longer a corresponding module for this gateway
-- object. We first check that the object has no
-- non-functional requirements, and then delete it.
--
DNA.RESOLVE (ITER => GATEWAY_CHILDREN,
SOURCE => GATEWAY_OBJECT_FULL_NAME & ".@'C(Text)",
STATUS => N,
HEAP => HEAP,
ACTION_ID => ACTION_ID);
if N = DNA.UNDEFINED then
DESTROY (GATEWAY_OBJECT => GATEWAY_OBJECT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
LOGGER.POSITIVE ("Gateway object " & GATEWAY_OBJECT_FULL_NAME &
" has been destroyed because it has no longer " &
"a corresponding module");
else
LOGGER.WARNING ("The gateway object " & GATEWAY_OBJECT_FULL_NAME &
" couldn't be destroyed because it has " &
"subobjects representing non-functional " &
"requirements. Use Asa.Move_Requirement " &
"to move these objects, and then run " &
"Asa.Accept_Changes again to complete " &
"change propagation");
end if;
end if;
end REDUCE;
-- ----------------------------------
-- ( ) Bodies of external subprograms
-- ----------------------------------
function CMVC_CONTROL (GATEWAY_NAME : in STRING) return CMVC_CONTROL_KIND is
GATEWAY_OBJECT : DIR.OBJECT;
GATEWAY_CMVC_CONTROL : CMVC_CONTROL_KIND;
N : DNA.NAME_STATUS;
THE_ACTION : ACTION.ID;
THE_STATE : STATE;
begin
THE_ACTION := ACTION.START;
INITIALIZE (THE_STATE => THE_STATE,
ACTION_ID => THE_ACTION,
WORK_ORDER => "");
DNA.RESOLVE (NAME => GATEWAY_NAME,
THE_OBJECT => GATEWAY_OBJECT,
STATUS => N,
ACTION_ID => THE_ACTION);
LOGGER.STATUS (N);
GET_CMVC_CONTROL (OBJECT => GATEWAY_OBJECT,
THE_STATE => THE_STATE,
CONTROL => GATEWAY_CMVC_CONTROL);
FINALIZE (THE_STATE);
ACTION.FINISH (THE_ACTION => THE_ACTION, DO_COMMIT => TRUE);
return GATEWAY_CMVC_CONTROL;
end CMVC_CONTROL;
procedure INITIALIZE (THE_STATE : out STATE;
ACTION_ID : in ACTION.ID;
WORK_ORDER : in STRING) is
RESULT : STATE;
THE_FILTER : PROFILE.LOG_FILTER := PROFILE.FILTER;
THE_HEAP : constant SYSTEM.SEGMENT := JOB_SEGMENT.GET;
begin
THE_FILTER (PROFILE.AUXILIARY_MSG) := FALSE;
RESULT := (CMVC => new STATE_OPERATIONS.STATE_RECORD,
CONFIGURATION => CMVCI.NIL);
pragma HEAP (THE_HEAP);
RESULT.CMVC.ACTION_ID := ACTION_ID;
RESULT.CMVC.HEAP := THE_HEAP;
RESULT.CMVC.CURRENT_PROFILE :=
PROFILE.RAISE_EXCEPTION (FILTER => THE_FILTER);
STATE_OPERATIONS.OBJECT_TO_DATABASE.INITIALIZE
(RESULT.CMVC.DATABASE_MAP, THE_HEAP);
STATE_OPERATIONS.OBJECT_TO_STRING.INITIALIZE
(RESULT.CMVC.STRING_MAP, THE_HEAP);
--[should open work-order]
THE_STATE := RESULT;
end INITIALIZE;
procedure FINALIZE (THE_STATE : in out STATE) is
begin
DATABASE_OPERATIONS.CLOSE (THE_STATE.CMVC);
end FINALIZE;
procedure AUGMENT (FOR_MODULE : in HIERARCHY.MODULE;
IN_LIBRARY : in STRING;
HOST : in STRING;
MODEL : in STRING;
UPDATE_TIME : in CALENDAR.TIME;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
GATEWAY_FULL_NAME : constant STRING :=
IN_LIBRARY & '.' & HCHY.FULL_NAME (FOR_MODULE);
S : SS.CONDITION;
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
CHILDREN : HCHY.MODULE_ITERATOR;
GATEWAY : GWO.HANDLE;
procedure DO_SET_UPDATE_TIME_AND_PROPERTIES (GATEWAY : in GWO.HANDLE) is
begin
ASAP.SET_ASA_UPDATE_TIME (GATEWAY, VALUE => UPDATE_TIME);
if not SAME_PROPERTIES (MODULE => FOR_MODULE, GATEWAY => GATEWAY) then
ASAP.SET_ASA_NODE_NUMBER (GATEWAY,
VALUE => HCHY.NODE_NUMBER (FOR_MODULE));
ASAP.SET_ASA_COMMENT (GATEWAY, VALUE => HCHY.COMMENT (FOR_MODULE));
for R in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER loop
ASAP.SET_ASA_REQUIREMENT
(H => GATEWAY,
NUMBER => R,
VALUE => HCHY.REQUIREMENT (FOR_MODULE, NUMBER => R));
end loop;
LOGGER.POSITIVE ("Updated properties of " & IN_LIBRARY &
'.' & HCHY.FULL_NAME (FOR_MODULE));
end if;
end DO_SET_UPDATE_TIME_AND_PROPERTIES;
procedure SET_UPDATE_TIME_AND_PROPERTIES is
new UPDATER (DO_SET_UPDATE_TIME_AND_PROPERTIES);
use HCHY;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_FULL_NAME,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
--
-- This is a new model. Create a gateway object to represent
-- it.
--
CREATE (FOR_MODULE => FOR_MODULE,
IN_LIBRARY => IN_LIBRARY,
HOST => HOST,
MODEL => MODEL,
UPDATE_TIME => UPDATE_TIME,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
else
SET_UPDATE_TIME_AND_PROPERTIES (GATEWAY => GATEWAY,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GWO.CLOSE (GATEWAY, S);
LOGGER.STATUS (S);
end if;
CHILDREN := HCHY.CHILDREN_OF (FOR_MODULE);
while not HCHY.DONE (CHILDREN) loop
AUGMENT (FOR_MODULE => HCHY.VALUE (M => CHILDREN),
IN_LIBRARY => IN_LIBRARY,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
HCHY.NEXT (CHILDREN);
end loop;
end AUGMENT;
procedure CREATE (FOR_MODULE : in HIERARCHY.MODULE;
IN_LIBRARY : in STRING;
HOST : in STRING;
MODEL : in STRING;
UPDATE_TIME : in CALENDAR.TIME;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
CHILDREN : HCHY.MODULE_ITERATOR := HCHY.CHILDREN_OF (FOR_MODULE);
CHILD : HCHY.MODULE;
NEXT_ID : POSITIVE;
SIZE : constant POSITIVE := TREE_SIZE (FOR_MODULE);
use HIERARCHY;
begin
CREATE_MODEL_GATEWAY
(GATEWAY_NAME => IN_LIBRARY & '.' & HCHY.FULL_NAME (FOR_MODULE),
LAST_ID => SIZE,
FOR_MODULE => FOR_MODULE,
HOST => HOST,
MODEL => MODEL,
UPDATE_TIME => UPDATE_TIME,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
NEXT_ID := 2;
for C in 1 .. HCHY.SIZE (CHILDREN) loop
CHILD := HCHY.VALUE (CHILDREN);
CREATE (FOR_MODULE => HCHY.VALUE (CHILDREN),
IN_LIBRARY => IN_LIBRARY,
ROOT_ID => NEXT_ID,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
NEXT_ID := NEXT_ID + TREE_SIZE (CHILD);
HCHY.NEXT (CHILDREN);
end loop;
end CREATE;
procedure CREATE (IN_GATEWAY : in STRING;
REQUIREMENT_NAME : in STRING;
REQUIREMENT_KIND : in REQUIREMENTS.NON_FUNCTIONAL;
REQUIREMENT_TEXT : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
ID : POSITIVE;
N : DNA.NAME_STATUS;
PARENT : GWO.HANDLE;
PARENT_OBJECT : DIR.OBJECT;
S : SS.CONDITION;
procedure DO_SET_LAST_REQUIREMENT_ID (GATEWAY : in GWO.HANDLE) is
begin
ID := ASAP.ASA_LAST_REQUIREMENT_ID (GATEWAY) + 1;
ASAP.SET_ASA_LAST_REQUIREMENT_ID (H => GATEWAY, VALUE => ID);
end DO_SET_LAST_REQUIREMENT_ID;
procedure SET_LAST_REQUIREMENT_ID is
new UPDATER (DO_SET_LAST_REQUIREMENT_ID);
use ASA_DEFINITIONS;
begin
DNA.RESOLVE (NAME => IN_GATEWAY,
THE_OBJECT => PARENT_OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
LOGGER.STATUS (N);
GWO.OPEN_MAIN_OBJECT (OBJECT => PARENT_OBJECT,
H => PARENT,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
LOGGER.STATUS (S);
if ASAP.CLASS (PARENT) = ASA_DEFINITIONS.ASA_REQUIREMENT then
LOGGER.ERROR ("The gateway object " &
DNA.GET_FULL_NAME (PARENT_OBJECT) &
" does not represent an " &
ASA_DEFINITIONS.ASA & " module, and thus " &
"cannot host non-functional requirements");
end if;
SET_LAST_REQUIREMENT_ID (GATEWAY => PARENT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
GWO.CLOSE (PARENT, S);
LOGGER.STATUS (S);
declare
PARENT_FULL_NAME : constant STRING :=
DNA.GET_FULL_NAME (PARENT_OBJECT);
begin
CREATE_REQUIREMENT_GATEWAY
(GATEWAY_NAME => PARENT_FULL_NAME & '.' & REQUIREMENT_NAME,
PARENT_NAME => PARENT_FULL_NAME,
ID => ID,
REQUIREMENT_KIND => REQUIREMENT_KIND,
REQUIREMENT_TEXT => REQUIREMENT_TEXT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end;
end CREATE;
procedure DESTROY (GATEWAY_NAME : in STRING;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
N : DNA.NAME_STATUS;
GATEWAY_OBJECT : DIR.OBJECT;
begin
DNA.RESOLVE (NAME => GATEWAY_NAME,
THE_OBJECT => GATEWAY_OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
LOGGER.STATUS (N);
DESTROY (GATEWAY_OBJECT => GATEWAY_OBJECT,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end DESTROY;
procedure REDUCE (GATEWAY_NAME : in STRING;
CANDIDATE_MODULES : in out HIERARCHY.MODULE_ITERATOR;
COMMENTS : in STRING;
THE_STATE : in out STATE) is
ACTION_ID : ACTION.ID renames THE_STATE.CMVC.ACTION_ID;
N : DNA.NAME_STATUS;
GATEWAY_OBJECT : DIR.OBJECT;
begin
DNA.RESOLVE (NAME => GATEWAY_NAME,
THE_OBJECT => GATEWAY_OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
LOGGER.STATUS (N);
REDUCE (GATEWAY_OBJECT => GATEWAY_OBJECT,
CANDIDATE_MODULES => CANDIDATE_MODULES,
COMMENTS => COMMENTS,
THE_STATE => THE_STATE);
end REDUCE;
end GATEWAYS;with CALENDAR;
with REQUIREMENTS;
with REMOTE_OPERATIONS;
package HIERARCHY is
type MODULE is private;
NIL : constant MODULE;
type MODULE_ITERATOR is private;
procedure BUILD (MODEL : in STRING;
HOST : in STRING;
ROOT : out MODULE;
BUILD_TIME : out CALENDAR.TIME);
procedure BUILD (MODEL : in STRING;
IN_CONTEXT : in REMOTE_OPERATIONS.CONTEXT;
ROOT : out MODULE;
BUILD_TIME : out CALENDAR.TIME);
function MAKE (IDENTIFIER : in STRING) return MODULE;
function CHILDREN_OF (M : in MODULE) return MODULE_ITERATOR;
function PARENT_OF (M : in MODULE) return MODULE;
function IDENTIFIER (M : in MODULE) return STRING;
function SIMPLE_NAME (M : in MODULE) return STRING;
function FULL_NAME (M : in MODULE) return STRING;
function NODE_NUMBER (M : in MODULE) return STRING;
function COMMENT (M : in MODULE) return STRING;
function REQUIREMENT (M : in MODULE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING;
function DONE (M : in MODULE_ITERATOR) return BOOLEAN;
function VALUE (M : in MODULE_ITERATOR) return MODULE;
procedure NEXT (M : in out MODULE_ITERATOR);
function SIZE (M : in MODULE_ITERATOR) return NATURAL;
function MAKE (M : in MODULE) return MODULE_ITERATOR;
private
type ACCESS_STRING is access STRING;
pragma SEGMENTED_HEAP (ACCESS_STRING);
type REQUIREMENT_LIST is
array (REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER) of ACCESS_STRING;
type MODULE_RECORD is
record
IDENTIFIER : ACCESS_STRING;
NODE_NUMBER : ACCESS_STRING;
COMMENT : ACCESS_STRING;
REQUIREMENTS : REQUIREMENT_LIST;
PARENT : MODULE;
FIRST_CHILD : MODULE;
NEXT_SIBLING : MODULE;
REMAINING_CHILDREN : NATURAL; -- Used for construction only.
end record;
type MODULE is access MODULE_RECORD;
pragma SEGMENTED_HEAP (MODULE);
NIL : constant MODULE := null;
type MODULE_ITERATOR is new MODULE;
end HIERARCHY;with ASA_DEFINITIONS;
with ASAOPEN;
with JOB_SEGMENT;
with LOGGER;
with REMOTE_OPERATIONS;
with SIMPLE_STATUS;
with TIME_UTILITIES;
with UNIX_DEFINITIONS;
package body HIERARCHY is
package RO renames REMOTE_OPERATIONS;
package SS renames SIMPLE_STATUS;
-- ----------
-- ( ) Naming
-- ----------
HIERARCHY : constant STRING :=
ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".HIERARCHY";
function ADA_NAME (S : in STRING) return STRING is
OFFSET : constant := CHARACTER'POS ('A') - CHARACTER'POS ('a');
RESULT : STRING (S'RANGE);
NEXT : NATURAL := S'FIRST;
begin
for I in S'RANGE loop
case S (I) is
when 'A' .. 'Z' =>
RESULT (NEXT) := S (I);
NEXT := NEXT + 1;
when 'a' .. 'z' =>
RESULT (NEXT) := CHARACTER'VAL (CHARACTER'POS (S (I)) + OFFSET);
NEXT := NEXT + 1;
when '0' .. '9' =>
if NEXT = S'FIRST then
-- An Ada name cannot start with a digit.
null;
else
RESULT (NEXT) := S (I);
NEXT := NEXT + 1;
end if;
when others =>
if NEXT = S'FIRST then
-- An Ada name cannot start with an underscore.
null;
elsif RESULT (NEXT - 1) = '_' then
-- An Ada name cannot have two consecutive
-- underscores.
null;
else
RESULT (NEXT) := '_';
NEXT := NEXT + 1;
end if;
end case;
end loop;
if NEXT > S'FIRST and then RESULT (NEXT - 1) = '_' then
-- An Ada name cannot end with an underscore.
return RESULT (S'FIRST .. NEXT - 2);
else
return RESULT (S'FIRST .. NEXT - 1);
end if;
end ADA_NAME;
--[bug]
-- Due to a bug in asaopen, the requirements arrive here with
-- underscores instead of blanks. They must be converted back.
--
function UNDERLINES_TO_SPACES (S : in STRING) return STRING is
RESULT : STRING (S'RANGE);
begin
for I in S'RANGE loop
if S (I) = '_' then
RESULT (I) := ' ';
else
RESULT (I) := S (I);
end if;
end loop;
return RESULT;
end UNDERLINES_TO_SPACES;
-- ----------------------------------
-- ( ) Bodies of external subprograms
-- ----------------------------------
procedure BUILD (MODEL : in STRING;
HOST : in STRING;
ROOT : out MODULE;
BUILD_TIME : out CALENDAR.TIME) is
C : RO.CONTEXT;
S : SIMPLE_STATUS.CONDITION;
begin
--
-- Acquire a connection.
--
RO.ACQUIRE (A_CONTEXT => C,
STATUS => S,
MACHINE => HOST,
INSTANCE => ASA_DEFINITIONS.ASA);
LOGGER.STATUS (S);
--
-- Do the actual build.
--
BUILD (MODEL => MODEL,
IN_CONTEXT => C,
ROOT => ROOT,
BUILD_TIME => BUILD_TIME);
--
-- Release the connection.
--
RO.RELEASE (A_CONTEXT => C, STATUS => S);
LOGGER.STATUS (S);
end BUILD;
procedure BUILD (MODEL : in STRING;
IN_CONTEXT : in REMOTE_OPERATIONS.CONTEXT;
ROOT : out MODULE;
BUILD_TIME : out CALENDAR.TIME) is
S : SS.CONDITION;
type LINE_KIND is (IDENTIFIER,
NODE,
COMMENT,
REQUIREMENT_1,
REQUIREMENT_2,
REQUIREMENT_3,
REQUIREMENT_4,
REQUIREMENT_5,
REQUIREMENT_6,
REQUIREMENT_7,
REQUIREMENT_8,
REQUIREMENT_9,
CHILDREN);
type STATE_RECORD is
record
CURRENT : MODULE;
EXPECTED : LINE_KIND;
end record;
MY_STATE : STATE_RECORD := (CURRENT => null,
EXPECTED => IDENTIFIER);
procedure PROCESS (STATE : in out STATE_RECORD; LINE : in STRING) is
NEW_MODULE : MODULE;
NB_OF_CHILDREN : NATURAL;
begin
case STATE.EXPECTED is
when IDENTIFIER =>
if STATE.CURRENT /= null then
NEW_MODULE := new MODULE_RECORD'(IDENTIFIER =>
new STRING'(LINE),
NODE_NUMBER => null,
COMMENT => null,
REQUIREMENTS =>
(others => null),
PARENT => STATE.CURRENT,
FIRST_CHILD => null,
NEXT_SIBLING =>
STATE.CURRENT.FIRST_CHILD,
REMAINING_CHILDREN => 0);
pragma HEAP (JOB_SEGMENT.GET);
STATE.CURRENT.REMAINING_CHILDREN :=
STATE.CURRENT.REMAINING_CHILDREN - 1;
STATE.CURRENT.FIRST_CHILD := NEW_MODULE;
STATE.CURRENT := NEW_MODULE;
else
STATE.CURRENT :=
new MODULE_RECORD'(IDENTIFIER => new STRING'(LINE),
NODE_NUMBER => null,
COMMENT => null,
REQUIREMENTS => (others => null),
PARENT => null,
FIRST_CHILD => null,
NEXT_SIBLING => null,
REMAINING_CHILDREN => 0);
pragma HEAP (JOB_SEGMENT.GET);
end if;
when NODE =>
STATE.CURRENT.NODE_NUMBER := new STRING'(LINE);
pragma HEAP (JOB_SEGMENT.GET);
when COMMENT =>
--
-- Asaopen says "(null)" if there is no comment.
--
if LINE = "(null)" then
STATE.CURRENT.COMMENT := new STRING'("");
pragma HEAP (JOB_SEGMENT.GET);
else
STATE.CURRENT.COMMENT := new STRING'(LINE);
pragma HEAP (JOB_SEGMENT.GET);
end if;
when REQUIREMENT_1 .. REQUIREMENT_9 =>
if LINE /= "" then
STATE.CURRENT.REQUIREMENTS
(REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER
(LINE_KIND'POS (STATE.EXPECTED) -
LINE_KIND'POS (LINE_KIND'PRED (REQUIREMENT_1)))) :=
new STRING'(UNDERLINES_TO_SPACES (LINE));
pragma HEAP (JOB_SEGMENT.GET);
end if;
when CHILDREN =>
NB_OF_CHILDREN := NATURAL'VALUE (LINE);
case NB_OF_CHILDREN is
when 0 =>
while STATE.CURRENT.REMAINING_CHILDREN = 0 and then
STATE.CURRENT.PARENT /= null loop
STATE.CURRENT := STATE.CURRENT.PARENT;
end loop;
when POSITIVE =>
STATE.CURRENT.REMAINING_CHILDREN := NB_OF_CHILDREN;
end case;
end case;
if STATE.EXPECTED = LINE_KIND'LAST then
STATE.EXPECTED := LINE_KIND'FIRST;
else
STATE.EXPECTED := LINE_KIND'SUCC (STATE.EXPECTED);
end if;
end PROCESS;
procedure EXECUTE_SCRIPT is
new ASAOPEN.EXECUTE (STATE_RECORD => STATE_RECORD, PROCESS => PROCESS);
begin
--
-- Get the remote model's update time.
--
RO.UPDATE_TIME (OF_FILE => MODEL,
IN_CONTEXT => IN_CONTEXT,
RESULT => BUILD_TIME,
STATUS => S);
if SS.ERROR (S) then
LOGGER.ERROR ("Unable to open remote model " & MODEL,
RAISE_ERROR => FALSE);
LOGGER.STATUS (S);
end if;
--
-- Execute the script to extract the hierarchy information.
--
EXECUTE_SCRIPT (IN_CONTEXT => IN_CONTEXT,
MODEL => MODEL,
TEMPLATE_NAME => HIERARCHY,
STATE => MY_STATE,
STATUS => S);
LOGGER.STATUS (S);
ROOT := MY_STATE.CURRENT;
end BUILD;
function MAKE (IDENTIFIER : in STRING) return MODULE is
begin
return new MODULE_RECORD'(IDENTIFIER => new STRING'(IDENTIFIER),
NODE_NUMBER => new STRING'("M"),
COMMENT => new STRING'(""),
REQUIREMENTS => (others => null),
PARENT => null,
FIRST_CHILD => null,
NEXT_SIBLING => null,
REMAINING_CHILDREN => 0);
pragma HEAP (JOB_SEGMENT.GET);
end MAKE;
function CHILDREN_OF (M : in MODULE) return MODULE_ITERATOR is
begin
return MODULE_ITERATOR (M.FIRST_CHILD);
end CHILDREN_OF;
function PARENT_OF (M : in MODULE) return MODULE is
begin
return M.PARENT;
end PARENT_OF;
function IDENTIFIER (M : in MODULE) return STRING is
begin
return M.IDENTIFIER.all;
end IDENTIFIER;
function SIMPLE_NAME (M : in MODULE) return STRING is
begin
return ADA_NAME (M.IDENTIFIER.all);
end SIMPLE_NAME;
function FULL_NAME (M : in MODULE) return STRING is
begin
if M.PARENT = null then
return ADA_NAME (M.IDENTIFIER.all);
else
return FULL_NAME (M.PARENT) & '.' & ADA_NAME (M.IDENTIFIER.all);
end if;
end FULL_NAME;
function NODE_NUMBER (M : in MODULE) return STRING is
begin
return M.NODE_NUMBER.all;
end NODE_NUMBER;
function COMMENT (M : in MODULE) return STRING is
begin
return M.COMMENT.all;
end COMMENT;
function REQUIREMENT (M : in MODULE;
NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
return STRING is
begin
if M.REQUIREMENTS (NUMBER) = null then
return "";
else
return M.REQUIREMENTS (NUMBER).all;
end if;
end REQUIREMENT;
function DONE (M : in MODULE_ITERATOR) return BOOLEAN is
begin
return M = null;
end DONE;
function VALUE (M : in MODULE_ITERATOR) return MODULE is
begin
return MODULE (M);
end VALUE;
procedure NEXT (M : in out MODULE_ITERATOR) is
begin
M := MODULE_ITERATOR (M.NEXT_SIBLING);
end NEXT;
function SIZE (M : in MODULE_ITERATOR) return NATURAL is
ITER : MODULE_ITERATOR := M;
RESULT : NATURAL := 0;
begin
while ITER /= null loop
RESULT := RESULT + 1;
ITER := MODULE_ITERATOR (ITER.NEXT_SIBLING);
end loop;
return RESULT;
end SIZE;
function MAKE (M : in MODULE) return MODULE_ITERATOR is
begin
return MODULE_ITERATOR (M);
end MAKE;
end HIERARCHY;with CMVC_IMPLEMENTATION_ERRORS;
with DIRECTORY;
with SIMPLE_STATUS;
package LOGGER is
procedure STATUS (S : in SIMPLE_STATUS.CONDITION;
INTERACTIVE : in BOOLEAN := FALSE);
procedure STATUS (S : in DIRECTORY.ERROR_STATUS);
procedure STATUS (S : in DIRECTORY.NAMING.NAME_STATUS);
subtype CMVC_STATUS is CMVC_IMPLEMENTATION_ERRORS.STATUS;
procedure STATUS (S : in CMVC_STATUS);
procedure AUXILIARY (MESSAGE : in STRING);
procedure DEBUG (MESSAGE : in STRING);
procedure NEGATIVE (MESSAGE : in STRING;
RAISE_ERROR : in BOOLEAN := TRUE);
procedure ERROR (MESSAGE : in STRING;
RAISE_ERROR : in BOOLEAN := TRUE);
procedure NOTE (MESSAGE : in STRING);
procedure POSITION (MESSAGE : in STRING);
procedure POSITIVE (MESSAGE : in STRING);
procedure WARNING (MESSAGE : in STRING);
end LOGGER;with LOG;
with PROFILE;
package body LOGGER is
package CMVCE renames CMVC_IMPLEMENTATION_ERRORS;
package DIR renames DIRECTORY;
function FORMAT (S : in STRING) return STRING is
OFFSET : constant := CHARACTER'POS ('a') - CHARACTER'POS ('A');
RESULT : STRING (S'RANGE);
begin
for I in S'RANGE loop
case S (I) is
when 'A' .. 'Z' =>
RESULT (I) := CHARACTER'VAL (CHARACTER'POS (S (I)) + OFFSET);
when '_' =>
RESULT (I) := ' ';
when others =>
RESULT (I) := S (I);
end case;
end loop;
return RESULT;
end FORMAT;
function STRIP (S : in STRING) return STRING is
RESULT : STRING (S'RANGE) := S;
begin
for I in S'RANGE loop
if S (I) not in ' ' .. '~' then
RESULT (I) := ' ';
end if;
end loop;
return RESULT;
end STRIP;
procedure STATUS (S : in SIMPLE_STATUS.CONDITION;
INTERACTIVE : in BOOLEAN := FALSE) is
begin
case SIMPLE_STATUS.SEVERITY (S) is
when SIMPLE_STATUS.NORMAL =>
null;
when SIMPLE_STATUS.WARNING =>
if INTERACTIVE then
DEBUG (SIMPLE_STATUS.DISPLAY_MESSAGE (S));
else
WARNING (SIMPLE_STATUS.DISPLAY_MESSAGE (S));
end if;
when SIMPLE_STATUS.PROBLEM =>
NEGATIVE (SIMPLE_STATUS.DISPLAY_MESSAGE (S));
when SIMPLE_STATUS.FATAL =>
ERROR (SIMPLE_STATUS.DISPLAY_MESSAGE (S));
end case;
end STATUS;
procedure STATUS (S : in DIRECTORY.ERROR_STATUS) is
use DIR;
begin
if S /= DIR.SUCCESSFUL then
LOGGER.ERROR ("Directory operation failed because of " &
FORMAT (DIR.ERROR_STATUS'IMAGE (S)));
end if;
end STATUS;
procedure STATUS (S : in DIRECTORY.NAMING.NAME_STATUS) is
use DIR.NAMING;
begin
if S /= DIR.NAMING.SUCCESSFUL then
LOGGER.ERROR ("Name resolution failed because of " &
FORMAT (DIR.NAMING.NAME_STATUS'IMAGE (S)));
end if;
end STATUS;
procedure STATUS (S : in CMVC_STATUS) is
begin
if CMVCE.IS_BAD (S) then
LOGGER.ERROR (CMVCE.MESSAGE (S));
end if;
end STATUS;
procedure AUXILIARY (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.AUXILIARY_MSG);
end AUXILIARY;
procedure DEBUG (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.DEBUG_MSG);
end DEBUG;
procedure NEGATIVE (MESSAGE : in STRING; RAISE_ERROR : in BOOLEAN := TRUE) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.NEGATIVE_MSG);
if RAISE_ERROR then
raise PROFILE.ERROR;
end if;
end NEGATIVE;
procedure ERROR (MESSAGE : in STRING; RAISE_ERROR : in BOOLEAN := TRUE) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.ERROR_MSG);
if RAISE_ERROR then
raise PROFILE.ERROR;
end if;
end ERROR;
procedure NOTE (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.NOTE_MSG);
end NOTE;
procedure POSITION (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.POSITION_MSG);
end POSITION;
procedure POSITIVE (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.POSITIVE_MSG);
end POSITIVE;
procedure WARNING (MESSAGE : in STRING) is
begin
LOG.PUT_LINE (STRIP (MESSAGE), KIND => PROFILE.WARNING_MSG);
end WARNING;
end LOGGER;with ACTION;
pragma PRIVATE_EYES_ONLY;
with DIRECTORY;
with SIMPLE_STATUS;
package REQUIREMENTS is
subtype COUNT is NATURAL range 0 .. 127;
type REQUIREMENT_KIND is (NOT_A_REQUIREMENT,
FUNCTIONAL,
PERFORMANCE,
EXTERNAL_INTERFACE,
OPERATIONAL,
RESOURCE,
QUALIFICATION_TESTING,
ACCEPTANCE_TESTING,
DOCUMENTATION,
QUALITY,
SAFETY,
RELIABILITY,
MAINTAINABILITY,
DEVELOPMENT_AND_VERIFICATION,
DESIGN_AND_PROGRAMMING,
REUSE_AND_COMMONALITY);
subtype NON_FUNCTIONAL is
REQUIREMENT_KIND range REQUIREMENT_KIND'SUCC (FUNCTIONAL) ..
REQUIREMENT_KIND'LAST;
subtype VERIFICATION is REQUIREMENT_KIND
range QUALIFICATION_TESTING .. ACCEPTANCE_TESTING;
subtype DEPENDABILITY is REQUIREMENT_KIND range QUALITY .. MAINTAINABILITY;
subtype IMPLEMENTATION is
REQUIREMENT_KIND range DEVELOPMENT_AND_VERIFICATION ..
REUSE_AND_COMMONALITY;
type REQUIREMENT_NUMBER is new POSITIVE;
subtype FUNCTIONAL_REQUIREMENT_NUMBER is
REQUIREMENT_NUMBER range REQUIREMENT_NUMBER'FIRST .. 9;
subtype NON_FUNCTIONAL_REQUIREMENT_NUMBER is
REQUIREMENT_NUMBER range FUNCTIONAL_REQUIREMENT_NUMBER'LAST + 1 ..
REQUIREMENT_NUMBER'LAST;
-- ---------------------------
-- ( ) Individual requirements
-- ---------------------------
type REQUIREMENT (KIND : REQUIREMENT_KIND := NOT_A_REQUIREMENT) is private;
subtype FUNCTIONAL_REQUIREMENT is REQUIREMENT (FUNCTIONAL);
function RESOLVE (MODEL_GATEWAY_NAME : in STRING;
MODULE_ID : in POSITIVE;
REQUIREMENT_ID : in REQUIREMENT_NUMBER;
ACTION_ID : in ACTION.ID) return REQUIREMENT;
function COMMENT (ASA_GATEWAY_NAME : in STRING;
ACTION_ID : in ACTION.ID) return STRING;
function DIAGNOSIS (REQ : in REQUIREMENT) return STRING;
function GATEWAY_FULL_NAME (REQ : in REQUIREMENT) return STRING;
function UNIQUE_ID (REQ : in REQUIREMENT) return STRING;
function TEXT (REQ : in REQUIREMENT) return STRING;
type PERMANENT_REPRESENTATION is array (POSITIVE range 1 .. 4) of INTEGER;
function CONVERT (REQ : in REQUIREMENT) return PERMANENT_REPRESENTATION;
function CONVERT (REP : in PERMANENT_REPRESENTATION;
ACTION_ID : in ACTION.ID) return REQUIREMENT;
-- --------------------------
-- ( ) Requirements hierarchy
-- --------------------------
type REQUIREMENT_ITERATOR (SIZE : COUNT := 0) is private;
function RESOLVE (ASA_GATEWAY_NAME : in STRING;
KIND : in REQUIREMENT_KIND;
ACTION_ID : ACTION.ID) return REQUIREMENT_ITERATOR;
function VALUE (REQS : in REQUIREMENT_ITERATOR) return REQUIREMENT;
function DONE (REQS : in REQUIREMENT_ITERATOR) return BOOLEAN;
procedure NEXT (REQS : in out REQUIREMENT_ITERATOR);
procedure ADD (REQ : in REQUIREMENT; REQS : in out REQUIREMENT_ITERATOR);
procedure REMOVE (REQ : in REQUIREMENT; REQS : in out REQUIREMENT_ITERATOR);
-- ----------------
-- ( ) Dependencies
-- ----------------
type DEPENDENTS (IS_BAD : BOOLEAN) is private;
function GET_DEPENDENTS (REQ : in REQUIREMENT) return DEPENDENTS;
procedure SET_DEPENDENTS (REQ : in REQUIREMENT;
DEP : in DEPENDENTS);
procedure ADD (DEP : in out DEPENDENTS;
ONTO : in STRING);
procedure REMOVE (DEP : in out DEPENDENTS;
ONTO : in STRING);
function DIAGNOSIS (DEP : in DEPENDENTS) return STRING;
-- --------------
-- ( ) Exceptions
-- --------------
DEPENDENT_ERROR : exception;
REQUIREMENT_ERROR : exception;
private
package DIR renames DIRECTORY;
package DNA renames DIRECTORY.NAMING;
type STATUS_KIND is (MODULE_ID_ERROR,
DIRECTORY_ERROR,
DIRECTORY_NAMING_ERROR,
GENERAL_ERROR);
type STATUS (KIND : STATUS_KIND := GENERAL_ERROR) is
record
case KIND is
when MODULE_ID_ERROR =>
null;
when DIRECTORY_ERROR =>
ERROR_STATUS : DIR.ERROR_STATUS;
when DIRECTORY_NAMING_ERROR =>
NAME_STATUS : DNA.NAME_STATUS;
when GENERAL_ERROR =>
CONDITION : SIMPLE_STATUS.CONDITION;
end case;
end record;
type REQUIREMENT (KIND : REQUIREMENT_KIND := NOT_A_REQUIREMENT) is
record
case KIND is
when NOT_A_REQUIREMENT =>
ERROR : STATUS;
when FUNCTIONAL | NON_FUNCTIONAL =>
ACTION_ID : ACTION.ID;
OBJECT : DIR.OBJECT;
case KIND is
when NOT_A_REQUIREMENT =>
null;
when FUNCTIONAL =>
ID : FUNCTIONAL_REQUIREMENT_NUMBER;
when NON_FUNCTIONAL =>
null;
end case;
end case;
end record;
type REQUIREMENT_LIST is array (COUNT range <>) of REQUIREMENT;
type REQUIREMENT_ITERATOR (SIZE : COUNT := 0) is
record
POS : COUNT := 1;
CONTENTS : REQUIREMENT_LIST (1 .. SIZE);
end record;
type OBJECT_LIST is array (COUNT range <>) of DIR.OBJECT;
type OBJECT_LIST_ACCESS is access OBJECT_LIST;
pragma SEGMENTED_HEAP (OBJECT_LIST_ACCESS);
type DEPENDENTS (IS_BAD : BOOLEAN) is
record
case IS_BAD is
when FALSE =>
OBJECTS : OBJECT_LIST_ACCESS;
when TRUE =>
ERROR : STATUS;
end case;
end record;
end REQUIREMENTS;with ASA_DEFINITIONS;
with GATEWAY_OBJECT;
with JOB_SEGMENT;
with OBJECT_CLASS;
with SIMPLE_STATUS;
with STRING_UTILITIES;
with SYSTEM;
with TABLE_SORT_GENERIC;
with UNCHECKED_CONVERSION;
package body REQUIREMENTS is
package ASAP renames ASA_DEFINITIONS.PROPERTIES;
package DTR renames DIRECTORY.TRAVERSAL;
package DST renames DIRECTORY.STATISTICS;
package GWO renames GATEWAY_OBJECT;
package SS renames SIMPLE_STATUS;
-- ---------------------------------------------
-- ( ) Declarations for permanent representation
-- ---------------------------------------------
type RECORD_PERMANENT_REPRESENTATION is
record
KIND : REQUIREMENT_KIND;
OBJECT : DIR.OBJECT;
ID : FUNCTIONAL_REQUIREMENT_NUMBER;
end record;
--
-- It is necessary to use a 31-bit integer internally, because
-- unchecked conversion to a 30-bit integer may yield -2**31,
-- which is the uninitialized value, and will raise NUMERIC_ERROR
-- when read.
--
type INTEGER31 is range -2 ** 30 .. 2 ** 30 - 1;
for INTEGER31'SIZE use 31;
pragma ASSERT (RECORD_PERMANENT_REPRESENTATION'SIZE <=
PERMANENT_REPRESENTATION'LENGTH * INTEGER31'SIZE);
type INTEGER31_PERMANENT_REPRESENTATION is
array (PERMANENT_REPRESENTATION'RANGE) of INTEGER31;
function TO_RECORD is new UNCHECKED_CONVERSION
(SOURCE => INTEGER31_PERMANENT_REPRESENTATION,
TARGET => RECORD_PERMANENT_REPRESENTATION);
function FROM_RECORD is
new UNCHECKED_CONVERSION (SOURCE => RECORD_PERMANENT_REPRESENTATION,
TARGET => INTEGER31_PERMANENT_REPRESENTATION);
-- ------------------
-- ( ) Error handling
-- ------------------
function DIAGNOSIS (ERROR : in STATUS) return STRING is
begin
case ERROR.KIND is
when MODULE_ID_ERROR =>
return "the specified requirement id could not be found";
when DIRECTORY_ERROR =>
return STRING_UTILITIES.LOWER_CASE
(DIR.ERROR_STATUS'IMAGE (ERROR.ERROR_STATUS));
when DIRECTORY_NAMING_ERROR =>
return STRING_UTILITIES.LOWER_CASE
(DNA.NAME_STATUS'IMAGE (ERROR.NAME_STATUS));
when GENERAL_ERROR =>
return SS.DISPLAY_MESSAGE (ERROR.CONDITION);
end case;
end DIAGNOSIS;
function MODULE_ID_ERROR return REQUIREMENT is
begin
return (KIND => NOT_A_REQUIREMENT,
ERROR => (KIND => STATUS_KIND'(MODULE_ID_ERROR)));
end MODULE_ID_ERROR;
function DIRECTORY_ERROR (E : in DIR.ERROR_STATUS) return REQUIREMENT is
begin
return (KIND => NOT_A_REQUIREMENT,
ERROR => (KIND => DIRECTORY_ERROR, ERROR_STATUS => E));
end DIRECTORY_ERROR;
function DIRECTORY_ERROR (E : in DIR.ERROR_STATUS) return DEPENDENTS is
begin
return (IS_BAD => TRUE,
ERROR => (KIND => DIRECTORY_ERROR, ERROR_STATUS => E));
end DIRECTORY_ERROR;
function DIRECTORY_NAMING_ERROR
(N : in DNA.NAME_STATUS) return REQUIREMENT is
begin
return (KIND => NOT_A_REQUIREMENT,
ERROR => (KIND => DIRECTORY_NAMING_ERROR, NAME_STATUS => N));
end DIRECTORY_NAMING_ERROR;
function DIRECTORY_NAMING_ERROR (N : in DNA.NAME_STATUS) return DEPENDENTS is
begin
return (IS_BAD => TRUE,
ERROR => (KIND => DIRECTORY_NAMING_ERROR, NAME_STATUS => N));
end DIRECTORY_NAMING_ERROR;
function GENERAL_ERROR (S : in SS.CONDITION) return REQUIREMENT is
begin
return (KIND => NOT_A_REQUIREMENT,
ERROR => (KIND => GENERAL_ERROR, CONDITION => S));
end GENERAL_ERROR;
function GENERAL_ERROR (S : in SS.CONDITION) return DEPENDENTS is
begin
return (IS_BAD => TRUE, ERROR => (KIND => GENERAL_ERROR, CONDITION => S));
end GENERAL_ERROR;
-- -------------
-- ( ) Utilities
-- -------------
function NAME (OBJECTS : in OBJECT_LIST; BEFORE : in STRING) return STRING is
begin
if OBJECTS'FIRST > OBJECTS'LAST then
return BEFORE;
elsif BEFORE = "" then
return NAME (OBJECTS => OBJECTS (OBJECTS'FIRST + 1 .. OBJECTS'LAST),
BEFORE => DNA.GET_FULL_NAME (OBJECTS (OBJECTS'FIRST)));
else
return NAME (OBJECTS => OBJECTS (OBJECTS'FIRST + 1 .. OBJECTS'LAST),
BEFORE => BEFORE & ',' & DNA.GET_FULL_NAME
(OBJECTS (OBJECTS'FIRST)));
end if;
end NAME;
procedure SEARCH_BY_ID (ROOT : in DIR.OBJECT;
ID : in POSITIVE;
ACTION_ID : in ACTION.ID;
FOUND : out BOOLEAN;
OBJECT : out DIR.OBJECT) is
E : DIR.ERROR_STATUS;
FOUND_IN_SUBOBJECT : BOOLEAN;
OBJECT_IN_SUBOBJECT : DIR.OBJECT;
GATEWAY : GWO.HANDLE;
N : DNA.NAME_STATUS;
S : SS.CONDITION;
SUBOBJECT : DIR.OBJECT;
SUBOBJECTS : DNA.ITERATOR;
use DIR;
use DNA;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => ROOT,
H => GATEWAY,
UPDATE => FALSE,
ERRORS => S);
if SS.ERROR (S) then
FOUND := FALSE;
OBJECT := DIR.NIL;
return;
end if;
if ASAP.ASA_ID (GATEWAY) = ID then
GWO.CLOSE (GATEWAY);
FOUND := TRUE;
OBJECT := ROOT;
return;
else
GWO.CLOSE (GATEWAY);
DNA.RESOLVE (ITER => SUBOBJECTS,
SOURCE => DNA.GET_FULL_NAME (ROOT) & ".@'C(~TEXT)",
STATUS => N,
ACTION_ID => ACTION_ID);
if N = DNA.SUCCESSFUL then
while not DNA.DONE (SUBOBJECTS) loop
DNA.GET_OBJECT (ITER => SUBOBJECTS,
THE_OBJECT => SUBOBJECT,
STATUS => E);
if E /= DIR.SUCCESSFUL then
FOUND := FALSE;
OBJECT := DIR.NIL;
return;
end if;
SEARCH_BY_ID (ROOT => SUBOBJECT,
ID => ID,
ACTION_ID => ACTION_ID,
FOUND => FOUND_IN_SUBOBJECT,
OBJECT => OBJECT_IN_SUBOBJECT);
if FOUND_IN_SUBOBJECT then
FOUND := FOUND_IN_SUBOBJECT;
OBJECT := OBJECT_IN_SUBOBJECT;
return;
end if;
DNA.NEXT (SUBOBJECTS);
end loop;
end if;
FOUND := FALSE;
OBJECT := DIR.NIL;
end if;
end SEARCH_BY_ID;
-- ----------------------------------
-- ( ) Bodies of external subprograms
-- ----------------------------------
-- -----------------------------
-- ( . ) Individual requirements
-- -----------------------------
function RESOLVE (MODEL_GATEWAY_NAME : in STRING;
MODULE_ID : in POSITIVE;
REQUIREMENT_ID : in REQUIREMENT_NUMBER;
ACTION_ID : in ACTION.ID) return REQUIREMENT is
E : DIR.ERROR_STATUS;
FOUND : BOOLEAN;
GATEWAY : GWO.HANDLE;
N : DNA.NAME_STATUS;
S : SS.CONDITION;
THE_MODULE : DIR.OBJECT;
THE_OBJECT : DIR.OBJECT;
THE_REQUIREMENT : DIR.OBJECT;
THE_REQUIREMENTS : DNA.ITERATOR;
use ASA_DEFINITIONS;
use DIR;
use DNA;
begin
DNA.RESOLVE (NAME => MODEL_GATEWAY_NAME,
THE_OBJECT => THE_OBJECT,
STATUS => N);
if N /= DNA.SUCCESSFUL then
return DIRECTORY_NAMING_ERROR (N);
end if;
SEARCH_BY_ID (ROOT => THE_OBJECT,
ID => MODULE_ID,
ACTION_ID => ACTION_ID,
FOUND => FOUND,
OBJECT => THE_MODULE);
if FOUND then
case REQUIREMENT_ID is
when FUNCTIONAL_REQUIREMENT_NUMBER =>
return (KIND => FUNCTIONAL,
ACTION_ID => ACTION_ID,
OBJECT => THE_MODULE,
ID => REQUIREMENT_ID);
when NON_FUNCTIONAL_REQUIREMENT_NUMBER =>
DNA.RESOLVE (ITER => THE_REQUIREMENTS,
SOURCE => DNA.GET_FULL_NAME (THE_MODULE) &
".@'C(TEXT)",
STATUS => N,
ACTION_ID => ACTION_ID);
if N = DNA.SUCCESSFUL then
while not DNA.DONE (THE_REQUIREMENTS) loop
DNA.GET_OBJECT (ITER => THE_REQUIREMENTS,
THE_OBJECT => THE_REQUIREMENT,
STATUS => E);
if E /= DIR.SUCCESSFUL then
return DIRECTORY_ERROR (E);
end if;
GWO.OPEN_MAIN_OBJECT (OBJECT => THE_REQUIREMENT,
H => GATEWAY,
UPDATE => FALSE,
ERRORS => S);
if SS.ERROR (S) then
return GENERAL_ERROR (S);
end if;
if REQUIREMENT_NUMBER (ASAP.ASA_ID (GATEWAY)) =
REQUIREMENT_ID then
declare
RESULT : REQUIREMENT
(ASAP.ASA_REQUIREMENT_KIND (GATEWAY));
begin
RESULT.ACTION_ID := ACTION_ID;
RESULT.OBJECT := THE_REQUIREMENT;
GWO.CLOSE (GATEWAY);
return RESULT;
end;
end if;
GWO.CLOSE (GATEWAY);
DNA.NEXT (THE_REQUIREMENTS);
end loop;
else
return DIRECTORY_NAMING_ERROR (N);
end if;
end case;
else
return MODULE_ID_ERROR;
end if;
end RESOLVE;
function COMMENT (ASA_GATEWAY_NAME : in STRING;
ACTION_ID : in ACTION.ID) return STRING is
GATEWAY : GWO.HANDLE;
GATEWAY_OBJECT : DIR.OBJECT;
S : SS.CONDITION;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => ASA_GATEWAY_NAME,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
return "";
end if;
declare
COMMENT : constant STRING := ASAP.ASA_COMMENT (GATEWAY);
begin
if COMMENT = "" then
GATEWAY_OBJECT := GWO.DIRECTORY_OBJECT (GATEWAY);
GWO.CLOSE (GATEWAY);
return DNA.GET_SIMPLE_NAME (GATEWAY_OBJECT);
else
GWO.CLOSE (GATEWAY);
return COMMENT;
end if;
end;
end COMMENT;
function DIAGNOSIS (REQ : in REQUIREMENT) return STRING is
begin
case REQ.KIND is
when NOT_A_REQUIREMENT =>
return DIAGNOSIS (REQ.ERROR);
when FUNCTIONAL | NON_FUNCTIONAL =>
return "";
end case;
end DIAGNOSIS;
function GATEWAY_FULL_NAME (REQ : in REQUIREMENT) return STRING is
begin
return DNA.GET_FULL_NAME (REQ.OBJECT);
end GATEWAY_FULL_NAME;
function UNIQUE_ID (REQ : in REQUIREMENT) return STRING is
DATA : DST.OBJECT_DATA;
E : DIR.ERROR_STATUS;
GATEWAY : GWO.HANDLE;
ID : POSITIVE;
MODULE_ID : POSITIVE;
S : SS.CONDITION;
use DIR;
begin
case REQ.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
MODULE_ID := ASAP.ASA_ID (GATEWAY);
GWO.CLOSE (GATEWAY);
declare
MODULE_ID_IMAGE : constant STRING := POSITIVE'IMAGE (MODULE_ID);
ID_IMAGE : constant STRING :=
FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (REQ.ID);
begin
return MODULE_ID_IMAGE (MODULE_ID_IMAGE'FIRST + 1 ..
MODULE_ID_IMAGE'LAST) & '.' &
ID_IMAGE (ID_IMAGE'FIRST + 1 .. ID_IMAGE'LAST);
end;
when NON_FUNCTIONAL =>
DST.GET_OBJECT_DATA (THE_OBJECT => REQ.OBJECT,
THE_DATA => DATA,
ACTION_ID => REQ.ACTION_ID,
STATUS => E);
if E /= DIR.SUCCESSFUL then
raise REQUIREMENT_ERROR;
end if;
GWO.OPEN_MAIN_OBJECT (OBJECT => DST.OBJECT_PARENT (DATA),
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
MODULE_ID := ASAP.ASA_ID (GATEWAY);
GWO.CLOSE (GATEWAY);
GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
ID := ASAP.ASA_ID (GATEWAY);
GWO.CLOSE (GATEWAY);
declare
MODULE_ID_IMAGE : constant STRING := POSITIVE'IMAGE (MODULE_ID);
ID_IMAGE : constant STRING := POSITIVE'IMAGE (ID);
begin
return MODULE_ID_IMAGE (MODULE_ID_IMAGE'FIRST + 1 ..
MODULE_ID_IMAGE'LAST) & '.' &
ID_IMAGE (ID_IMAGE'FIRST + 1 .. ID_IMAGE'LAST);
end;
end case;
end UNIQUE_ID;
function TEXT (REQ : in REQUIREMENT) return STRING is
GATEWAY : GWO.HANDLE;
S : SS.CONDITION;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
case REQ.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
declare
THE_TEXT : constant STRING :=
ASAP.ASA_REQUIREMENT (GATEWAY, NUMBER => REQ.ID);
begin
GWO.CLOSE (GATEWAY);
return THE_TEXT;
end;
when NON_FUNCTIONAL =>
declare
THE_TEXT : constant STRING :=
ASAP.ASA_REQUIREMENT_TEXT (GATEWAY);
begin
GWO.CLOSE (GATEWAY);
return THE_TEXT;
end;
end case;
end TEXT;
function CONVERT (REQ : in REQUIREMENT) return PERMANENT_REPRESENTATION is
IREP : INTEGER31_PERMANENT_REPRESENTATION := (others => 0);
REP : PERMANENT_REPRESENTATION;
begin
case REQ.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
IREP := FROM_RECORD
((KIND => REQ.KIND, OBJECT => REQ.OBJECT, ID => REQ.ID));
when NON_FUNCTIONAL =>
IREP := FROM_RECORD
((KIND => REQ.KIND, OBJECT => REQ.OBJECT, ID => 1));
end case;
for I in REP'RANGE loop
REP (I) := INTEGER (IREP (I));
end loop;
return REP;
end CONVERT;
function CONVERT (REP : in PERMANENT_REPRESENTATION;
ACTION_ID : in ACTION.ID) return REQUIREMENT is
IREP : INTEGER31_PERMANENT_REPRESENTATION;
RREP : RECORD_PERMANENT_REPRESENTATION;
begin
for I in REP'RANGE loop
IREP (I) := INTEGER31 (REP (I));
end loop;
RREP := TO_RECORD (IREP);
declare
RESULT : REQUIREMENT (RREP.KIND);
begin
case RESULT.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
RESULT.ACTION_ID := ACTION_ID;
RESULT.OBJECT := RREP.OBJECT;
RESULT.ID := RREP.ID;
when NON_FUNCTIONAL =>
RESULT.ACTION_ID := ACTION_ID;
RESULT.OBJECT := RREP.OBJECT;
end case;
return RESULT;
end;
end CONVERT;
-- ----------------------------
-- ( . ) Requirements hierarchy
-- ----------------------------
function RESOLVE (ASA_GATEWAY_NAME : in STRING;
KIND : in REQUIREMENT_KIND;
ACTION_ID : ACTION.ID) return REQUIREMENT_ITERATOR is
type OBJECT_AND_ID is
record
OBJECT : DIR.OBJECT;
ID : POSITIVE;
end record;
type OBJECTS_AND_IDS is array (COUNT range <>) of OBJECT_AND_ID;
E : DIR.ERROR_STATUS;
GATEWAY : GWO.HANDLE;
GATEWAY_OBJECT : DIR.OBJECT;
GATEWAY_OBJECTS : DNA.ITERATOR;
N : DNA.NAME_STATUS;
RESULT : REQUIREMENT_ITERATOR;
S : SS.CONDITION;
SIZE : COUNT := 0;
THE_OBJECTS : OBJECTS_AND_IDS (COUNT range 1 .. COUNT'LAST);
function "<" (LEFT : in OBJECT_AND_ID; RIGHT : in OBJECT_AND_ID)
return BOOLEAN is
begin
return LEFT.ID < RIGHT.ID;
end "<";
procedure SORT_BY_ID is
new TABLE_SORT_GENERIC (ELEMENT => OBJECT_AND_ID,
INDEX => COUNT,
ELEMENT_ARRAY => OBJECTS_AND_IDS);
use DIR;
use DNA;
begin
case KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
DNA.RESOLVE (NAME => ASA_GATEWAY_NAME,
THE_OBJECT => GATEWAY_OBJECT,
STATUS => N,
ACTION_ID => ACTION_ID);
if N /= DNA.SUCCESSFUL then
raise REQUIREMENT_ERROR;
end if;
GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
for R in reverse FUNCTIONAL_REQUIREMENT_NUMBER loop
if ASAP.ASA_REQUIREMENT (GATEWAY, NUMBER => R) /= "" then
SIZE := COUNT (R);
exit;
end if;
end loop;
GWO.CLOSE (GATEWAY);
RESULT := (SIZE => SIZE,
POS => 1,
CONTENTS => (others => (KIND => FUNCTIONAL,
ACTION_ID => ACTION_ID,
OBJECT => GATEWAY_OBJECT,
ID => 1)));
for I in RESULT.CONTENTS'RANGE loop
RESULT.CONTENTS (I).ID := FUNCTIONAL_REQUIREMENT_NUMBER (I);
end loop;
return RESULT;
when NON_FUNCTIONAL =>
DNA.RESOLVE (SOURCE => ASA_GATEWAY_NAME & ".@'C(Text)",
ITER => GATEWAY_OBJECTS,
STATUS => N,
ACTION_ID => ACTION_ID);
if N /= DNA.UNDEFINED then
if N /= DNA.SUCCESSFUL then
raise REQUIREMENT_ERROR;
end if;
while not DNA.DONE (GATEWAY_OBJECTS) loop
DNA.GET_OBJECT (ITER => GATEWAY_OBJECTS,
THE_OBJECT => GATEWAY_OBJECT,
STATUS => E);
if E /= DIR.SUCCESSFUL then
raise REQUIREMENT_ERROR;
end if;
GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
if ASAP.ASA_REQUIREMENT_KIND (GATEWAY) = KIND then
SIZE := SIZE + 1;
THE_OBJECTS (SIZE) := (OBJECT => GATEWAY_OBJECT,
ID => ASAP.ASA_ID (GATEWAY));
end if;
GWO.CLOSE (GATEWAY);
DNA.NEXT (GATEWAY_OBJECTS);
end loop;
end if;
SORT_BY_ID (THE_OBJECTS (THE_OBJECTS'FIRST .. SIZE));
declare
NULL_REQUIREMENT : REQUIREMENT (KIND);
begin
NULL_REQUIREMENT.ACTION_ID := ACTION_ID;
NULL_REQUIREMENT.OBJECT := DIR.NIL;
RESULT := (SIZE => SIZE,
POS => 1,
CONTENTS => (others => NULL_REQUIREMENT));
end;
for I in RESULT.CONTENTS'RANGE loop
RESULT.CONTENTS (I).OBJECT := THE_OBJECTS (I).OBJECT;
end loop;
return RESULT;
end case;
end RESOLVE;
function VALUE (REQS : in REQUIREMENT_ITERATOR) return REQUIREMENT is
begin
return REQS.CONTENTS (REQS.POS);
end VALUE;
function DONE (REQS : in REQUIREMENT_ITERATOR) return BOOLEAN is
begin
return REQS.POS > REQS.SIZE;
end DONE;
procedure NEXT (REQS : in out REQUIREMENT_ITERATOR) is
begin
REQS.POS := REQS.POS + 1;
end NEXT;
procedure ADD (REQ : in REQUIREMENT; REQS : in out REQUIREMENT_ITERATOR) is
RESULT : REQUIREMENT_ITERATOR (REQS.SIZE + 1);
begin
RESULT.POS := REQS.POS;
RESULT.CONTENTS := REQS.CONTENTS & REQ;
REQS := RESULT;
end ADD;
procedure REMOVE (REQ : in REQUIREMENT;
REQS : in out REQUIREMENT_ITERATOR) is
RESULT : REQUIREMENT_ITERATOR (REQS.SIZE - 1);
begin
for I in REQS.CONTENTS'RANGE loop
if REQS.CONTENTS (I) = REQ then
RESULT.CONTENTS := REQS.CONTENTS (1 .. I - 1) &
REQS.CONTENTS (I + 1 .. REQS.SIZE);
end if;
end loop;
REQS := RESULT;
end REMOVE;
-- ----------------
-- ( ) Dependencies
-- ----------------
function GET_DEPENDENTS (REQ : in REQUIREMENT) return DEPENDENTS is
DEPENDENT_OBJECTS : DNA.ITERATOR;
E : DIR.ERROR_STATUS;
GATEWAY : GWO.HANDLE;
N : DNA.NAME_STATUS;
S : SS.CONDITION;
SIZE : COUNT := 0;
THE_OBJECTS : OBJECT_LIST (COUNT);
function ASA_DEPENDENTS (REQ : in REQUIREMENT) return STRING is
begin
case REQ.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
return ASAP.ASA_DEPENDENTS (GATEWAY, NUMBER => REQ.ID);
when NON_FUNCTIONAL =>
return ASAP.ASA_DEPENDENTS (GATEWAY);
end case;
end ASA_DEPENDENTS;
use DIR;
use DNA;
begin
GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
return GENERAL_ERROR (S);
end if;
declare
THE_DEPENDENTS : constant STRING := ASA_DEPENDENTS (REQ);
begin
GWO.CLOSE (GATEWAY, S);
if SS.ERROR (S) then
return GENERAL_ERROR (S);
end if;
if THE_DEPENDENTS = "" then
return (IS_BAD => FALSE,
OBJECTS => new OBJECT_LIST'(1 .. 0 => DIR.NIL));
pragma HEAP (JOB_SEGMENT.GET);
end if;
DNA.RESOLVE (ITER => DEPENDENT_OBJECTS,
SOURCE => '[' & THE_DEPENDENTS & "]'S(Installed,Coded)",
STATUS => N,
OBJECTS_ONLY => FALSE,
ACTION_ID => REQ.ACTION_ID);
end;
if N = DNA.UNDEFINED then
return (IS_BAD => FALSE,
OBJECTS => new OBJECT_LIST'(1 .. 0 => DIR.NIL));
pragma HEAP (JOB_SEGMENT.GET);
elsif N /= DNA.SUCCESSFUL then
return DIRECTORY_NAMING_ERROR (N);
end if;
while not DNA.DONE (DEPENDENT_OBJECTS) loop
SIZE := SIZE + 1;
DNA.GET_OBJECT (ITER => DEPENDENT_OBJECTS,
THE_OBJECT => THE_OBJECTS (SIZE),
STATUS => E);
if E /= DIR.SUCCESSFUL then
return DIRECTORY_ERROR (E);
end if;
DNA.NEXT (DEPENDENT_OBJECTS);
end loop;
return (IS_BAD => FALSE,
OBJECTS => new OBJECT_LIST'(THE_OBJECTS (1 .. SIZE)));
pragma HEAP (JOB_SEGMENT.GET);
end GET_DEPENDENTS;
procedure SET_DEPENDENTS (REQ : in REQUIREMENT;
DEP : in DEPENDENTS) is
DEPENDENT_OBJECTS : DNA.ITERATOR;
GATEWAY : GWO.HANDLE;
S : SS.CONDITION;
SIZE : COUNT := 0;
THE_OBJECTS : OBJECT_LIST (COUNT);
begin
if DEP.IS_BAD then
raise DEPENDENT_ERROR;
end if;
GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,
H => GATEWAY,
UPDATE => FALSE,
ACTION_ID => REQ.ACTION_ID,
ERRORS => S);
if SS.ERROR (S) then
raise REQUIREMENT_ERROR;
end if;
case REQ.KIND is
when NOT_A_REQUIREMENT =>
raise REQUIREMENT_ERROR;
when FUNCTIONAL =>
ASAP.SET_ASA_DEPENDENTS
(GATEWAY,
NUMBER => REQ.ID,
VALUE => NAME (OBJECTS => DEP.OBJECTS.all, BEFORE => ""));
when NON_FUNCTIONAL =>
ASAP.SET_ASA_DEPENDENTS
(GATEWAY,
VALUE => NAME (OBJECTS => DEP.OBJECTS.all, BEFORE => ""));
end case;
GWO.CLOSE (GATEWAY);
end SET_DEPENDENTS;
procedure ADD (DEP : in out DEPENDENTS;
ONTO : in STRING) is
N : DNA.NAME_STATUS;
THE_OBJECT : DIR.OBJECT;
use DNA;
begin
if DEP.IS_BAD then
raise DEPENDENT_ERROR;
end if;
DNA.RESOLVE (NAME => ONTO,
THE_OBJECT => THE_OBJECT,
STATUS => N,
ACTION_ID => ACTION.NULL_ID);
DEP := (IS_BAD => FALSE,
OBJECTS => new OBJECT_LIST'(DEP.OBJECTS.all & THE_OBJECT));
pragma HEAP (JOB_SEGMENT.GET);
end ADD;
procedure REMOVE (DEP : in out DEPENDENTS;
ONTO : in STRING) is
N : DNA.NAME_STATUS;
THE_OBJECT : DIR.OBJECT;
use DIR;
begin
if DEP.IS_BAD then
raise DEPENDENT_ERROR;
end if;
DNA.RESOLVE (NAME => ONTO,
THE_OBJECT => THE_OBJECT,
STATUS => N,
ACTION_ID => ACTION.NULL_ID);
for I in DEP.OBJECTS'RANGE loop
if THE_OBJECT = DEP.OBJECTS (I) then
DEP := (IS_BAD => FALSE,
OBJECTS => new
OBJECT_LIST'
(DEP.OBJECTS (DEP.OBJECTS'FIRST .. I - 1) &
DEP.OBJECTS (I + 1 .. DEP.OBJECTS'LAST)));
pragma HEAP (JOB_SEGMENT.GET);
end if;
end loop;
end REMOVE;
function DIAGNOSIS (DEP : in DEPENDENTS) return STRING is
begin
case DEP.IS_BAD is
when FALSE =>
return "";
when TRUE =>
return DIAGNOSIS (DEP.ERROR);
end case;
end DIAGNOSIS;
end REQUIREMENTS;--
-- This function returns a 10-character string made of lowercase letter
-- and digits, which is guaranteed to be different at each call, even if
-- they are very close to each other. For any sensible machine date,
-- the first character will be alphabetic.
--
function UNIQUE return STRING;with CALENDAR;
with UNCHECKED_CONVERSION;
function UNIQUE return STRING is
type INTEGER5 is range 0 .. 31;
for INTEGER5'SIZE use 5;
type TIME_STRING is
array (POSITIVE range 1 .. (CALENDAR.TIME'SIZE + INTEGER5'SIZE - 1) /
INTEGER5'SIZE) of INTEGER5;
GOOD_CHARACTERS : constant array (INTEGER5) of CHARACTER :=
"012345abcdefghijklmnopqrstuvwxyz";
function TO_TIME_STRING is
new UNCHECKED_CONVERSION (SOURCE => CALENDAR.TIME, TARGET => TIME_STRING);
NOW : constant CALENDAR.TIME := CALENDAR.CLOCK;
TS : constant TIME_STRING := TO_TIME_STRING (NOW);
S : STRING (TS'RANGE);
begin
for I in TS'RANGE loop
S (I) := GOOD_CHARACTERS (TS (I));
end loop;
return S;
end UNIQUE;package UNIX_DEFINITIONS is
-- UNIX commands
BACKGROUND : constant STRING := "&";
REMOVE : constant STRING := "rm";
SETENV : constant STRING := "setenv";
STREAM_EDITOR : constant STRING := "sed";
EDIT : constant STRING := "-e";
TAPE_ARCHIVE : constant STRING := "tar";
CREATE : constant STRING := "c";
ARCHIVE_FILE : constant STRING := "f";
OUTPUT_REDIRECT : constant STRING := ">";
CHANGE_DIRECTORY : constant STRING := "cd";
COMMAND_SEPARATOR : constant CHARACTER := ';';
-- UNIX environment variables
DISPLAY : constant STRING := "DISPLAY";
-- UNIX filenames
MINIMAL_FILENAME_LENGTH : constant := 14;
CONTEXT_SEPARATOR : constant CHARACTER := '/';
EXTENSION_SEPARATOR : constant CHARACTER := '.';
TARFILE_EXTENSION : constant STRING := EXTENSION_SEPARATOR & "Z";
function ENCLOSING_DIRECTORY (NAME : in STRING) return STRING;
function LOCAL_NAME (NAME : in STRING) return STRING;
function SIMPLE_NAME (NAME : in STRING) return STRING;
function TEMPORARY_FILENAME (EXTENSION : in STRING) return STRING;
end UNIX_DEFINITIONS;with UNIQUE;
package body UNIX_DEFINITIONS is
function ENCLOSING_DIRECTORY (NAME : in STRING) return STRING is
begin
for I in reverse NAME'RANGE loop
if NAME (I) = CONTEXT_SEPARATOR then
return NAME (NAME'FIRST .. I - 1);
end if;
end loop;
return "";
end ENCLOSING_DIRECTORY;
function LOCAL_NAME (NAME : in STRING) return STRING is
begin
for I in reverse NAME'RANGE loop
if NAME (I) = CONTEXT_SEPARATOR then
return NAME (I + 1 .. NAME'LAST);
end if;
end loop;
return NAME;
end LOCAL_NAME;
function SIMPLE_NAME (NAME : in STRING) return STRING is
begin
for I in reverse NAME'RANGE loop
if NAME (I) = CONTEXT_SEPARATOR then
for J in I + 1 .. NAME'LAST loop
if NAME (J) = EXTENSION_SEPARATOR then
return NAME (I + 1 .. J - 1);
end if;
end loop;
return NAME (I + 1 .. NAME'LAST);
end if;
end loop;
return NAME;
end SIMPLE_NAME;
function TEMPORARY_FILENAME (EXTENSION : in STRING) return STRING is
UNIQUE_NAME : constant STRING := UNIQUE & EXTENSION;
pragma ASSERT (UNIQUE_NAME'LENGTH <= MINIMAL_FILENAME_LENGTH);
begin
return CONTEXT_SEPARATOR & "tmp" & CONTEXT_SEPARATOR & UNIQUE_NAME;
end TEMPORARY_FILENAME;
end UNIX_DEFINITIONS;