--| --|Item: Ada PCTE Binding --|$Revision: 0.2 $ --|$State: Prototype $ --| --|The Version Description Document (VDD) included with this release provides --|detailed information regarding the condition of the software. The "User --|Feedback" section of the VDD describes how to obtain additional information. --| --|Distribution Statement "A", per DoD Directive 5230.24 --|Authorized for public release; distribution is unlimited. --| --|Copyright (c) 1992, Paramax Systems Corporation, Reston, Virginia --|Copyright is assigned to the U.S. Government, upon delivery thereto, --|in accordance with the DFAR Special Works Clause. --| --|Developed by: Paramax Systems Corporation, --| --|This software, developed under the Software Technology for Adaptable, --|Reliable Systems (STARS) program, is approved for release under --|Distribution "A" of the Scientific and Technical Information Program --|Classification Scheme (DoD Directive 5230.24) unless otherwise indicated. --|Sponsored by the U.S. Defense Advanced Research Projects Agency (DARPA) --|under contract F19628-88-D-0031, the STARS program is supported by the --|military services, SEI, and MITRE, with the U.S. Air Force as the executive --|contracting agent. --| --|Permission to use, copy, modify, and comment on this software and its --|documentation for purposes stated under Distribution "A" and without fee --|is hereby granted, provided that this notice appears in each whole or --|partial copy. This software retains Contractor indemnification to --|the Government regarding copyrights pursuant to the above referenced --|STARS contract. The Government disclaims all responsibility against --|liability, including costs and expenses for violation of proprietary --|rights, or copyrights arising out of the creation or use of this --|software. --| --|In addition, the Government, Paramax, and its subcontractors disclaim all --|warranties with regard to this software, including all implied warranties --|of merchantability and fitness, and in no event shall the Government, --|Paramax, or its subcontractor(s) be liable for any special, indirect or --|consequential damages or any damages whatsoever resulting from the loss of --|use, data, or profits, whether in action of contract, negligence or other --|tortious action, arising in connection with the use or performance of this --|software. --| --|$Log $ --| -- Version Information -- ^^^^^^^^^^^^^^^^^^^ -- -- PCTE - Ada Language Interface. -- Version: 0.2. -- Release Date: November 30, 1992. -- Compiled under SUN OS 4.1.2 using SunAda 1.0 -- -- -- General Information -- ^^^^^^^^^^^^^^^^^^^ -- -- This is an alpha release of the Paramax STARS Ada binding to Emeraude's -- PCTE 1.5 using the ECMA PCTE Ada binding specifications. The binding -- is incomplete in this release. See the Version Description Document -- provided with this alpha release for information on which interfaces -- have been implemented. It is expected that future releases will -- expand the number of interfaces implemented. The interfaces defined -- herein are subject to change. -- -- For further information, contact the authors: -- -- -- Robert Smith -- Paramax Systems Corp. -- Valley Forge Labs -- 70 E. Swedesford Road -- Paoli, PA. 19301 -- smith@prc.unisys.com (current) -- smith@vfl.paramax.com (future) -- +1 215 648-2402 -- -- Michael Horton -- Paramax Systems Corp. -- Valley Forge Labs -- 70 E. Swedesford Road -- Paoli, PA. 19301 -- horton@prc.unisys.com (current) -- horton@vfl.paramax.com (future) -- +1 215 648-2527 -- -- with pcte_1_5_int; use pcte_1_5_int; with pcte_1_5_support; use pcte_1_5_support; with errors_c; with error; with emer_conversion; with system; with text_io; package body Pcte_object is type pathname_ptr is access Pcte.reference.pathname; -- 9.3.1 OBJECT_CHECK_TYPE function check_type ( object : Pcte.object_reference; pcte_type : Pcte.type_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte_object.type_ancestry is dummy : Pcte_Object.type_ancestry := UNRELATED; begin return dummy; -- STUB end check_type; -- 9.3.2 OBJECT_CONVERT procedure convert ( object : in Pcte.object_reference; pcte_type : in Pcte.type_reference; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end convert; -- 9.3.3 OBJECT_COPY -- The effect of not providing the optional on_same_volume_as -- parameter is achieved by the first overloaded subprogram. The -- effect of not providing the optional reverse_key parameter is -- achieved by providing the empty string. procedure copy ( object : in Pcte.object_reference; new_origin : in Pcte.object_reference; new_link : in Pcte.link_reference; access_mask : in Pcte_discretionary.object.access_rights; new_object : in out Pcte.object_reference; reverse_key : in Pcte.key := ""; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end copy; procedure copy ( object : in Pcte.object_reference; new_origin : in Pcte.object_reference; new_link : in Pcte.link_reference; access_mask : in Pcte_discretionary.object.access_rights; new_object : in out Pcte.object_reference; on_same_volume_as : in Pcte.object_reference; reverse_key : in Pcte.key := ""; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end copy; -- 9.3.4 OBJECT_CREATE -- The effect of not providing the optional on_same_volume_as -- parameter is achieved by the first overloaded subprogram. The -- effect of not providing the optional reverse_key parameter is -- achieved by providing the empty string. procedure create ( pcte_type : in Pcte.type_reference; new_origin : in Pcte.object_reference; new_link : in Pcte.link_reference; access_mask : in Pcte_discretionary.object.access_rights; new_object : in out Pcte.object_reference; reverse_key : in Pcte.key := ""; status : in Pcte_error.handle := EXCEPTION_ONLY) is use errors_c; c_type_ref : Pcte.type_reference (pcte_type'FIRST .. pcte_type'LAST + 1) := pcte_type & ascii.nul; result : standard.integer; mode : standard.integer := emer_conversion.emer_access_mode (access_mask); link_name : Pcte.link_reference (new_link'FIRST .. new_link'LAST + 1) := new_link & ascii.nul; origin_path : constant Pcte.reference.pathname := Pcte.reference.get_path (new_origin); c_orig_path : Pcte.reference.pathname (1 .. origin_path'LENGTH + 1) := origin_path & ascii.nul; c_rev_key : Pcte.string (reverse_key'FIRST .. reverse_key'LAST + 1) := reverse_key & ascii.nul; errno : standard.integer; err_msg : pcte_error.error_code; begin if reverse_key = "" then result := pcte_1_5_int.crobj ( c_orig_path (c_orig_path'FIRST)'ADDRESS, link_name (link_name'FIRST)'ADDRESS, c_type_ref (c_type_ref'FIRST)'ADDRESS, mode ); else result := pcte_1_5_int.crobjr ( c_orig_path (c_orig_path'FIRST)'ADDRESS, link_name (link_name'FIRST)'ADDRESS, c_type_ref (c_type_ref'FIRST)'ADDRESS, mode, c_rev_key (c_rev_key'FIRST)'ADDRESS ); end if; if result < 0 then errno := errors_c.get_errno; case errno is when EREFOBJ | ENOLINK | ETYPEREF | ENOMOUNT | EACCES => err_msg := pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT; when ECATEGORY => err_msg := pcte_error.CATEGORY_IS_BAD; when EROV | EMASTER | ECOPY | EPERM | ESTABLE => err_msg := pcte_error.USAGE_MODE_ON_LINK_TYPE_WOULD_BE_VIOLATED; when ELTYPE | EKEY => err_msg := pcte_error.REVERSE_KEY_IS_BAD; when EEXIST => err_msg := pcte_error.LINK_EXISTS; when EOTYPE => err_msg := pcte_error.OBJECT_TYPES_MISMATCH; when EINVAL => err_msg := pcte_error.OBJECT_TYPE_IS_INVALID; when ENOSPC => err_msg := pcte_error.UPPER_BOUND_WOULD_BE_VIOLATED; when others => err_msg := pcte_error.NO_ERROR; end case; error.process_status_info (status, err_msg, errno); return; end if; -- result < 0 error.process_status_info (status); Pcte.reference.set_relative ( new_object, new_origin, Pcte.reference.ON_FIRST_USE, Pcte.reference.pathname (new_link), status ); end create; procedure create ( pcte_type : in Pcte.type_reference; new_origin : in Pcte.object_reference; new_link : in Pcte.link_reference; access_mask : in Pcte_discretionary.object.access_rights; new_object : in out Pcte.object_reference; on_same_volume_as : in Pcte.object_reference; reverse_key : in Pcte.key := ""; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end create; -- 9.3.5 OBJECT_DELETE procedure delete ( object : in Pcte.object_reference; link : in Pcte.link_reference; status : in Pcte_error.handle := EXCEPTION_ONLY) is use errors_c; use Pcte; origin : constant Pcte.reference.pathname := Pcte.reference.get_path (object); c_origin : Pcte.reference.pathname (1 .. origin'LENGTH + 1) := origin & ascii.nul; c_link : Pcte.link_reference (1 .. link'LENGTH + 1) := link & ascii.nul; result : standard.integer; errno : standard.integer := 0; err_msg : pcte_error.error_code := pcte_error.NO_ERROR; begin if origin'LENGTH = 0 then error.process_status_info (status, Pcte_error.UNDEFINED_REFERENCE, 0); return; end if; result := pcte_1_5_int.dllink ( c_origin (c_origin'FIRST)'ADDRESS, c_link (c_link'FIRST)'ADDRESS); if result < 0 then errno := errors_c.get_errno; case errno is when EREFOBJ | ENOLINK | ENOMOUNT | EFAULT | EACCES => err_msg := Pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT; when ECATEGORY => err_msg := Pcte_error.CATEGORY_IS_BAD; when ETYPEREF | EPERM | ELTYPE => err_msg := Pcte_error.LINK_TYPE_IS_INVALID; when EMASTER | ECOPY | EROV => err_msg := Pcte_error.DESTINATION_OBJECT_TYPE_IS_INVALID; when EDEL => err_msg := Pcte_error.OBJECT_HAS_EXTERNAL_LINKS_PREVENTING_DELETION; when ETXTBSY => err_msg := Pcte_error.OBJECT_IS_IN_USE; when others => err_msg := Pcte_error.OBJECT_IS_INACCESSIBLE; end case; end if; error.process_status_info (status, err_msg, errno); end delete; -- 9.3.6 OBJECT_GET_ATTRIBUTE -- OBJECT_GET_ATTRIBUTE is mapped to overloaded versions of the function -- Pcte_object.get_attribute, one for each possible type of the result. -- If the type of the result of the particular overloaded function -- that is used is different from the type of its parameter attribute, -- then the error VALUE_TYPE_IS_INVALID is raised. function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.boolean is use pcte_1_5_int; use errors_c; attr_kind : u_short; boolean_value : short; c_attribute : constant string := string (attribute) & ascii.nul; c_object_path : constant string := pcte.reference.get_path (object, status) & ascii.nul; return_code : standard.integer; -- attrval is a stand-in for a C union paramter: attrval : system.address := boolean_value'ADDRESS; begin attr_kind := attr_type_of (object, string (attribute)); if attr_kind = V_BOOLEAN then return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, c_attribute (c_attribute'FIRST)'ADDRESS, 2, attrval'ADDRESS); if return_code = 0 then error.process_status_info (status); if boolean_value /= 0 then return true; else return false; end if; end if; end if; error.process_status_info (status, pcte_error.VALUE_TYPE_IS_INVALID, errors_c.get_errno); return false; -- ??? end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.natural is use pcte_1_5_int; use errors_c; attr_kind : u_short; integer_value : long; c_attribute : constant string := string (attribute) & ascii.nul; c_object_path : constant string := pcte.reference.get_path (object) & ascii.nul; return_code : standard.integer; -- attrval is a stand-in for a C union paramter: attrval : system.address := integer_value'ADDRESS; begin attr_kind := attr_type_of (object, string (attribute)); if attr_kind = V_INT then return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, c_attribute (c_attribute'FIRST)'ADDRESS, 4, attrval'ADDRESS); if return_code = 0 and then integer_value > 0 then error.process_status_info (status); return Pcte.natural (integer_value); end if; end if; error.process_status_info (status, pcte_error.VALUE_TYPE_IS_INVALID, errors_c.get_errno); return 0; -- ??? end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.integer is use pcte_1_5_int; use errors_c; attr_kind : u_short; integer_value : long; c_attribute : constant string := string (attribute) & ascii.nul; c_object_path : constant string := pcte.reference.get_path (object) & ascii.nul; return_code : standard.integer; -- attrval is a stand-in for a C union paramter: attrval : system.address := integer_value'ADDRESS; begin attr_kind := attr_type_of (object, string (attribute)); if attr_kind = V_INT then return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, c_attribute (c_attribute'FIRST)'ADDRESS, 4, attrval'ADDRESS); if return_code = 0 then error.process_status_info (status); return Pcte.integer (integer_value); end if; end if; error.process_status_info (status, pcte_error.VALUE_TYPE_IS_INVALID, errors_c.get_errno); return 0; -- ??? end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.float is dummy : Pcte.float := 0.0; begin return dummy; -- STUB end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.calendar.time is dummy : Pcte.calendar.time; begin return dummy; -- STUB end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.string is use pcte_1_5_int; use errors_c; attr_kind : u_short; string_value : string (1 .. STRATTRSIZE); c_attribute : constant string := string (attribute) & ascii.nul; c_object_path : constant string := pcte.reference.get_path (object) & ascii.nul; return_code : standard.integer; -- attrval is a stand-in for a C union paramter: attrval : system.address := string_value(1)'ADDRESS; begin attr_kind := attr_type_of (object, string (attribute)); if attr_kind = V_STRING then return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, c_attribute (c_attribute'FIRST)'ADDRESS, STRATTRSIZE, attrval'ADDRESS); if return_code >= 0 then return string_value (1 .. return_code); end if; end if; error.process_status_info (status, pcte_error.VALUE_TYPE_IS_INVALID, errors_c.get_errno); return ""; -- ??? end get_attribute; function get_attribute ( object : Pcte.object_reference; attribute : Pcte.attribute_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.enumeration_item is dummy : constant Pcte.enumeration_item := ""; begin return dummy; -- STUB end get_attribute; -- 9.3.7 OBJECT_GET_PREFERRED_KEY function get_preferred_key ( object : Pcte.object_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.string is dummy : constant Pcte.string := ""; begin return dummy; -- STUB end get_preferred_key; -- 9.3.8 OBJECT_GET_SEVERAL_ATTRIBUTES -- These subprograms are construct subprograms for the datatype -- Pcte.attribute_assignments.sequence; -- any existing value of the in parameter is discarded. -- The effect of assigning IN_WORKING_SCHEMA to the parameter visibility -- is achieved by the first overloaded subprogram; -- the effect of assigning set of Attribute_designator to the -- parameter visibility is achieved by the second overloaded subprogram. procedure get_several_attributes ( object : in Pcte.object_reference; values : in out Pcte.attribute_assignments.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is c_object_path : constant string := pcte.reference.get_path (object) & ascii.nul; attr_defids : constant defid_array := pcte_1_5_support.attributes_of (object); attr_name : string (1 .. TYPENAMESIZE + 1); attr_name_size : integer; attr_type : u_short; attrs_with_problems : natural := 0; string_value : string (1 .. STRATTRSIZE); string_len : natural := 0; int_form_of_boolean : short; integer_value : standard.integer; boolean_value : boolean; attrval : system.address; return_code : standard.integer; procedure problem_with_attr (num : integer) is attr_value : constant Pcte.attribute_value := (type_is => UNTYPED, string_length => 0); attr_name_value_pair : constant Pcte.attribute_assignment := (type_is => UNTYPED, string_length => 0, attribute_length => attr_name_size, attribute => type_reference (attr_name (1 .. attr_name_size)), value => attr_value); begin Pcte.attribute_assignments.put (values, attr_name_value_pair, num); attrs_with_problems := attrs_with_problems + 1; end problem_with_attr; begin for i in attr_defids'RANGE loop attr_name_size := sdsdefname (system.no_addr, attr_defids (i)'ADDRESS, attr_name (attr_name'FIRST)'ADDRESS, attr_name'LENGTH); if attr_name_size > 0 then attr_type := pcte_1_5_support.attr_type_of (attr_defids (i).d_kind); case attr_type is when V_STRING => attrval := string_value (1)'ADDRESS; string_len := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, attr_name (attr_name'FIRST)'ADDRESS, STRATTRSIZE, attrval'ADDRESS); if string_len >= 0 then declare attr_value : constant Pcte.attribute_value := (type_is => STRING_TYPE, string_length => string_len, string_value => string_value (1 .. string_len)); attr_name_value_pair : constant Pcte.attribute_assignment := (type_is => STRING_TYPE, string_length => string_len, attribute_length => attr_name_size, attribute => type_reference (attr_name (1 .. attr_name_size)), value => attr_value); begin Pcte.attribute_assignments.put (values, attr_name_value_pair, i); end; else problem_with_attr (i); end if; when V_INT => attrval := integer_value'ADDRESS; return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, attr_name (attr_name'FIRST)'ADDRESS, 4, attrval'ADDRESS); if return_code = 0 then declare attr_value : constant Pcte.attribute_value := (type_is => INTEGER_TYPE, string_length => 0, integer_value => Pcte.integer (integer_value)); attr_name_value_pair : constant Pcte.attribute_assignment := (type_is => INTEGER_TYPE, string_length => 0, attribute_length => attr_name_size, attribute => type_reference (attr_name (1 .. attr_name_size)), value => attr_value); begin Pcte.attribute_assignments.put (values, attr_name_value_pair, i); end; else problem_with_attr (i); end if; when V_BOOLEAN => attrval := int_form_of_boolean'ADDRESS; return_code := getattr (c_object_path (c_object_path'FIRST)'ADDRESS, attr_name (attr_name'FIRST)'ADDRESS, 2, attrval'ADDRESS); if return_code = 0 then if int_form_of_boolean /= 0 then boolean_value := true; else boolean_value := false; end if; declare attr_value : constant Pcte.attribute_value := (type_is => BOOLEAN_TYPE, string_length => 0, boolean_value => boolean_value); attr_name_value_pair : constant Pcte.attribute_assignment := (type_is => BOOLEAN_TYPE, string_length => 0, attribute_length => attr_name_size, attribute => type_reference (attr_name (1 .. attr_name_size)), value => attr_value); begin Pcte.attribute_assignments.put (values, attr_name_value_pair, i); end; else problem_with_attr (i); end if; when V_DATE => -- TBD: date not currently supported problem_with_attr (i); when others => -- NOTE: this case should not arise. problem_with_attr (i); end case; else -- currently ignore any error number associated with an -- sdsdefname that was in error. problem_with_attr (i); end if; end loop; if attrs_with_problems = 0 then error.process_status_info (status); else error.process_status_info (status, Pcte_error.ATTRIBUTE_TYPE_IS_INVALID); end if; end get_several_attributes; procedure get_several_attributes ( object : in Pcte.object_reference; attributes : in Pcte.attribute_references.sequence; values : in out Pcte.attribute_assignments.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end get_several_attributes; -- 9.3.9 OBJECT_GET_TYPE function get_type ( object : Pcte.object_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.type_reference is type_defid : defid; c_object_path : constant string := string (Pcte.reference.get_path (object)) & ascii.nul; err_code : integer; name : string (1 .. TYPENAMESIZE + 1); errno : integer := 0; err_msg : pcte_error.error_code := Pcte_error.NO_ERROR; name_size : integer; use errors_c; begin if gettype (c_object_path (c_object_path'FIRST)'ADDRESS, type_defid'ADDRESS) = 0 then error.process_status_info (status); name_size := sdsdefname (system.no_addr, type_defid'ADDRESS, name (name'FIRST)'ADDRESS, name'LENGTH); if name_size > 0 then return Pcte.type_reference (name (name'FIRST .. name'FIRST + name_size - 1)); else return Pcte.type_reference (type_identifier_of_defid (type_defid)); end if; else errno := errors_c.get_errno; case errno is when EREFOBJ | ENOLINK | ETYPEREF | ENOMOUNT | ELTYPE => err_msg := pcte_error. PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT; -- ??? when EACCES => err_msg := pcte_error.OBJECT_IS_INACCESSIBLE; -- ??? when EINTR | EDEADLOCK => err_msg := pcte_error.OBJECT_IS_LOCKED; -- ??? when others => err_msg := pcte_error.NO_ERROR; -- ??? end case; error.process_status_info (status, err_msg, errno); return ""; end if; end get_type; -- 9.3.10 OBJECT_IS_COMPONENT function is_component ( object1 : Pcte.object_reference; object2 : Pcte.object_reference; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.boolean is dummy : Pcte.boolean := false; begin return dummy; -- STUB end is_component; -- 9.3.11 OBJECT_LIST_LINKS -- The effect of assigning ALL to the parameter visibility is -- achieved by one of the operations list_all_xxx_links. The -- effect of assigning IN_WORKING_SCHEMA to the parameter visibility is -- achieved by one of the operations list_visible_xxx_links. The -- effect of assigning a set of link type designators to the parameter -- visibility is achieved by one of the operations -- list_given_xxx_links. The effect of assigning INTERNAL to the -- parameter extent is is achieved by one of the operations -- list_yyy_internal_links. The effect of assigning EXTERNAL to the -- parameter extent is is achieved by one of the operations -- list_yyy_external_links. The effect of assigning ALL to the -- parameter extent is is achieved by one of the operations -- list_yyy_links. function link_type_name_of (link : string) return string is -- extract the link_type_name from within the specified link reference of -- the form: "key_value.link_type_name" begin -- make a special check for the system implicit link if link'LENGTH > 2 and then link (link'LAST - 1 .. link'LAST) = ".." then return "."; else for i in reverse link'range loop if link (i) = '.' then return link (i + 1 .. link'LAST); end if; end loop; return ""; -- indicates name not found end if; end link_type_name_of; procedure list_visible_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_visible_links; procedure list_visible_external_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_visible_external_links; procedure list_visible_internal_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_visible_internal_links; procedure list_given_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_given_links; procedure list_given_external_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_given_external_links; procedure list_given_internal_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_given_internal_links; procedure list_all_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is use Pcte_object; object_defid : defid; link_type : u_short; type_is_ok : boolean; err_msg : pcte_error.error_code; errno : standard.integer; return_code : standard.integer; begin -- first check for unsupported features: case extent is when INTERNAL | EXTERNAL => -- TBD: not currently supported error.process_status_info (status, pcte_error.UNIMPLEMENTED_FEATURE_ERROR, 0); when ALL_LINKS => null; end case; case scope is when COMPOSITE => -- TBD: not currently supported error.process_status_info (status, pcte_error.UNIMPLEMENTED_FEATURE_ERROR, 0); when ATOMIC => null; end case; declare c_object_path : constant string := pcte.reference.get_path (origin) & ascii.nul; linkstats : constant linkstat_array := pcte_1_5_support.links_of (origin); link_name : string (1 .. LINKSIZE + 1); link_length : natural; use errors_c; begin return_code := gettype (c_object_path'ADDRESS, object_defid'ADDRESS); if return_code /= 0 then errno := errors_c.get_errno; case errno is when EREFOBJ | ENOLINK | ETYPEREF | ENOMOUNT | ELTYPE => err_msg := pcte_error. PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT; -- ??? when EACCES => err_msg := pcte_error.OBJECT_IS_INACCESSIBLE; -- ??? when EINTR | EDEADLOCK => err_msg := pcte_error.OBJECT_IS_LOCKED; -- ??? when others => err_msg := pcte_error.NO_ERROR; -- ??? end case; error.process_status_info (status, err_msg, errno); return; end if; for i in linkstats'RANGE loop link_type := pcte_1_5_support.link_type_of (linkstats (i).l_def.d_kind); case link_type is when COMP => type_is_ok := categories (COMPOSITION_LINK); when REF => type_is_ok := categories (REFERENCE_LINK); when IMP | SREV => type_is_ok := categories (IMPLICIT_LINK); when others => type_is_ok := false; end case; if type_is_ok then return_code := linkname (object_defid'ADDRESS, linkstats (i)'ADDRESS, 0, link_name (1)'ADDRESS); if return_code = 0 then link_length := 0; for j in link_name'RANGE loop exit when link_name (j) = ascii.nul; link_length := link_length + 1; end loop; if Pcte.type_references.length_of (link_types) > 0 then -- since only specific link types are desired, assume -- for the moment that the current link does not match -- any of the desired type. type_is_ok := false; -- extract the link type name from the full link name for j in 1 .. Pcte.type_references.length_of (link_types) loop declare found_name : constant string := link_type_name_of (link_name (1 .. link_length)); desired_name : constant string := string (Pcte.type_references.get (link_types, Pcte.positive (j))); begin if found_name = desired_name then -- one of the link type names matches type_is_ok := true; exit; end if; end; end loop; end if; if type_is_ok then declare new_link : constant link_descriptor := (link_length => link_length, origin => origin, link => link_name (1 .. link_length)); begin Pcte_object.link_descriptors.put (links, new_link, i); end; end if; end if; end if; end loop; end; exception when others => error.process_status_info (status, pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT, 0); end list_all_links; procedure list_all_external_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_all_external_links; procedure list_all_internal_links ( origin : in Pcte.object_reference; extent : in Pcte_object.extent; scope : in Pcte.object_scope; categories : in Pcte.set_of_categories; link_types : in Pcte.type_references.sequence; links : in out Pcte_object.link_descriptors.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end list_all_internal_links; -- 9.3.12 OBJECT_MOVE procedure move ( object : in Pcte.object_reference; on_same_volume_as : in Pcte.object_reference; scope : in Pcte.object_scope; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end move; -- 9.3.13 OBJECT_SET_ATTRIBUTE -- OBJECT_SET_ATTRIBUTE is mapped to overloaded versions of the procedure -- Pcte_object.set_attribute, -- one for each possible type of the parameter value. -- If the type of the parameter value of the particular overloaded procedure -- that is used is different from the type of its parameter attribute, -- then the error VALUE_TYPE_IS_INVALID is raised. -- The effect of not supplying the optional parameter value is obtained -- by calling the procedure Pcte_object.reset_attribute. procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.boolean := FALSE; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end; -- Pcte_object.set_attribute, -- one for each possible type of the parameter value. -- If the type of the parameter value of the particular overloaded procedure -- that is used is different from the type of its parameter attribute, -- then the error VALUE_TYPE_IS_INVALID is raised. -- The effect of not supplying the optional parameter value is obtained -- by calling the procedure Pcte_object.reset_attribute. procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.natural := 0; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.integer := 0; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.float := 0.0; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.calendar.time := DEFAULT_TIME; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.string := ""; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure set_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; value : in Pcte.enumeration_item; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_attribute; procedure reset_attribute ( object : in Pcte.object_reference; attribute : in Pcte.attribute_reference; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end reset_attribute; -- 9.3.14 OBJECT_SET_PREFERENCE -- The effect of providing both the optional parameter type and the -- optional parameter key is obtained by the first overloaded -- subprogram. The effect of providing the optional parameter type -- and not providing the optional parameter key is obtained by the -- second overloaded subprogram. The effect of not providing the -- optional parameter type and providing the optional parameter key is -- obtained by the third overloaded subprogram. The effect of -- providing neither the optional parameter type nor the optional -- parameter key is obtained by the procedure -- Pcte_object.unset_preference. procedure set_preference ( object : in Pcte.object_reference; pcte_type : in Pcte.type_reference; key : in Pcte.key; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_preference; procedure set_preference ( object : in Pcte.object_reference; pcte_type : in Pcte.type_reference; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_preference; procedure set_preference ( object : in Pcte.object_reference; key : in Pcte.key; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_preference; procedure unset_preference ( object : in Pcte.object_reference; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end unset_preference; -- 9.3.15 OBJECT_SET_SEVERAL_ATTRIBUTES procedure set_several_attributes ( object : in Pcte.object_reference; attributes : in Pcte.attribute_assignments.sequence; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end set_several_attributes; -- 9.3.16 VOLUME_LIST_OBJECTS -- See 11.2. end Pcte_object;