|
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: 34816 (0x8800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, generic, package Gateway_Object, pragma Module_Name 4 3995, pragma Segmented_Heap Handle, pragma Subsystem Tools_Integration, seg_00f2a0
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Action;
with Directory;
with Io;
with Job_Segment;
with Polymorphic_Io;
with Simple_Status;
with System;
package Gateway_Object is
package Dir renames Directory;
-- Interface for manipulating Dtia Gateway objects
--
-- A Dtia Gateway object is a file which contains a number of property
-- values. There may, in addition, be zero or more sub-objects
-- under the file.
--
-- A Gateway_Object.Handle can represent a number of open Dtia objects
-- all related in some way. There is one main object referenced
-- by a Handle. It is the only one that can be updated. Other
-- objects can be opened using the same handle, but these are always
-- opened for read.
--
-- This package contains three groups of operations. The first is
-- for creating Gateway classes. A gateway class defines the
-- properties that objects of the class will specify. It also can
-- define types which specify the set of values for properties of the type.
-- The second group of operations handles the creation of Gateway objects.
-- The final group is used to read and set the values of Gateway
-- and Gateway class properties.
--------------------------------------------------
--
-- Operations for creating Gateway classes
--
--
type Handle is private;
-- Handles are dynamically allocated on a supplied heap. A handle can
-- be reused after it is closed. Thus, if you carefully declare
-- handles, few will be allocated.
--
Null_Handle : constant Handle;
--
type Slot_Id is new Integer; -- unique id for object's slot in handle
Nil_Slot_Id : constant Slot_Id := 0;
Main_Slot : constant Slot_Id := 1;
Class_Slot : constant Slot_Id := 2;
--
-- A Handle designates an open Gateway class or object. The Handle
-- designates one main object (which can be updated). Additional
-- objects can be opened for read under a single handle. Each is
-- opened under the same action and each has an Id associated with
-- it. This Id is supplied by the opener and is also supplied with
-- each use of a Handle. The Id identifies which object opened in
-- the handle will actually be accessed by a given call.
-- A Gateway class is a pattern from which other gateway objects are
-- constructed. The class may also contain default values that
-- are inherited by the objects. In addition, the class can define
-- enumeration types that are used in objects of the class.
-- The class defines the properties that objects of the class can
-- specify.
--
-- Each property has a type. The type must be either a predefined type
-- or a type defined in the class. Each type has an Id, and this Id
-- is used to reference the type in some contexts. The type Id must
-- be unique within the class, but different classes may reuse type
-- ids.
subtype Type_Id is Natural range 0 .. 2 ** 16 - 1; -- Identifies a type
Null_Type_Id : constant Type_Id := 0; -- This value is reserved.
-- Type_Id values are partitioned into predefined types and class-defined
-- types. Predefined values are allocated at the high end of the
-- range.
First_Predefined_Type : constant Type_Id := 65000;
Natural_Type_Id : constant Type_Id := 65000;
Long_Integer_Type_Id : constant Type_Id := 65001;
Boolean_Type_Id : constant Type_Id := 65002;
String_Type_Id : constant Type_Id := 65003;
Date_Type_Id : constant Type_Id := 65004;
Script_Type_Id : constant Type_Id := 65005;
-- Class defined Type_Ids are stored using a contiguous vector
-- indexed by the Type_Id. There can be unused values, but
-- all array elements in the range are allocated, so don't
-- choose the Type Ids to be sparse.
-- prefined property-type names:
--------------------------------
Natural_Property_Type_Name : constant String := "Natural";
Long_Integer_Property_Type_Name : constant String := "Long_Integer";
Boolean_Property_Type_Name : constant String := "Boolean";
String_Property_Type_Name : constant String := "String";
Date_Property_Type_Name : constant String := "Date";
Script_Property_Type_Name : constant String := "Script";
procedure Create_Class (Class_Name : String;
Highest_Class_Type_Id : Type_Id;
H : in out Handle;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
--
-- Create a definition for Class_Name which will contain type definitions
-- and property names and default values. These are defined by
-- calls to the Add_Type and Add_Property procedures below. Close
-- must be called once all the properties and types are defined.
--
-- If the Highest_Class_Type_Id must be changed, the class must be
-- deleted and rebuilt. As long as the Type_Id values defined for each
-- type are the same, this is not a problem for objects that reference
-- the class.
--
-- If H is null, it is allocated on the specified Heap. The Main_Slot
-- and Class_Slot entries in the Handle both refer to the opened
-- new class object.
procedure Add_Type (Class_Handle : in out Handle;
Id : Type_Id;
Type_Name : String;
Enumeration_Literals : String;
Errors : in out Simple_Status.Condition);
--
-- Add a type to the open class Class_Handle which was created with
-- Create_Class. Type_Id must be <= Highest_Class_Type_Id
-- and not already defined. The Enumeration_Literals list
-- is a comma-separated list of legal Ada identifiers (which can
-- be empty).
procedure Add_Property (Class_Handle : in out Handle;
Property_Name : String;
Property_Type : String;
Property_Value : String;
Is_Constant : Boolean;
Editable : Boolean;
Non_Display : Boolean;
Never_Display : Boolean;
No_Inherit : Boolean;
No_Eval : Boolean;
Edit_Acl_From : String;
Help_Text : String;
Errors : in out Simple_Status.Condition);
--
-- Add a property to the already-open class designated by Class_Handle.
-- The name, type, etc. of the property are specified by the parameters.
-- Property_Type Must be a predefined type or a type whose name
-- is already defined in the class.
-- Property_Value will be the default value for the property
-- in gateway objects of this class.
-- Is_Constant implies that the value is not changeable in the
-- gateway object once inherited.
-- Editable implies that the value is editable using the
-- Gateway OE. Does not affect programmatic
-- update of the object.
-- Non_Display implies that the Gateway OE will not display
-- this property by default.
-- Never_Display implies that the Gateway OE will never
-- display the property.
-- No_Inherit implies that, when an object is created, this
-- property will not be inherited from the class.
-- No_Eval implies that this property's value will not be
-- evaluated as a possible indirection specification,
-- but will be used as is.
-- Edit_Acl_From names a file whose acl is used to control update
-- of the property from the editor or as is desired.
-- W access to the file is required to
-- update the property value.
-- If null, no acl check is performed (other than
-- normal update (W) access to the object itself).
-- If a file is named but does not exist or cannot
-- be located, this is equivalent to not having W
-- access which prevents the property update.
-- Help_Text A structured string that is displayed when help
-- is requested for the property in the Gateway OE.
-- *** work to be done here: specify structure
--
-- Error if Class_Handle does not designate a class, or any of the
-- property values are illegal in some way.
---------------------------------------------------
--
-- Operations for creating Gateway objects
--
--
---------------------------------------------------
procedure Create (Name : String;
H : in out Handle;
Dir_Class : String := "File";
Dir_Subclass : String := "";
Gateway_Class : String;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
-- Create a Gateway object. Dir_Class and Dir_Subclass indicates the
-- kind of object. Currently, Dir_Class must be "File" and Dir_Subclass
-- can be any legal Gateway file subclass. If the Gateway_Class has a
-- property "Directory_Subclass", then the parameter Dir_Subclass may
-- be null and the subclass will be taken from the Gateway class
-- property.
--
-- The Gateway_Class may specify that subobjects be created. If so, they
-- will be created as part of this operation.
--
-- Property definitions will be inherited from the Gateway_Class.
-- If the class includes default values for properties, these will
-- also be inherited.
--
-- The new Gateway object is left open with H as its handle. It must
-- be closed at some point to complete the creation (see Close below).
--
-- Once created, the object is open and additional property values
-- can be assigned or interrogated.
--
-- The Main_Slot entry in the handle is set for the new object. The
-- Class_Slot entry is set for the object's gateway class.
----------------------------------------------------------------
--
-- Operations for accessing Gateway Objects and values
--
----------------------------------------------------------------
function Is_Gateway_Object (The_Object : Dir.Object) return Boolean;
-- true if gateway_object
procedure Open_Main_Object (Object : String;
H : in out Handle;
Update : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
--
-- Open the named object which must be a Gateway object or class
-- as the handle's main object. Also opens the Gateway object's class
-- in the handle's class slot.
--
-- Update indicates that the object is opened for update.
-- Update access to property values is further
-- controlled by the Edit_Acl_From mechanism.
--
-- If H is null, it is allocated on the specified Heap.
-- The object is opened using the Main_Slot entry in the handle.
procedure Open_Main_Object (Object : Dir.Object;
H : in out Handle;
Update : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
-- Same as above Open_Main_Object, except takes a Dir.Object
-- instead of a name
procedure Open_Unactivated_Class (Class_Object_Name : String;
H : in out Handle;
Update : Boolean := False;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
--
-- Open the named object which must be a class object that is not
-- currently activated as the handle's main object.
--
-- Update indicates that the object is opened for update.
-- Update access to property values is further
-- controlled by the Edit_Acl_From mechanism.
--
-- If H is null, it is allocated on the specified Heap.
-- The object is opened using the Main_Slot entry in the handle.
procedure Re_Open_Main_Object_For_Update
(H : in out Handle; Errors : in out Simple_Status.Condition);
-- If the handle's main slot's object was open but not for update, close
-- it and re-open it for update. No-op if it was already opened for update.
-- An error will result if no object is open, or the object could not
-- be re-opened.
procedure Open (Object : String;
Slot : Slot_Id;
H : in out Handle;
Action_Id : Action.Id := Action.Null_Id;
Heap : System.Segment := Job_Segment.Get;
Errors : in out Simple_Status.Condition);
--
-- Open the named object which must be a Gateway object or class.
-- The object may then be referenced by H and Slot.
--
-- The handle H may already designate one or more open objects.
-- The new one is placed in the specified slot which must not already
-- be in use.
--
-- If H is null, it is allocated on the specified Heap.
procedure Open_Object (Object : String;
Slot : Slot_Id;
H : Handle;
Action_Id : Action.Id := Action.Null_Id;
Errors : in out Simple_Status.Condition);
-- Exactly identical to Open, but with H as an "in" parameter and
-- already allocated. Modifies H's data because Handle is an access type.
--------------------------------------------------------------
--
-- Operations to read and update Gateway property values.
--
--------------------------------------------------------------
function Value (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot;
Subobject : String := "") return String;
--
-- Return the value of the named property (Name) from the designated
-- gateway object (H). If Subobject /= "", then the property of the
-- thus-named subobject is returned. The value returned is the "raw"
-- value stored in the object; it is not processed (to resolve
-- indirection or other value conventions). To read processed
-- values, use package Gateway_Property.
-- H may have more than one open object in it. The value is read from the
-- one designated by Slot.
-- Exceptions raised:
-- Undefined_Property_Name if the property is undefined;
-- No_Open_Object if the handle's Slot specifies no open object.
No_Open_Object : exception;
Undefined_Property_Name : exception;
procedure Set_Value (H : Handle;
Property_Name : String;
Subobject : String := "";
New_Value : String);
-- Set the value of property Name in gateway object H to New_Value.
-- If Subobject /= "", then set the value of property Name for the
-- specified subobject. The New_Value is placed into the object
-- as is for a string value or New_Value is illegal for the property's type,
-- or with some processing depending on the object's type.
-- H may have more than one open object in it. Only the main object
-- can be updated. It must have been opened for update for this operation
-- to be successful.
-- Does NOT do access checking; this must be done by the caller.
-- Exceptions raised:
-- No_Open_Object if the handle specifies no open object;
-- Not_Open_For_Update if the object was opened with update := false;
-- Property_Cant_Be_Changed if the property was defined to be constant.
-- Undefined_Property_Name if the property is undefined;
Not_Open_For_Update : exception;
Property_Cant_Be_Changed : exception;
Illegal_Property_Value : exception;
function Class_Name (H : Handle; Slot : Slot_Id := Main_Slot) return String;
-- Returns the gateway class name of the object opened in the handle's
-- specified slot; raises No_Open_Object if none
function Action_Id (H : Handle) return Action.Id;
-- Returns the action_id current in use by H
function Object_Name
(H : Handle; Slot : Slot_Id := Main_Slot) return String;
-- Returns name of the object opened in the handle's specified slot;
-- "" if none
function Directory_Object
(H : Handle; Slot : Slot_Id := Main_Slot) return Dir.Object;
-- Returns the object opened in the handle's specified slot;
-- Dir.Nil if none
function Slot_For_Object (H : Handle; Object : Dir.Object) return Slot_Id;
-- If Object is open in one or more of handle's slots, return the id of
-- the first slot containing object; else, return Null_Slot
function Is_Object_Open
(H : Handle; Slot : Slot_Id := Main_Slot) return Boolean;
-- Returns true iff an object is open in the handle's specified slot
function Is_Main_Object_Open_For_Update (H : Handle) return Boolean;
-- Returns true iff the handle's main slot's object is open for update
function Is_Class_Object
(H : Handle; Slot : Slot_Id := Main_Slot) return Boolean;
-- Returns true iff the object in the specified slot is a class object
procedure Get_Class_Id
(H : Handle; Index : out Natural; Serial_Number : out Natural);
-- Return the class id numbers of the class of the main object in
-- handle H. This is mainly of use by internal packages.
generic
with procedure Visit (Property_Name : String;
Subobject : String;
Property_Type : Type_Id;
Value : String);
-- Each call to Visit specifies the property's name, subobject,
-- value, and type.
procedure Traverse (H : Handle; Slot : Slot_Id := Main_Slot);
-- Call Visit for each of the property values defined in H's specified slot.
-- iterators for reading all enumeration types for a class:
type Enumeration_Type_Iterator is limited private;
procedure Init (Iter : out Enumeration_Type_Iterator; H : Handle);
-- Starts iterating over enumeration types for class of main object opened
-- in handle. Done (Iter) will be true if error occurred.
procedure Next (Iter : in out Enumeration_Type_Iterator);
function Value (Iter : Enumeration_Type_Iterator) return Type_Id;
function Done (Iter : Enumeration_Type_Iterator) return Boolean;
-- iterators for reading all enumeration literals for a enumeration type:
type Enumeration_Literal_Iterator is limited private;
procedure Init (Iter : out Enumeration_Literal_Iterator;
H : Handle;
Id : Type_Id);
-- Starts iterating over enumeration literals for enumeration type id of
-- main object opened in handle. Done (Iter) will be true if error occurred.
procedure Next (Iter : in out Enumeration_Literal_Iterator);
function Value (Iter : Enumeration_Literal_Iterator) return String;
-- enumeration literal, capitalized with no punctuation
function Done (Iter : Enumeration_Literal_Iterator) return Boolean;
function Type_Info (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot;
Subobject : String := "") return Type_Id;
-- Return the type of the specified property in the specified object
-- in the handle.
function Property_Options_Image (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return String;
-- return an image of the property options for the specified
-- property in the specified object in the handle.
-- queries for individual options:
function Is_Constant (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the IS_CONSTANT option for the specified property in the handle's
-- specified object.
function Editable (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the EDITABLE option for the specified property in the handle's
-- specified object.
function Non_Display (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the NON_DISPLAY option for the specified property in the handle's
-- specified object.
function Never_Display (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the NEVER_DISPLAY option for the specified property in the handle's
-- specified object.
function No_Inherit (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the NO_INHERIT option for the specified property in the handle's
-- specified object.
function No_Eval (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return Boolean;
-- Return the NO_EVAL option for the specified property in the handle's
-- specified object.
function Edit_Acl_From (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return String;
-- Return the EDIT_ACL_FROM option for the specified property in the
-- handle's specified object.
function Help_Text (H : Handle;
Property_Name : String;
Slot : Slot_Id := Main_Slot) return String;
-- Return the HELP_TEXT option for the specified property in the
-- handle's specified object.
function Type_Def (H : Handle; Id : Type_Id) return String;
-- Return an image of the type information for the specified type, as
-- defined for the gateway class of H's main slot's object.
-- Raise Undefined_Type_Id if Id is out-of-range or not defined in the
-- class.
function Type_Name (H : Handle; Id : Type_Id) return String;
-- Return the name for the specified type, as defined for the gateway
-- class of H's main slot's object.
-- Raise Undefined_Type_Id if Id is out-of-range or not defined in the
-- class.
Undefined_Type_Id : exception;
function Property_Value_Image (H : Handle;
Property_Name : String;
Id : Type_Id;
Image : String) return String;
-- Returns Image formatted for its type.
-- Raises Undefined_Type_Id if Id not defined in the class designated by H.
-- Raises Illegal_Property_Value if invalid image for type.
-- uses property_name in semantic checking of indirections
-- Returns Image formatted for its type.
-- Raises Undefined_Type_Id if Id not defined in the class designated by H.
-- Raises Illegal_Property_Value if invalid image for type.
procedure Close (H : Handle);
-- Changes do not become permanent until the object is closed or committed.
-- If you know that only objects placed into the handle via the
-- Make_... procedures contain changes, then you can commit those
-- objects and not bother with this call, but this is not advised.
procedure Close (H : Handle; Errors : in out Simple_Status.Condition);
-- same as above close, but returns status
procedure Commit (H : Handle;
Re_Open_For_Update : Boolean;
Errors : in out Simple_Status.Condition);
-- Commits and closes all opened objects in the handle and re-opens them.
-- If Re_Open_For_Update, opens the main object for update.
procedure Release_Slot (H : Handle;
Slot : Slot_Id;
Errors : in out Simple_Status.Condition);
-- Closes the object in just the specified slot and release it.
-- Implementation actually closes all the handle's objects and re-opens
-- all but the one in slot.
-- If Object is open in one of handle's slots, return the slot's id;
-- else, return Null_Slot
pragma Subsystem (Tools_Integration);
pragma Module_Name (4, 3995);
pragma Bias_Key (29);
private
type Handle_Data;
type Handle is access Handle_Data;
pragma Segmented_Heap (Handle);
-- type Handle_Data is roughly:
-- handles : array (1..max) of polymorphic_io.handle;
-- opens : 0..max
Null_Handle : constant Handle := null;
--
type Enumeration_Type_Iterator_Value;
type Enumeration_Type_Iterator is access Enumeration_Type_Iterator_Value;
type Enumeration_Literal_Iterator_Value;
type Enumeration_Literal_Iterator is
access Enumeration_Literal_Iterator_Value;
end Gateway_Object;
nblk1=21
nid=0
hdr6=42
[0x00] rec0=1e rec1=00 rec2=01 rec3=030
[0x01] rec0=1a rec1=00 rec2=02 rec3=066
[0x02] rec0=00 rec1=00 rec2=21 rec3=006
[0x03] rec0=13 rec1=00 rec2=03 rec3=02e
[0x04] rec0=15 rec1=00 rec2=04 rec3=02c
[0x05] rec0=03 rec1=00 rec2=20 rec3=012
[0x06] rec0=13 rec1=00 rec2=05 rec3=068
[0x07] rec0=01 rec1=00 rec2=1f rec3=018
[0x08] rec0=13 rec1=00 rec2=06 rec3=028
[0x09] rec0=11 rec1=00 rec2=07 rec3=07e
[0x0a] rec0=10 rec1=00 rec2=08 rec3=026
[0x0b] rec0=0e rec1=00 rec2=09 rec3=036
[0x0c] rec0=17 rec1=00 rec2=0a rec3=00e
[0x0d] rec0=12 rec1=00 rec2=0b rec3=078
[0x0e] rec0=17 rec1=00 rec2=0c rec3=05e
[0x0f] rec0=14 rec1=00 rec2=0d rec3=000
[0x10] rec0=13 rec1=00 rec2=0e rec3=060
[0x11] rec0=16 rec1=00 rec2=0f rec3=00c
[0x12] rec0=17 rec1=00 rec2=10 rec3=068
[0x13] rec0=18 rec1=00 rec2=11 rec3=04a
[0x14] rec0=00 rec1=00 rec2=1e rec3=012
[0x15] rec0=15 rec1=00 rec2=12 rec3=014
[0x16] rec0=19 rec1=00 rec2=13 rec3=088
[0x17] rec0=00 rec1=00 rec2=1d rec3=00e
[0x18] rec0=1a rec1=00 rec2=14 rec3=042
[0x19] rec0=17 rec1=00 rec2=15 rec3=038
[0x1a] rec0=17 rec1=00 rec2=16 rec3=052
[0x1b] rec0=17 rec1=00 rec2=17 rec3=060
[0x1c] rec0=14 rec1=00 rec2=18 rec3=084
[0x1d] rec0=16 rec1=00 rec2=19 rec3=014
[0x1e] rec0=19 rec1=00 rec2=1a rec3=008
[0x1f] rec0=11 rec1=00 rec2=1b rec3=07e
[0x20] rec0=1e rec1=00 rec2=1c rec3=000
tail 0x2170bb36e822a62acfe68 0x42a00088462065003