------------------------------------------------------------------------------ -- -- -- FLORIST (FSU Implementation of POSIX.5) COMPONENTS -- -- -- -- P O S I X . I O -- -- -- -- B o d y -- -- -- -- -- -- Copyright (c) 1996-1998 Florida State University (FSU), -- -- All Rights Reserved. -- -- -- -- This file is a component of FLORIST, an implementation of an Ada API -- -- for the POSIX OS services, for use with the GNAT Ada compiler and -- -- the FSU Gnu Ada Runtime Library (GNARL). The interface is intended -- -- to be close to that specified in IEEE STD 1003.5: 1990 and IEEE STD -- -- 1003.5b: 1996. -- -- -- -- FLORIST is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. FLORIST is distributed in the hope that it will be -- -- useful, but WITHOUT ANY WARRANTY; without even the implied warranty -- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have received a -- -- copy of the GNU General Public License distributed with GNARL; see -- -- file COPYING. If not, write to the Free Software Foundation, 59 -- -- Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- ------------------------------------------------------------------------------ -- [$Revision: 1.5 $] -- ????? -- Perhaps we should put exception handlers around the critical -- sections in this code, in case Storage_Error is raised by one -- of the system calls within them? This would be a lot more overhead. with Ada.IO_Exceptions, System, POSIX.C, POSIX.Implementation, POSIX.Permissions, POSIX.Permissions.Implementation, Unchecked_Conversion; package body POSIX.IO is use POSIX.C, POSIX.Implementation, POSIX.Permissions.Implementation; function To_int is new Unchecked_Conversion (Bits, int); function To_Bits is new Unchecked_Conversion (int, Bits); function To_char_ptr is new Unchecked_Conversion (System.Address, char_ptr); function To_Address is new Unchecked_Conversion (char_ptr, System.Address); C_File_Mode : constant array (File_Mode) of Bits := (Read_Only => O_RDONLY, Write_Only => O_WRONLY, Read_Write => O_RDWR); C_Whence : constant array (Position) of int := (From_Beginning => SEEK_SET, From_End_Of_File => SEEK_END, From_Current_Position => SEEK_CUR); procedure Check_NNeg_And_Restore_Signals (Result : int; Masked_Signals : Signal_Masking; Old_Mask : access Signal_Mask); procedure Check_NNeg_And_Restore_Signals (Result : ssize_t; Masked_Signals : Signal_Masking; Old_Mask : access Signal_Mask); pragma Inline (Check_NNeg_And_Restore_Signals); procedure Check_NNeg_And_Restore_Signals (Result : int; Masked_Signals : Signal_Masking; Old_Mask : access Signal_Mask) is begin if Result < 0 then Restore_Signals_And_Raise_POSIX_Error (Masked_Signals, Old_Mask); else Restore_Signals (Masked_Signals, Old_Mask); end if; end Check_NNeg_And_Restore_Signals; procedure Check_NNeg_And_Restore_Signals (Result : ssize_t; Masked_Signals : Signal_Masking; Old_Mask : access Signal_Mask) is begin if Result < 0 then Restore_Signals_And_Raise_POSIX_Error (Masked_Signals, Old_Mask); else Restore_Signals (Masked_Signals, Old_Mask); end if; end Check_NNeg_And_Restore_Signals; ------------ -- Open -- ------------ function open (path : char_ptr; oflag : int) return int; function open (path : char_ptr; oflag : int; mode : mode_t) return int; pragma Import (C, open, open_LINKNAME); function Open (Name : Pathname; Mode : File_Mode; Options : Open_Option_Set := Empty_Set; Masked_Signals : Signal_Masking := RTS_Signals) return File_Descriptor is Result : int; Name_With_NUL : POSIX_String := Name & NUL; Old_Mask : aliased Signal_Mask; begin Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := open (path => Name_With_NUL (Name_With_NUL'First)'Unchecked_Access, oflag => To_int (Option_Set (Options).Option or C_File_Mode (Mode))); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); return File_Descriptor (Result); end Open; ---------------------- -- Open_Or_Create -- ---------------------- function Open_Or_Create (Name : Pathname; Mode : File_Mode; Permissions : POSIX.Permissions.Permission_Set; Options : Open_Option_Set := -- Empty_Set; Open_Option_Set (POSIX.Empty_Set); -- Conversion is only to work around a GNAT3.09 problem. Masked_Signals : POSIX.Signal_Masking := RTS_Signals) return File_Descriptor is Result : int; Name_With_NUL : POSIX_String := Name & NUL; Old_Mask : aliased Signal_Mask; begin Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := open (path => Name_With_NUL (Name_With_NUL'First)'Unchecked_Access, oflag => To_int (Option_Set (Options).Option or C_File_Mode (Mode) or O_CREAT), mode => Form_C_Permission (Permissions)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); return File_Descriptor (Result); end Open_Or_Create; --------------- -- Is_Open -- --------------- function fcntl (fildes : int; cmd : int) return int; function fcntl (fildes : int; cmd : int; arg : int) return int; pragma Import (C, fcntl, fcntl_LINKNAME); function Is_Open (File : File_Descriptor) return Boolean is begin return fcntl (int (File), F_GETFL) /= -1; end Is_Open; ------------- -- Close -- ------------- function close (fildes : int) return int; pragma Import (C, close, close_LINKNAME); procedure Close (File : in File_Descriptor; Masked_Signals : in Signal_Masking := RTS_Signals) is Old_Mask : aliased Signal_Mask; Result : int; begin Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := close (int (File)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Access); end Close; ----------------- -- Duplicate -- ----------------- function dup (fildes : int) return int; pragma Import (C, dup, dup_LINKNAME); function Duplicate (File : File_Descriptor; Target : File_Descriptor := 0) return File_Descriptor is pragma Warnings (Off, Target); begin return File_Descriptor (Check (dup (int (File)))); end Duplicate; --------------------------- -- Duplicate_and_Close -- --------------------------- function dup2 (fildes, fildes2 : int) return int; -- fildes = old fd, fildes2 = new fd pragma Import (C, dup2, dup2_LINKNAME); function Duplicate_and_Close (File : File_Descriptor; Target : File_Descriptor := 0; Masked_Signals : Signal_Masking := RTS_Signals) return File_Descriptor is Old_Mask : aliased Signal_Mask; Result : int; begin if File = Target then return Target; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := dup2 (int (File), int (Target)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); return File_Descriptor (Result); end Duplicate_and_Close; ------------------- -- Create_Pipe -- ------------------- type fildes_pair is array (1 .. 2) of File_Descriptor; function pipe (fildes : access fildes_pair) return int; pragma Import (C, pipe, pipe_LINKNAME); procedure Create_Pipe (Read_End : out File_Descriptor; Write_End : out File_Descriptor) is Fildes : aliased fildes_pair; begin Check_NZ (pipe (Fildes'Unchecked_Access)); Read_End := Fildes (1); Write_End := Fildes (2); end Create_Pipe; ------------ -- Read -- ------------ -- .... Change P1003.5? -- We have trouble getting a pointer to the Buffer argument, -- which we need in order to pass it through to the OS. -- 1) The type Ada_Streams.Stream_Element_Array -- is not declared with aliased components. This prevents us -- from using Buffer (Buffer'First)'Unchecked_Access. -- 2) The parameter Buffer is not aliased, so we can't use -- Buffer'Unchecked_Access. -- 3) The parameter Buffer is not itself an access parameter. -- Therefore, we use Buffer (Buffer'First)'Address. -- The compiler should always -- accept this, but some day it may quietly stop working, as it relies -- on assumptions about the meaning of 'Address and how the compiler -- chooses to pass the parameter Buffer. -- If this breaks here, then it will also break in several other -- places, where we use the same technique. function read (fildes : int; buf : System.Address; nbyte : size_t) return ssize_t; pragma Import (C, read, read_LINKNAME); procedure Read (File : in File_Descriptor; Buffer : out IO_Buffer; Last : out IO_Count; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Buffer'Length <= 0 then Last := IO_Count (Buffer'First) - 1; return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := read (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := IO_Count (Buffer'First) + IO_Count (Result) - 1; if Result = 0 then raise Ada.IO_Exceptions.End_Error; end if; end Read; procedure NONSTANDARD_Read (File : in File_Descriptor; Buffer : out IO_Buffer; Last : out Natural; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Buffer'Length <= 0 then Last := Buffer'First - 1; return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := read (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := Buffer'First + Integer (Result) - 1; if Result = 0 then raise Ada.IO_Exceptions.End_Error; end if; end NONSTANDARD_Read; procedure Read (File : in File_Descriptor; Buffer : out Ada_Streams.Stream_Element_Array; Last : out Ada_Streams.Stream_Element_Offset; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; use Ada_Streams; begin if Buffer'Length <= 0 then Last := Buffer'First - 1; return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := read (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := Buffer'First + Ada_Streams.Stream_Element_Offset (Result) - 1; if Result = 0 then raise Ada.IO_Exceptions.End_Error; end if; end Read; -- .... Consider writing one lower-level subprogram for Read and -- having both versions call it. Similarly for Write. ------------- -- Write -- ------------- function write (fildes : int; buf : System.Address; nbyte : size_t) return ssize_t; pragma Import (C, write, write_LINKNAME); -- ....Change POSIX.5???? -- Something is inconsistent here. -- If Last is the last position, then for a null array -- we don't want to set it to zero! procedure Write (File : in File_Descriptor; Buffer : in IO_Buffer; Last : out IO_Count; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Buffer'Length <= 0 then Last := IO_Count (Buffer'First - 1); return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := write (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := IO_Count (Buffer'First) + IO_Count (Result) - 1; end Write; -- .... Change POSIX.5????? -- The type of Last really should be Natural, since it is -- an index in a POSIX_String array. procedure NONSTANDARD_Write (File : in File_Descriptor; Buffer : in IO_Buffer; Last : out Natural; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Buffer'Length <= 0 then Last := Buffer'First - 1; return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := write (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := Buffer'First + Integer (Result) - 1; end NONSTANDARD_Write; procedure Write (File : in File_Descriptor; Buffer : in Ada_Streams.Stream_Element_Array; Last : out Ada_Streams.Stream_Element_Offset; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; use Ada_Streams; begin if Buffer'Length <= 0 then Last := Buffer'First - 1; return; end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := write (int (File), Buffer (Buffer'First)'Address, size_t (Buffer'Last - Buffer'First + 1)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); Last := Buffer'First + Ada_Streams.Stream_Element_Offset (Result) - 1; end Write; -------------------- -- Generic_Read -- -------------------- procedure Generic_Read (File : in File_Descriptor; Item : out T; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Item'Size rem char'Size /= 0 then Raise_POSIX_Error (Operation_Not_Implemented); end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := read (int (File), Item'Address, size_t (Item'Size / char'Size)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); if Result < Item'Size / char'Size then raise Ada.IO_Exceptions.End_Error; end if; end Generic_Read; --------------------- -- Generic_Write -- --------------------- procedure Generic_Write (File : in File_Descriptor; Item : in T; Masked_Signals : in Signal_Masking := RTS_Signals) is Result : ssize_t; Old_Mask : aliased Signal_Mask; begin if Item'Size rem char'Size /= 0 then Raise_POSIX_Error (Operation_Not_Implemented); end if; Mask_Signals (Masked_Signals, Old_Mask'Unchecked_Access); Result := write (int (File), Item'Address, size_t (Item'Size / char'Size)); Check_NNeg_And_Restore_Signals (Result, Masked_Signals, Old_Mask'Unchecked_Access); end Generic_Write; ------------ -- Seek -- ------------ function lseek (fildes : int; offset : off_t; whence : int) return off_t; pragma Import (C, lseek, lseek_LINKNAME); procedure Seek (File : in File_Descriptor; Offset : in IO_Offset; Result : out IO_Offset; Starting_Point : in Position := From_Beginning) is begin Result := IO_Offset (lseek (int (File), off_t (Offset), C_Whence (Starting_Point))); Check (int (Result)); end Seek; ----------------- -- File_Size -- ----------------- function File_Size (File : File_Descriptor) return IO_Count is Prevoff, Endoff : off_t; begin Begin_Critical_Section; Prevoff := lseek (int (File), 0, SEEK_CUR); if Prevoff < 0 then End_Critical_Section; Raise_POSIX_Error; end if; Endoff := lseek (int (File), 0, SEEK_END); if Endoff < 0 then End_Critical_Section; Raise_POSIX_Error; end if; Prevoff := lseek (int (File), Prevoff, SEEK_SET); if Prevoff < 0 then End_Critical_Section; Raise_POSIX_Error; end if; End_Critical_Section; return (IO_Count (Endoff)); end File_Size; --------------------- -- File_Position -- --------------------- function File_Position (File : File_Descriptor) return IO_Offset is begin return IO_Offset (Check (int (lseek (int (File), 0, SEEK_CUR)))); end File_Position; --------------------- -- Is_A_Terminal -- --------------------- function isatty (fildes : int) return int; pragma Import (C, isatty, isatty_LINKNAME); function Is_A_Terminal (File : File_Descriptor) return Boolean is begin return isatty (int (File)) = 1; end Is_A_Terminal; ------------------------- -- Get_Terminal_Name -- ------------------------- function ttyname (fildes : int) return char_ptr; pragma Import (C, ttyname, ttyname_LINKNAME); function Get_Terminal_Name (File : File_Descriptor) return Pathname is Result : char_ptr; begin Result := ttyname (int (File)); if Result = null then Raise_POSIX_Error; end if; return Form_POSIX_String (Result); end Get_Terminal_Name; ------------------------ -- Get_File_Control -- ------------------------ procedure Get_File_Control (File : in File_Descriptor; Mode : out File_Mode; Options : out Open_Option_Set) is Result : Bits; Access_Mode : Bits; begin Defer_Abortion; Result := To_Bits (Check (fcntl (int (File), F_GETFL))); Undefer_Abortion; Access_Mode := Result and O_ACCMODE; if Access_Mode = O_RDONLY then Mode := Read_Only; elsif Access_Mode = O_WRONLY then Mode := Write_Only; elsif Access_Mode = O_RDWR then Mode := Read_Write; else Raise_POSIX_Error (ENOSYS); -- should never be reached end if; Options := Open_Option_Set (Option_Set' (Option => Result and not O_ACCMODE)); end Get_File_Control; ------------------------ -- Set_File_Control -- ------------------------ C_Other_Open_Options : constant Bits := O_TRUNC or O_EXCL or O_NOCTTY or O_SYNC or O_DSYNC or O_RSYNC or O_RDONLY or O_RDWR or O_WRONLY; procedure Set_File_Control (File : in File_Descriptor; Options : in Open_Option_Set) is Old_Values : int; New_Values : Bits; begin Begin_Critical_Section; Old_Values := fcntl (int (File), F_GETFL); if Old_Values = -1 then End_Critical_Section; Raise_POSIX_Error; end if; New_Values := (Option_Set (Options).Option and not C_Other_Open_Options) or (To_Bits (Old_Values) and C_Other_Open_Options); if fcntl (int (File), F_SETFL, To_int (New_Values)) = -1 then End_Critical_Section; Raise_POSIX_Error; end if; End_Critical_Section; end Set_File_Control; ------------------------- -- Get_Close_On_Exec -- ------------------------- function Get_Close_On_Exec (File : File_Descriptor) return Boolean is Result : int; begin Result := fcntl (int (File), F_GETFD); if Result = -1 then Raise_POSIX_Error; end if; return (To_Bits (Result) and FD_CLOEXEC) /= 0; end Get_Close_On_Exec; ------------------------- -- Set_Close_On_Exec -- ------------------------- procedure Set_Close_On_Exec (File : in File_Descriptor; To : in Boolean := True) is Flags : Bits; Result : int; begin Begin_Critical_Section; Flags := To_Bits (fcntl (int (File), F_GETFD)); if Flags = -1 then End_Critical_Section; Raise_POSIX_Error; end if; if To then Flags := Flags or FD_CLOEXEC; else Flags := Flags and not FD_CLOEXEC; end if; if fcntl (int (File), F_SETFD, To_int (Flags)) = -1 then End_Critical_Section; Raise_POSIX_Error; end if; Result := fcntl (int (File), F_GETFD); -- should not fail since previous call did not fail End_Critical_Section; end Set_Close_On_Exec; ------------------------- -- Change_Permission -- ------------------------- function fchmod (fildes : int; mode : mode_t) return int; pragma Import (C, fchmod, fchmod_LINKNAME); procedure Change_Permissions (File : in File_Descriptor; Permission : in POSIX.Permissions.Permission_Set) is begin Check (fchmod (int (File), Form_C_Permission (Permission))); end Change_Permissions; --------------------- -- Truncate_File -- --------------------- function ftruncate (fildes : int; length : off_t) return int; pragma Import (C, ftruncate, ftruncate_LINKNAME); procedure Truncate_File (File : in File_Descriptor; Length : in IO_Count) is begin Check (ftruncate (int (File), off_t (Length))); end Truncate_File; ------------------------ -- Synchronize_File -- ------------------------ function fsync (fildes : int) return int; pragma Import (C, fsync, fsync_LINKNAME); procedure Synchronize_File (File : in File_Descriptor) is begin Check (fsync (int (File))); end Synchronize_File; ------------------------ -- Synchronize_Data -- ------------------------ function fdatasync (fildes : int) return int; pragma Import (C, fdatasync, fdatasync_LINKNAME); procedure Synchronize_Data (File : in File_Descriptor) is begin Check (fdatasync (int (File))); end Synchronize_Data; -- 6.1.12 Sockets File Ownership procedures from P1003.5c pragma Warnings (Off); procedure Get_Owner (File : in File_Descriptor; Process : out POSIX.Process_Identification.Process_ID; Group : out POSIX.Process_Identification.Process_Group_ID) is begin Raise_POSIX_Error (Operation_Not_Implemented); end Get_Owner; pragma Warnings (On); procedure Set_Socket_Process_Owner (File : in File_Descriptor; Process : in POSIX.Process_Identification.Process_ID) is begin Raise_POSIX_Error (Operation_Not_Implemented); end Set_Socket_Process_Owner; procedure Set_Socket_Group_Owner (File : in File_Descriptor; Group : in POSIX.Process_Identification.Process_Group_ID) is begin Raise_POSIX_Error (Operation_Not_Implemented); end Set_Socket_Group_Owner; procedure Set_Buffer (Vector : in out IO_Vector; Buffer : in System.Address; Length : in Positive) is begin Vector.C.iov_base := To_char_ptr (Buffer); Vector.C.iov_len := size_t (Length); end Set_Buffer; procedure Get_Buffer (Vector : in IO_Vector; Buffer : out System.Address; Length : out POSIX.IO_Count) is begin Buffer := To_Address (Vector.C.iov_base); Length := POSIX.IO_Count (Vector.C.iov_len); end Get_Buffer; end POSIX.IO;