--| --|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; with errors_c; with error; with unchecked_deallocation; package body Pcte_contents is INVALID_FD : constant fildes := -1; BYTE_SIZE : constant standard.integer := 8; type path_ptr is access pcte.reference.pathname; STANDARD_INPUT_HANDLE : constant handle := new handle_rec'( fd => 0, contents => device, amode => read_only, nb_io => false, inherit => false, io_type => sequential, pos => 0); STANDARD_OUTPUT_HANDLE : constant handle := new handle_rec'( fd => 1, contents => device, amode => write_only, nb_io => true, inherit => false, io_type => sequential, pos => 0); STANDARD_ERROR_HANDLE : constant handle := new handle_rec'( fd => 2, contents => device, amode => write_only, nb_io => true, inherit => false, io_type => sequential, pos => 0); -- heap management routines procedure free is new unchecked_deallocation ( object => pcte.reference.pathname, name => path_ptr); -- 12.2.1 CONTENTS_CLOSE procedure close ( contents : in Pcte_contents.handle; status : in Pcte_error.handle := EXCEPTION_ONLY) is result : standard.integer; errno : standard.integer; tmp : handle := contents; begin result := pcte_1_5_int.close (integer (contents.fd)); if result < 0 then errno := errors_c.get_errno; if errno = errors_c.EBADF then error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); else error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); end if; else error.process_status_info (status, pcte_error.NO_ERROR, 0); tmp.fd := invalid_fd; -- need an assignment here to an in parameter; sets contents end if; end close; -- 12.2.2 CONTENTS_GET_FROM_KEY procedure get_from_key ( open_key : in Pcte.natural; contents : in out Pcte_contents.handle; status : in Pcte_error.handle := EXCEPTION_ONLY) is -- Pcte_contents.get_from_key can give rise to the binding-defined -- error condition CONTENTS_HANDLE_IS_OPEN(contents). begin null; -- STUB end get_from_key; -- 12.2.3 CONTENTS_GET_KEY function get_key ( contents : Pcte_contents.handle; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.natural is dummy : Pcte.natural := 0; begin return dummy; -- STUB end get_key; -- 12.2.4 CONTENTS_GET_POSITION function get_position ( contents : Pcte_contents.handle; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte_contents.position_handle is pos : standard.integer; errno : standard.integer; begin pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), 0, pcte_1_5_int.SEEK_CUR); if pos < 0 then errno := errors_c.get_errno; error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); return 0; else error.process_status_info (status, pcte_error.NO_ERROR); return pcte_contents.position_handle (pos); end if; end get_position; -- 12.2.5 CONTENTS_OPEN procedure open ( object : in Pcte.object_reference; opening_mode : in Pcte_contents.opening_mode; non_blocking_io : in Pcte.boolean; inheritable : in Pcte.boolean; contents : in out Pcte_contents.handle; status : in Pcte_error.handle := EXCEPTION_ONLY) is use pcte_1_5_int; use errors_c; fd : fildes; path : path_ptr; oflag : standard.integer; errno : standard.integer; begin path := new pcte.reference.pathname'( pcte.reference.get_path (object) & ascii.nul); case opening_mode is when READ_ONLY => oflag := O_RDONLY; when WRITE_ONLY => oflag := O_WRONLY; when APPEND => oflag := O_WRONLY + O_APPEND; when READ_WRITE => oflag := O_RDWR; end case; if non_blocking_io then oflag := oflag + O_NDELAY; end if; -- we might have to do something with inheritable; don't know what fd := fildes (pcte_1_5_int.open (path (path'first)'address, oflag)); if fd < 0 then -- we've got an error errno := errors_c.get_errno; case errno is when EINVAL => error.process_status_info ( status, pcte_error.OPENING_MODE_IS_INVALID, errno); when ENFILE | EMFILE => error.process_status_info ( status, pcte_error.LIMIT_WOULD_BE_EXCEEDED, errno); when others => error.process_status_info ( status, pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT, errno); end case; return; end if; error.process_status_info (status, pcte_error.NO_ERROR); contents := new handle_rec'( fd => fd, contents => pcte_contents.file, amode => opening_mode, nb_io => non_blocking_io, inherit => inheritable, io_type => sequential, pos => 0); free (path); end open; -- 12.2.6 CONTENTS_READ --generic -- type element_type is private ; function read ( contents : Pcte_contents.handle; size : Pcte.natural; status : Pcte_error.handle := EXCEPTION_ONLY) return element_type is -- I'll treat this generic as though it were reading non array data. -- In this case the size parameter is not needed. The size will be -- the size of element_type. There should probably be another generic -- for arrays which uses size and returns an array of element_type. data : element_type; nbytes : standard.integer; errno : standard.integer; begin nbytes := pcte_1_5_int.read ( standard.integer (contents.fd), data'ADDRESS, standard.integer (data'SIZE / BYTE_SIZE)); if nbytes < 0 then errno := errors_c.get_errno; case errno is when errors_c.EAGAIN | errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when errors_c.EIO | errors_c.ENXIO => error.process_status_info ( status, pcte_error.DATA_ARE_NOT_AVAILABLE, errno); when others => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); end case; else error.process_status_info (status, pcte_error.NO_ERROR); end if; return data; -- the application will have to determine if data is useful end read; procedure read_s ( contents : Pcte_contents.handle; size : Pcte.natural; buf : in out Pcte.string; act_size : out Pcte.natural; status : Pcte_error.handle := EXCEPTION_ONLY) is nbytes : standard.integer; errno : standard.integer; begin if size > pcte.natural (buf'length) then error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID ); act_size := 0; return; end if; nbytes := pcte_1_5_int.read ( standard.integer (contents.fd), buf (buf'FIRST)'ADDRESS, standard.integer (size)); if nbytes < 0 then errno := errors_c.get_errno; case errno is when errors_c.EAGAIN | errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when errors_c.EIO | errors_c.ENXIO => error.process_status_info ( status, pcte_error.DATA_ARE_NOT_AVAILABLE, errno); when others => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); end case; else error.process_status_info (status, pcte_error.NO_ERROR); act_size := Pcte.natural (nbytes); end if; end read_s; -- 12.2.7 CONTENTS_SEEK procedure seek ( contents : in Pcte_contents.handle; offset : in Pcte.integer; whence : in Pcte_contents.whence; status : in Pcte_error.handle := EXCEPTION_ONLY) is c_whence : pcte_1_5_int.whence; pos : standard.integer; errno : standard.integer; begin case whence is when AT_BEGINNING => c_whence := pcte_1_5_int.SEEK_SET; when AT_CURRENT => c_whence := pcte_1_5_int.SEEK_CUR; when AT_END => c_whence := pcte_1_5_int.SEEK_END; end case; pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), pcte_1_5_int.off_t (offset), c_whence); if pos < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EINVAL => error.process_status_info ( status, pcte_error.POSITIONING_IS_INVALID, errno); when errors_c.ESPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => null; -- this should not happen end case; else error.process_status_info (status, pcte_error.NO_ERROR); end if; -- pos < 0 end seek; -- 12.2.8 CONTENTS_SET_POSITION procedure set_position ( contents : in Pcte_contents.handle; position : in Pcte_contents.position_handle; set_mode : in Pcte_contents.set_mode; status : in Pcte_error.handle := EXCEPTION_ONLY) is pos : standard.integer; errno : standard.integer; begin case set_mode is when AT_BEGINNING => pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), 0, pcte_1_5_int.SEEK_SET); when AT_POSITION => pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), pcte_1_5_int.off_t (position), pcte_1_5_int.SEEK_SET); when AT_END => pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), 0, pcte_1_5_int.SEEK_END); end case; if pos < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EINVAL => error.process_status_info ( status, pcte_error.POSITION_HANDLE_IS_INVALID, errno); when errors_c.ESPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => null; -- this won't happen end case; else error.process_status_info (status, pcte_error.NO_ERROR); --contents.pos := pcte_contents.position_handle (pos); -- this is not reliable; use lseek to query end if; end set_position; -- 12.2.9 CONTENTS_SET_PROPERTIES procedure set_properties ( contents : in Pcte_contents.handle; positioning : in Pcte_contents.positioning; status : in Pcte_error.handle := EXCEPTION_ONLY) is use pcte_1_5_int; result : standard.integer; errno : standard.integer; buf : pcte_1_5_int.obj_stat_rec; tmp : handle := contents; begin if contents.fd = invalid_fd then error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN ); elsif contents.contents = pipe then error.process_status_info ( status, pcte_error.POSITIONING_IS_INVALID ); elsif contents.contents = file then result := pcte_1_5_int.getobjfstat ( standard.integer (contents.fd), buf'ADDRESS); if result < 0 then errno := errors_c.get_errno; if errno = errors_c.EBADF then error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); else raise constraint_error; end if; elsif buf.o_size /= pcte_1_5_int.off_t (0) then error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_EMPTY ); else -- christ, it must be good by now error.process_status_info (status, pcte_error.NO_ERROR); -- after all this error checking we ought to do something -- set positioning in contents via tmp pointer tmp.io_type := positioning; end if; else error.process_status_info (status, pcte_error.NO_ERROR); -- after all this error checking we ought to do something -- set positioning in contents via tmp pointer tmp.io_type := positioning; end if; end set_properties; -- 12.2.10 CONTENTS_TRUNCATE procedure truncate ( contents : in Pcte_contents.handle; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end truncate; -- 12.2.11 CONTENTS_WRITE --generic -- type element_type is private ; procedure write ( contents : in Pcte_contents.handle; size : in Pcte.natural; data : in element_type; actual_size : out Pcte.natural; status : in Pcte_error.handle := EXCEPTION_ONLY) is -- Again we ignore the size parameter in favor of using data'SIZE, -- and we assume that element_type is not an array. We will probably -- need to have a generic for arrays. nbytes : standard.integer := 0; errno : standard.integer; begin if data'SIZE > 0 then -- write only there is something to write -- not an error to write something of zero length nbytes := pcte_1_5_int.write ( standard.integer (contents.fd), data'ADDRESS, standard.integer (data'SIZE / BYTE_SIZE)); end if; if nbytes < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EFBIG => error.process_status_info ( status, pcte_error.LIMIT_WOULD_BE_EXCEEDED, errno); when errors_c.EINTR => error.process_status_info ( status, pcte_error.OPERATION_IS_INTERRUPTED, errno); when errors_c.ENOSPC => error.process_status_info ( status, pcte_error.DEVICE_SPACE_IS_FULL, errno); when errors_c.EPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when errors_c.ENXIO => error.process_status_info ( status, pcte_error.DEVICE_IS_UNKNOWN, errno); when errors_c.EAGAIN | errors_c.EIO => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); end case; -- if we haven't raised an exception return 0 to indicate no data -- was written. actual_size := 0; return; end if; -- okay, we have at least a partial write error.process_status_info (status, pcte_error.NO_ERROR); actual_size := Pcte.natural (nbytes); end write; procedure write_s ( contents : in Pcte_contents.handle; size : in Pcte.natural; data : in Pcte.string; act_size : out Pcte.natural; status : in Pcte_error.handle := EXCEPTION_ONLY) is nbytes : standard.integer := 0; errno : standard.integer; begin if size > 0 then -- write only there is something to write -- not an error to write something of zero length nbytes := pcte_1_5_int.write ( standard.integer (contents.fd), data (data'FIRST)'ADDRESS, standard.integer (size)); end if; if nbytes < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EFBIG => error.process_status_info ( status, pcte_error.LIMIT_WOULD_BE_EXCEEDED, errno); when errors_c.EINTR => error.process_status_info ( status, pcte_error.OPERATION_IS_INTERRUPTED, errno); when errors_c.ENOSPC => error.process_status_info ( status, pcte_error.DEVICE_SPACE_IS_FULL, errno); when errors_c.EPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when errors_c.ENXIO => error.process_status_info ( status, pcte_error.DEVICE_IS_UNKNOWN, errno); when errors_c.EAGAIN | errors_c.EIO => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); end case; -- if we haven't raised an exception return 0 to indicate no data -- was written. act_size := 0; return; end if; -- okay, we have at least a partial write error.process_status_info (status, pcte_error.NO_ERROR); act_size := Pcte.natural (nbytes); end write_s; function end_of_contents ( contents : in Pcte_contents.handle; status : in Pcte_error.handle := EXCEPTION_ONLY) return Pcte.boolean is pos : standard.integer; end_pos : standard.integer; reset_pos : standard.integer; errno : standard.integer; begin -- get the original position pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), 0, pcte_1_5_int.SEEK_CUR); if pos < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EINVAL => error.process_status_info ( status, pcte_error.POSITION_HANDLE_IS_INVALID, errno); when errors_c.ESPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => null; -- this won't happen end case; return true; end if; -- get the end position end_pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), 0, pcte_1_5_int.SEEK_END); if end_pos < 0 then errno := errors_c.get_errno; case errno is when errors_c.EBADF => error.process_status_info ( status, pcte_error.CONTENTS_IS_NOT_OPEN, errno); when errors_c.EINVAL => error.process_status_info ( status, pcte_error.POSITION_HANDLE_IS_INVALID, errno); when errors_c.ESPIPE => error.process_status_info ( status, pcte_error.CONTENTS_OPERATION_IS_INVALID, errno); when others => null; -- this won't happen end case; return true; end if; error.process_status_info (status, Pcte_error.NO_ERROR); -- now compare the two to see if we're at the end making sure to -- to reposition the file in its original position if end_pos = pos then reset_pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), pcte_1_5_int.off_t (pos), pcte_1_5_int.SEEK_SET); return true; else reset_pos := pcte_1_5_int.lseek ( standard.integer (contents.fd), pcte_1_5_int.off_t (pos), pcte_1_5_int.SEEK_SET); return false; end if; end end_of_contents; -- 18.3.1 CONTENTS_COPY_FROM_FOREIGN_SYSTEM procedure copy_from_foreign_system ( file : in Pcte.object_reference; foreign_system : in Pcte.object_reference; foreign_name : in Pcte.string; foreign_parameters : in Pcte.string; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end copy_from_foreign_system; -- 18.3.1 CONTENTS_COPY_TO_FOREIGN_SYSTEM procedure copy_to_foreign_system ( file : in Pcte.object_reference; foreign_system : in Pcte.object_reference; foreign_name : in Pcte.string; foreign_parameters : in Pcte.string; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end copy_to_foreign_system; procedure standard_input (contents : in out Pcte_contents.handle) is begin contents := STANDARD_INPUT_HANDLE; end standard_input; procedure standard_output (contents : in out Pcte_contents.handle) is begin contents := STANDARD_OUTPUT_HANDLE; end standard_output; procedure standard_error (contents : in out Pcte_contents.handle) is begin contents := STANDARD_ERROR_HANDLE; end standard_error; end Pcte_contents;