------------------------------------------------------------------------------ -- -- -- FLORIST (FSU Implementation of POSIX.5) COMPONENTS -- -- -- -- P O S I X -- -- -- -- B o d y -- -- -- -- -- -- Copyright (c) 1996-2002 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.10 $] with Ada.Streams, POSIX.C, POSIX.Implementation, System, Unchecked_Conversion, Unchecked_Deallocation; pragma Elaborate (POSIX.C); pragma Elaborate (POSIX.Implementation); package body POSIX is use Ada.Streams; use POSIX.C; use POSIX.Implementation; type String_List is new POSIX.Implementation.String_List; ----------------------------- -- Unchecked Conversions -- ----------------------------- type Big_POSIX_String_Ptr is access all POSIX_String (Positive'Range); type Big_String_Ptr is access all String (Positive'Range); type Big_Stream_Element_Array_Ptr is access all Ada_Streams.Stream_Element_Array (Ada_Streams.Stream_Element_Offset'Range); function From_Address is new Unchecked_Conversion (System.Address, Big_String_Ptr); function From_Address is new Unchecked_Conversion (System.Address, Big_POSIX_String_Ptr); function From_Address is new Unchecked_Conversion (System.Address, Big_Stream_Element_Array_Ptr); ----------------------- -- To_POSIX_String -- ----------------------- function To_POSIX_String (Str : String) return POSIX_String is begin return From_Address (Str'Address) (Str'Range); end To_POSIX_String; ----------------- -- To_String -- ----------------- function To_String (Str : POSIX_String) return String is begin return From_Address (Str'Address) (Str'Range); end To_String; ---------------------- -- To_Wide_String -- ---------------------- function To_Wide_String (Str : POSIX_String) return Wide_String is Result : Wide_String (Str'Range); begin for I in Str'Range loop Result (I) := Wide_Character'Val (POSIX_Character'Pos (Str (I))); end loop; return Result; end To_Wide_String; -- We cannot use direct unchecked conversion here, -- since the sizes of the characters are different. -- However, we rely that the integer codes for the -- first 256 wide characters are the same as those -- of the ordinary characters. [See ARM A.1 (36)] ----------------------- -- To_POSIX_String -- ----------------------- function To_POSIX_String (Str : Wide_String) return POSIX_String is Result : POSIX_String (Str'Range); begin for I in Str'Range loop Result (I) := POSIX_Character'Val (Wide_Character'Pos (Str (I)) rem 256); end loop; return Result; end To_POSIX_String; ------------------------------- -- To_Stream_Element_Array -- ------------------------------- function To_Stream_Element_Array (Buffer : POSIX_String) return Ada_Streams.Stream_Element_Array is subtype Offset is Stream_Element_Offset; begin return From_Address (Buffer'Address) ((Offset (Buffer'First) + Offset'First - 1) .. (Offset (Buffer'Last) + Offset'First - 1)); end To_Stream_Element_Array; ----------------------- -- To_POSIX_String -- ----------------------- function To_POSIX_String (Buffer : Ada_Streams.Stream_Element_Array) return POSIX_String is subtype Offset is Stream_Element_Offset; begin return From_Address (Buffer'Address) (Positive (Buffer'First - Offset'First + 1) .. Positive (Buffer'Last - Offset'First + 1)); end To_POSIX_String; ------------------- -- Is_Filename -- ------------------- function Is_Filename (Str : POSIX_String) return Boolean is begin if To_String (Str)'Length = 0 then return False; end if; for I in Str'Range loop if Str (I) = '/' or Str (I) = NUL or Str (I) = ' ' then return False; end if; end loop; return True; end Is_Filename; -- These two functions (Is_Pathname and Is_Filename) seem -- not to be unimplementable in a portable way, since they are -- supposed to "check all constraints set on filename and -- pathname by the implementation that can be checked without -- accessing the file system directly. ------------------- -- Is_Pathname -- ------------------- function Is_Pathname (Str : POSIX_String) return Boolean is begin if To_String (Str)'Length = 0 then return False; end if; for I in Str'Range loop if Str (I) = NUL or Str (I) = ' ' then return False; end if; end loop; return True; end Is_Pathname; ---------------------------- -- Is_Portable_filename -- ---------------------------- function Is_Portable_Filename (Str : POSIX_String) return Boolean is begin if To_String (Str)'Length = 0 then return False; end if; for I in Str'Range loop case Str (I) is when 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '.' | '_' => null; when '-' => if I = Str'First then return False; end if; when others => return False; end case; end loop; return True; end Is_Portable_Filename; ---------------------------- -- Is_Portable_Pathname -- ---------------------------- function Is_Portable_Pathname (Str : POSIX_String) return Boolean is Start : Positive; P : Positive; begin if To_String (Str)'Length = 0 then return False; end if; Start := Str'First; P := Str'First; loop if P > Str'Last or else Str (P) = '/' then if Start < P and then not Is_Portable_Filename (Str (Start .. P - 1)) then return False; end if; if P > Str'Last then return True; end if; Start := P + 1; end if; P := P + 1; end loop; end Is_Portable_Pathname; ------------------ -- Make_Empty -- ------------------ procedure Free is new Unchecked_Deallocation (POSIX_String, POSIX_String_Ptr); procedure Free is new Unchecked_Deallocation (String_List, POSIX_String_List); procedure Make_Empty (List : in out POSIX_String_List) is begin if List = null then return; end if; for I in 1 .. List.Length loop if List.List (I) = null then exit; end if; Free (List.List (I)); end loop; Free (List); end Make_Empty; -------------- -- Append -- -------------- procedure Append (List : in out POSIX_String_List; Str : in POSIX_String) is Tmp : POSIX_String_List; Len : constant Integer := Str'Length; begin if List = null then List := new String_List (Min_String_List_Length); -- rely that pointers all initialized to null end if; for I in 1 .. List.Length loop if List.List (I) = null then if I = List.Length then Tmp := new String_List (2 * List.Length); Tmp.List (List.List'Range) := List.List; Tmp.Char (List.List'Range) := List.Char; Free (List); List := Tmp; end if; List.List (I) := new POSIX_String (1 .. Len + 1); List.List (I)(1 .. Len) := Str; List.List (I)(Len + 1) := NUL; List.Char (I) := List.List (I)(1)'Unchecked_Access; return; end if; end loop; end Append; ---------------------- -- For_Every_Item -- ---------------------- -- generic -- with procedure Action -- (Item: POSIX_String; Quit: in out Boolean); procedure For_Every_Item (List : in POSIX_String_List) is Quit : Boolean := False; begin if List = null then return; end if; for I in 1 .. List.Length loop exit when List.List (I) = null; declare L : constant Integer := List.List (I)'Length; begin Action (List.List (I)(1 .. L - 1), Quit); end; exit when Quit; end loop; end For_Every_Item; -------------- -- Length -- -------------- function Length (List : POSIX_String_List) return Natural is begin if List = null then return 0; end if; for I in 1 .. List.Length loop if List.List (I) = null then return Natural (I - 1); end if; end loop; raise Program_Error; return 0; end Length; ------------- -- Value -- ------------- function Value (List : POSIX_String_List; Index : Positive) return POSIX_String is I : constant Positive := Index; begin if List = null or else not (I in 1 .. List.Length) or else List.List (I) = null then raise Constraint_Error; end if; declare L : constant Integer := List.List (I).all'Length; begin return List.List (I)(1 .. L - 1); end; end Value; ----------------- -- Empty_set -- ----------------- function Empty_Set return Option_Set is begin return (Option => 0); end Empty_Set; ----------- -- "+" -- ----------- function "+" (L, R : Option_Set) return Option_Set is begin return (Option => Bits (unsigned (L.Option) or unsigned (R.Option))); end "+"; ----------- -- "-" -- ----------- function "-" (L, R : Option_Set) return Option_Set is begin return (Option => Bits (unsigned (L.Option) and not (unsigned (R.Option)))); end "-"; --------- -- < -- --------- function "<" (Left, Right : Option_Set) return Boolean is begin return (Left <= Right) and (Left /= Right); end "<"; --------- -- <= -- --------- function "<=" (Left, Right : Option_Set) return Boolean is begin return (((not Bits (unsigned (Right.Option)))) and Bits (unsigned (Left.Option))) = 0; end "<="; --------- -- > -- --------- function ">" (Left, Right : Option_Set) return Boolean is begin return Right < Left; end ">"; ---------- -- >= -- ---------- function ">=" (Left, Right : Option_Set) return Boolean is begin return Right <= Left; end ">="; ---------------------- -- Get_Error_Code -- ---------------------- function Get_Error_Code return Error_Code is begin return POSIX.Implementation.Get_Ada_Error_Code; end Get_Error_Code; ---------------------- -- Set_Error_Code -- ---------------------- procedure Set_Error_Code (Error : in Error_Code) is begin POSIX.Implementation.Set_Ada_Error_Code (Error); end Set_Error_Code; ---------------------- -- Is_POSIX_Error -- ---------------------- function Is_POSIX_Error (Error : Error_Code) return Boolean is use Bogus_Error_Codes; begin for I in Error_Array'Range loop if Error = Error_Array (I) then return True; end if; end loop; return False; end Is_POSIX_Error; ------------- -- Image -- ------------- function Image (Error : Error_Code) return String is use Bogus_Error_Codes; begin for I in Error_Array'Range loop if Error = Error_Array (I) then return Error_Name_Enum'Image (I); end if; end loop; declare Tmp : constant String := Error_Code'Image (Error); begin if Tmp (Tmp'First) /= ' ' then return Tmp; end if; return Tmp (Tmp'First + 1 .. Tmp'Last); end; end Image; function uname (name : access struct_utsname) return int; pragma Import (C, uname, uname_LINKNAME); ------------------- -- System_Name -- ------------------- function System_Name return POSIX_String is Name : aliased struct_utsname; begin Check (uname (Name'Unchecked_Access)); return Form_POSIX_String (Name.sysname (1)'Unchecked_Access); end System_Name; ----------------- -- Node_Name -- ----------------- function Node_Name return POSIX_String is Name : aliased struct_utsname; begin Check (uname (Name'Unchecked_Access)); return Form_POSIX_String (Name.nodename (1)'Unchecked_Access); end Node_Name; --------------- -- Release -- --------------- function Release return POSIX_String is Name : aliased struct_utsname; begin Check (uname (Name'Unchecked_Access)); return Form_POSIX_String (Name.release (1)'Unchecked_Access); end Release; --------------- -- Version -- --------------- function Version return POSIX_String is Name : aliased struct_utsname; begin Check (uname (Name'Unchecked_Access)); return Form_POSIX_String (Name.version (1)'Unchecked_Access); end Version; --------------- -- Machine -- --------------- function Machine return POSIX_String is Name : aliased struct_utsname; begin Check (uname (Name'Unchecked_Access)); return Form_POSIX_String (Name.machine (1)'Unchecked_Access); end Machine; ----------------------------------------- -- Timespec Composition/Decomposition -- ----------------------------------------- procedure Split (D : in Duration; S : out Duration; NS : out Duration); pragma Inline (Split); -- Decompose D into seconds (S) and nanoseconds (NS) parts, -- with the nanosecond part in the range 0.0 .. 0.999999999. procedure Split (D : in Duration; S : out Duration; NS : out Duration) is begin S := POSIX.Implementation.To_Duration (To_D_Int (D / NS_per_S) * NS_per_S); NS := D - S; if NS < 0.0 then S := S - 1.0; NS := NS + 1.0; end if; end Split; ------------- -- Split -- ------------- procedure Split (Time : in Timespec; S : out Seconds; NS : out Nanoseconds) is SD, NSD : Duration; begin Split (Time.Val, S => SD, NS => NSD); S := Seconds (SD); NS := Nanoseconds (NSD * NS_per_S); end Split; ------------------- -- To_Timespec -- ------------------- function To_Timespec (S : Seconds; NS : Nanoseconds) return Timespec is begin return Timespec' (Val => Duration (S) + Duration (NS) / NS_per_S); end To_Timespec; ------------------- -- Get_Seconds -- ------------------- function Get_Seconds (Time : Timespec) return Seconds is SD, NSD : Duration; begin Split (Time.Val, S => SD, NS => NSD); return Seconds (SD); end Get_Seconds; ----------------------- -- Get_Nanoseconds -- ----------------------- function Get_Nanoseconds (Time : Timespec) return Nanoseconds is SD, NSD : Duration; begin Split (Time.Val, S => SD, NS => NSD); return Nanoseconds (NSD * NS_per_S); end Get_Nanoseconds; ----------------------- -- Set_Nanoseconds -- ----------------------- procedure Set_Nanoseconds (Time : in out Timespec; NS : in Nanoseconds) is SD, NSD : Duration; begin Split (Time.Val, S => SD, NS => NSD); Time.Val := SD + Duration (NS) / NS_per_S; end Set_Nanoseconds; ------------------- -- Set_Seconds -- ------------------- procedure Set_Seconds (Time : in out Timespec; S : in Seconds) is SD, NSD : Duration; begin Split (Time.Val, S => SD, NS => NSD); Time.Val := Duration (S) + NSD; end Set_Seconds; ----------- -- "+" -- ----------- function "+" (Left, Right : Timespec) return Timespec is begin return Timespec'(Val => Left.Val + Right.Val); end "+"; ----------- -- "+" -- ----------- function "+" (Left : Timespec; Right : Nanoseconds) return Timespec is begin return Timespec' (Val => Left.Val + Duration (Right) / NS_per_S); end "+"; ----------- -- "-" -- ----------- function "-" (Right : Timespec) return Timespec is begin return Timespec'(Val => -Right.Val); end "-"; ----------- -- "-" -- ----------- function "-" (Left, Right : Timespec) return Timespec is begin return Timespec'(Val => Left.Val - Right.Val); end "-"; ----------- -- "-" -- ----------- function "-" (Left : Timespec; Right : Nanoseconds) return Timespec is begin return Timespec'(Val => Left.Val - Duration (Right) / NS_per_S); end "-"; ----------- -- "*" -- ----------- function "*" (Left : Timespec; Right : Integer) return Timespec is begin return Timespec'(Val => Left.Val * Duration (Right)); end "*"; ----------- -- "*" -- ----------- function "*" (Left : Integer; Right : Timespec) return Timespec is begin return Timespec'(Val => Left * Right.Val); end "*"; ----------- -- "/" -- ----------- function "/" (Left : Timespec; Right : Integer) return Timespec is begin return Timespec'(Val => Left.Val / Right); end "/"; ----------- -- "/" -- ----------- function "/" (Left, Right : Timespec) return Integer is begin return Integer (Left.Val / Right.Val); end "/"; ----------- -- "<" -- ----------- function "<" (Left, Right : Timespec) return Boolean is begin return Left.Val < Right.Val; end "<"; ----------- -- "<=" -- ----------- function "<=" (Left, Right : Timespec) return Boolean is begin return Left.Val < Right.Val or else Right.Val = Left.Val; end "<="; ----------- -- ">" -- ----------- function ">" (Left, Right : Timespec) return Boolean is begin return Right <= Left; end ">"; ------------ -- ">=" -- ------------ function ">=" (Left, Right : Timespec) return Boolean is begin return Right < Left; end ">="; ------------------- -- To_Timespec -- ------------------- function To_Timespec (D : Duration) return Timespec is begin return Timespec'(Val => D); end To_Timespec; ------------------- -- To_Duration -- ------------------- function To_Duration (Time : Timespec) return Duration is begin return Time.Val; end To_Duration; ------------------------------ -- Host_To_Network_Byte_Order ------------------------------ function c_htonl (host_32 : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; pragma Import (C, c_htonl, "c_htonl"); function Host_To_Network_Byte_Order (Host_32 : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 is begin return c_htonl (Host_32); end Host_To_Network_Byte_Order; function c_htons (host_16 : Interfaces.Unsigned_16) return Interfaces.Unsigned_16; pragma Import (C, c_htons, "c_htons"); function Host_To_Network_Byte_Order (Host_16 : Interfaces.Unsigned_16) return Interfaces.Unsigned_16 is begin return c_htons (Host_16); end Host_To_Network_Byte_Order; ------------------------------ -- Host_To_Network_Byte_Order ------------------------------ function c_ntohl (host_32 : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; pragma Import (C, c_ntohl, "c_htonl"); function Network_To_Host_Byte_Order (Host_32 : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 is begin return c_ntohl (Host_32); end Network_To_Host_Byte_Order; function c_ntohs (host_16 : Interfaces.Unsigned_16) return Interfaces.Unsigned_16; pragma Import (C, c_ntohs, "c_htons"); function Network_To_Host_Byte_Order (Host_16 : Interfaces.Unsigned_16) return Interfaces.Unsigned_16 is begin return c_ntohs (Host_16); end Network_To_Host_Byte_Order; begin pragma Assert (Duration'Small = 1.0/NS_per_S); -- We rely that Duration is an exact count of nanoseconds. null; end POSIX;