X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fg-socket.adb;h=940026586c3abd9abb6f8b7511cd13bae0e6d3c9;hb=390bd8226449222ff163ccbe44a07508ca828f3a;hp=a7af20b87d23a2a867f82123caeb6f8aa87a5648;hpb=dd23de097c021a32856d3ffd7471af555f58d0b3;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index a7af20b87d2..940026586c3 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2005 Ada Core Technologies, Inc. -- +-- Copyright (C) 2001-2007, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,15 +31,14 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Streams; use Ada.Streams; -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Streams; use Ada.Streams; +with Ada.Exceptions; use Ada.Exceptions; with Ada.Unchecked_Conversion; with Interfaces.C.Strings; - with GNAT.Sockets.Constants; -with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; -with GNAT.Task_Lock; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; +with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB; with GNAT.Sockets.Linker_Options; pragma Warnings (Off, GNAT.Sockets.Linker_Options); @@ -56,50 +55,59 @@ package body GNAT.Sockets is ENOERROR : constant := 0; + Netdb_Buffer_Size : constant := Constants.Need_Netdb_Buffer * 1024; + -- The network database functions gethostbyname, gethostbyaddr, + -- getservbyname and getservbyport can either be guaranteed task safe by + -- the operating system, or else return data through a user-provided buffer + -- to ensure concurrent uses do not interfere. + -- Correspondance tables Families : constant array (Family_Type) of C.int := - (Family_Inet => Constants.AF_INET, - Family_Inet6 => Constants.AF_INET6); + (Family_Inet => Constants.AF_INET, + Family_Inet6 => Constants.AF_INET6); Levels : constant array (Level_Type) of C.int := - (Socket_Level => Constants.SOL_SOCKET, - IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, - IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP, - IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP); + (Socket_Level => Constants.SOL_SOCKET, + IP_Protocol_For_IP_Level => Constants.IPPROTO_IP, + IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP, + IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP); Modes : constant array (Mode_Type) of C.int := - (Socket_Stream => Constants.SOCK_STREAM, - Socket_Datagram => Constants.SOCK_DGRAM); + (Socket_Stream => Constants.SOCK_STREAM, + Socket_Datagram => Constants.SOCK_DGRAM); Shutmodes : constant array (Shutmode_Type) of C.int := - (Shut_Read => Constants.SHUT_RD, - Shut_Write => Constants.SHUT_WR, - Shut_Read_Write => Constants.SHUT_RDWR); + (Shut_Read => Constants.SHUT_RD, + Shut_Write => Constants.SHUT_WR, + Shut_Read_Write => Constants.SHUT_RDWR); Requests : constant array (Request_Name) of C.int := - (Non_Blocking_IO => Constants.FIONBIO, - N_Bytes_To_Read => Constants.FIONREAD); + (Non_Blocking_IO => Constants.FIONBIO, + N_Bytes_To_Read => Constants.FIONREAD); Options : constant array (Option_Name) of C.int := - (Keep_Alive => Constants.SO_KEEPALIVE, - Reuse_Address => Constants.SO_REUSEADDR, - Broadcast => Constants.SO_BROADCAST, - Send_Buffer => Constants.SO_SNDBUF, - Receive_Buffer => Constants.SO_RCVBUF, - Linger => Constants.SO_LINGER, - Error => Constants.SO_ERROR, - No_Delay => Constants.TCP_NODELAY, - Add_Membership => Constants.IP_ADD_MEMBERSHIP, - Drop_Membership => Constants.IP_DROP_MEMBERSHIP, - Multicast_TTL => Constants.IP_MULTICAST_TTL, - Multicast_Loop => Constants.IP_MULTICAST_LOOP); + (Keep_Alive => Constants.SO_KEEPALIVE, + Reuse_Address => Constants.SO_REUSEADDR, + Broadcast => Constants.SO_BROADCAST, + Send_Buffer => Constants.SO_SNDBUF, + Receive_Buffer => Constants.SO_RCVBUF, + Linger => Constants.SO_LINGER, + Error => Constants.SO_ERROR, + No_Delay => Constants.TCP_NODELAY, + Add_Membership => Constants.IP_ADD_MEMBERSHIP, + Drop_Membership => Constants.IP_DROP_MEMBERSHIP, + Multicast_If => Constants.IP_MULTICAST_IF, + Multicast_TTL => Constants.IP_MULTICAST_TTL, + Multicast_Loop => Constants.IP_MULTICAST_LOOP, + Send_Timeout => Constants.SO_SNDTIMEO, + Receive_Timeout => Constants.SO_RCVTIMEO); Flags : constant array (0 .. 3) of C.int := - (0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data - 1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data - 2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception - 3 => Constants.MSG_EOR); -- Send_End_Of_Record + (0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data + 1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data + 2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception + 3 => Constants.MSG_EOR); -- Send_End_Of_Record Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; Host_Error_Id : constant Exception_Id := Host_Error'Identity; @@ -110,6 +118,9 @@ package body GNAT.Sockets is function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + function Err_Code_Image (E : Integer) return String; + -- Return the value of E surrounded with brackets + ----------------------- -- Local subprograms -- ----------------------- @@ -160,15 +171,20 @@ package body GNAT.Sockets is function To_Service_Entry (E : Servent) return Service_Entry_Type; -- Conversion function - function To_Timeval (Val : Selector_Duration) return Timeval; + function To_Timeval (Val : Timeval_Duration) return Timeval; -- Separate Val in seconds and microseconds + function To_Duration (Val : Timeval) return Timeval_Duration; + -- Reconstruct a Duration value from a Timeval record (seconds and + -- microseconds). + procedure Raise_Socket_Error (Error : Integer); -- Raise Socket_Error with an exception message describing the error code + -- from errno. - procedure Raise_Host_Error (Error : Integer); + procedure Raise_Host_Error (H_Error : Integer); -- Raise Host_Error exception with message describing error code (note - -- hstrerror seems to be obsolete). + -- hstrerror seems to be obsolete) from h_errno. procedure Narrow (Item : in out Socket_Set_Type); -- Update Last as it may be greater than the real last socket @@ -225,14 +241,13 @@ package body GNAT.Sockets is -------------------- procedure Abort_Selector (Selector : Selector_Type) is - Buf : aliased Character := ASCII.NUL; Res : C.int; begin - -- Send an empty array to unblock C select system call + -- Send one byte to unblock select system call + + Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); - Res := C_Send (C.int (Selector.W_Sig_Socket), Buf'Address, 1, - Constants.MSG_Forced_Flags); if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; @@ -344,8 +359,9 @@ package body GNAT.Sockets is raise Socket_Error; end if; - Set_Length (Sin'Unchecked_Access, Len); - Set_Family (Sin'Unchecked_Access, Families (Address.Family)); + Set_Length (Sin'Unchecked_Access, Len); + Set_Family (Sin'Unchecked_Access, Families (Address.Family)); + Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); Set_Port (Sin'Unchecked_Access, Short_To_Network (C.unsigned_short (Address.Port))); @@ -384,6 +400,7 @@ package body GNAT.Sockets is is Res : C.int; Last : C.int; + RSig : Socket_Type renames Selector.R_Sig_Socket; RSet : Socket_Set_Type; WSet : Socket_Set_Type; ESet : Socket_Set_Type; @@ -391,102 +408,110 @@ package body GNAT.Sockets is TPtr : Timeval_Access; begin - Status := Completed; + begin + Status := Completed; - -- No timeout or Forever is indicated by a null timeval pointer + -- No timeout or Forever is indicated by a null timeval pointer - if Timeout = Forever then - TPtr := null; - else - TVal := To_Timeval (Timeout); - TPtr := TVal'Unchecked_Access; - end if; - - -- Copy R_Socket_Set in RSet and add read signalling socket + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; - RSet := (Set => New_Socket_Set (R_Socket_Set.Set), - Last => R_Socket_Set.Last); - Set (RSet, Selector.R_Sig_Socket); + -- Copy R_Socket_Set in RSet and add read signalling socket - -- Copy W_Socket_Set in WSet + RSet := (Set => New_Socket_Set (R_Socket_Set.Set), + Last => R_Socket_Set.Last); + Set (RSet, RSig); - WSet := (Set => New_Socket_Set (W_Socket_Set.Set), - Last => W_Socket_Set.Last); + -- Copy W_Socket_Set in WSet - -- Copy E_Socket_Set in ESet + WSet := (Set => New_Socket_Set (W_Socket_Set.Set), + Last => W_Socket_Set.Last); - ESet := (Set => New_Socket_Set (E_Socket_Set.Set), - Last => E_Socket_Set.Last); + -- Copy E_Socket_Set in ESet - Last := C.int'Max (C.int'Max (C.int (RSet.Last), - C.int (WSet.Last)), - C.int (ESet.Last)); + ESet := (Set => New_Socket_Set (E_Socket_Set.Set), + Last => E_Socket_Set.Last); - Res := - C_Select - (Last + 1, - RSet.Set, - WSet.Set, - ESet.Set, - TPtr); + Last := C.int'Max (C.int'Max (C.int (RSet.Last), + C.int (WSet.Last)), + C.int (ESet.Last)); - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; + Res := + C_Select + (Last + 1, + RSet.Set, + WSet.Set, + ESet.Set, + TPtr); - -- If Select was resumed because of read signalling socket, read this - -- data and remove socket from set. + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; - if Is_Set (RSet, Selector.R_Sig_Socket) then - Clear (RSet, Selector.R_Sig_Socket); + -- If Select was resumed because of read signalling socket, read this + -- data and remove socket from set. - declare - Buf : Character; + if Is_Set (RSet, RSig) then + Clear (RSet, RSig); - begin - Res := C_Recv (C.int (Selector.R_Sig_Socket), Buf'Address, 1, 0); + Res := Signalling_Fds.Read (C.int (RSig)); if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; - end; - Status := Aborted; + Status := Aborted; - elsif Res = 0 then - Status := Expired; - end if; + elsif Res = 0 then + Status := Expired; + end if; - -- Update RSet, WSet and ESet in regard to their new socket sets + -- Update RSet, WSet and ESet in regard to their new socket sets - Narrow (RSet); - Narrow (WSet); - Narrow (ESet); + Narrow (RSet); + Narrow (WSet); + Narrow (ESet); - -- Reset RSet as it should be if R_Sig_Socket was not added + -- Reset RSet as it should be if R_Sig_Socket was not added - if Is_Empty (RSet) then - Empty (RSet); - end if; + if Is_Empty (RSet) then + Empty (RSet); + end if; - if Is_Empty (WSet) then - Empty (WSet); - end if; + if Is_Empty (WSet) then + Empty (WSet); + end if; - if Is_Empty (ESet) then - Empty (ESet); - end if; + if Is_Empty (ESet) then + Empty (ESet); + end if; + + -- Deliver RSet, WSet and ESet + + Empty (R_Socket_Set); + R_Socket_Set := RSet; - -- Deliver RSet, WSet and ESet + Empty (W_Socket_Set); + W_Socket_Set := WSet; - Empty (R_Socket_Set); - R_Socket_Set := RSet; + Empty (E_Socket_Set); + E_Socket_Set := ESet; - Empty (W_Socket_Set); - W_Socket_Set := WSet; + exception + when Socket_Error => - Empty (E_Socket_Set); - E_Socket_Set := ESet; + -- The local socket sets must be emptied before propagating + -- Socket_Error so the associated storage is freed. + + Empty (RSet); + Empty (WSet); + Empty (ESet); + raise; + end; end Check_Selector; ----------- @@ -510,24 +535,19 @@ package body GNAT.Sockets is -- Close_Selector -- -------------------- - -- Comments needed below ??? - -- Why are exceptions ignored ??? - procedure Close_Selector (Selector : in out Selector_Type) is begin - begin - Close_Socket (Selector.R_Sig_Socket); - exception - when Socket_Error => - null; - end; + -- Close the signalling file descriptors used internally for the + -- implementation of Abort_Selector. - begin - Close_Socket (Selector.W_Sig_Socket); - exception - when Socket_Error => - null; - end; + Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); + Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); + + -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any + -- (errneous) subsequent attempt to use this selector properly fails. + + Selector.R_Sig_Socket := No_Socket; + Selector.W_Sig_Socket := No_Socket; end Close_Selector; ------------------ @@ -594,7 +614,6 @@ package body GNAT.Sockets is when N_Bytes_To_Read => null; - end case; Res := C_Ioctl @@ -636,105 +655,23 @@ package body GNAT.Sockets is --------------------- procedure Create_Selector (Selector : out Selector_Type) is - S0 : C.int; - S1 : C.int; - S2 : C.int; - Res : C.int; - Sin : aliased Sockaddr_In; - Len : aliased C.int := Sin'Size / 8; - Err : Integer; + Two_Fds : aliased Fd_Pair; + Res : C.int; begin - -- We open two signalling sockets. One of them is used to send data to - -- the other, which is included in a C_Select socket set. The - -- communication is used to force the call to C_Select to complete, and + -- We open two signalling file descriptors. One of them is used to send + -- data to the other, which is included in a C_Select socket set. The + -- communication is used to force a call to C_Select to complete, and -- the waiting task to resume its execution. - -- Create a listening socket - - S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); - - if S0 = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - -- Bind the socket to any unused port on localhost - - Sin.Sin_Addr.S_B1 := 127; - Sin.Sin_Addr.S_B2 := 0; - Sin.Sin_Addr.S_B3 := 0; - Sin.Sin_Addr.S_B4 := 1; - Sin.Sin_Port := 0; - - Res := C_Bind (S0, Sin'Address, Len); - - if Res = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Raise_Socket_Error (Err); - end if; - - -- Get the port used by the socket - - Res := C_Getsockname (S0, Sin'Address, Len'Access); - - if Res = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Raise_Socket_Error (Err); - end if; - - -- Set backlog to 1 to guarantee that exactly one call to connect(2) - -- can succeed. - - Res := C_Listen (S0, 1); - - if Res = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Raise_Socket_Error (Err); - end if; - - S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0); - - if S1 = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Raise_Socket_Error (Err); - end if; - - -- Do a connect and accept the connection - - Res := C_Connect (S1, Sin'Address, Len); - - if Res = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Res := C_Close (S1); - Raise_Socket_Error (Err); - end if; - - -- Since the call to connect(2) has suceeded and the backlog limit on - -- the listening socket is 1, we know that there is now exactly one - -- pending connection on S0, which is the one from S1. - - S2 := C_Accept (S0, Sin'Address, Len'Access); - - if S2 = Failure then - Err := Socket_Errno; - Res := C_Close (S0); - Res := C_Close (S1); - Raise_Socket_Error (Err); - end if; - - Res := C_Close (S0); + Res := Signalling_Fds.Create (Two_Fds'Access); if Res = Failure then Raise_Socket_Error (Socket_Errno); end if; - Selector.R_Sig_Socket := Socket_Type (S1); - Selector.W_Sig_Socket := Socket_Type (S2); + Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); + Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); end Create_Selector; ------------------- @@ -772,6 +709,17 @@ package body GNAT.Sockets is Item.Last := No_Socket; end Empty; + -------------------- + -- Err_Code_Image -- + -------------------- + + function Err_Code_Image (E : Integer) return String is + Msg : String := E'Img & "] "; + begin + Msg (Msg'First) := '['; + return Msg; + end Err_Code_Image; + -------------- -- Finalize -- -------------- @@ -833,32 +781,20 @@ package body GNAT.Sockets is is pragma Unreferenced (Family); - HA : aliased In_Addr := To_In_Addr (Address); - Res : Hostent_Access; - Err : Integer; + HA : aliased In_Addr := To_In_Addr (Address); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; begin - -- This C function is not always thread-safe. Protect against - -- concurrent access. - - Task_Lock.Lock; - Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET); - - if Res = null then - Err := Socket_Errno; - Task_Lock.Unlock; - Raise_Host_Error (Err); + if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET, + Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Raise_Host_Error (Integer (Err)); end if; - -- Translate from the C format to the API format - - declare - HE : constant Host_Entry_Type := To_Host_Entry (Res.all); - - begin - Task_Lock.Unlock; - return HE; - end; + return To_Host_Entry (Res); end Get_Host_By_Address; ---------------------- @@ -866,10 +802,6 @@ package body GNAT.Sockets is ---------------------- function Get_Host_By_Name (Name : String) return Host_Entry_Type is - HN : constant C.char_array := C.To_C (Name); - Res : Hostent_Access; - Err : Integer; - begin -- Detect IP address name and redirect to Inet_Addr @@ -877,25 +809,21 @@ package body GNAT.Sockets is return Get_Host_By_Address (Inet_Addr (Name)); end if; - -- This C function is not always thread-safe. Protect against - -- concurrent access. - - Task_Lock.Lock; - Res := C_Gethostbyname (HN); - - if Res = null then - Err := Socket_Errno; - Task_Lock.Unlock; - Raise_Host_Error (Err); - end if; - - -- Translate from the C format to the API format - declare - HE : constant Host_Entry_Type := To_Host_Entry (Res.all); + HN : constant C.char_array := C.To_C (Name); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; + begin - Task_Lock.Unlock; - return HE; + if Safe_Gethostbyname + (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Raise_Host_Error (Integer (Err)); + end if; + + return To_Host_Entry (Res); end; end Get_Host_By_Name; @@ -927,32 +855,21 @@ package body GNAT.Sockets is (Name : String; Protocol : String) return Service_Entry_Type is - SN : constant C.char_array := C.To_C (Name); - SP : constant C.char_array := C.To_C (Protocol); - Res : Servent_Access; + SN : constant C.char_array := C.To_C (Name); + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; begin - -- This C function is not always thread-safe. Protect against - -- concurrent access. - - Task_Lock.Lock; - Res := C_Getservbyname (SN, SP); - - if Res = null then - Task_Lock.Unlock; + if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then Ada.Exceptions.Raise_Exception (Service_Error'Identity, "Service not found"); end if; -- Translate from the C format to the API format - declare - SE : constant Service_Entry_Type := To_Service_Entry (Res.all); - - begin - Task_Lock.Unlock; - return SE; - end; + return To_Service_Entry (Res); end Get_Service_By_Name; ------------------------- @@ -963,32 +880,23 @@ package body GNAT.Sockets is (Port : Port_Type; Protocol : String) return Service_Entry_Type is - SP : constant C.char_array := C.To_C (Protocol); - Res : Servent_Access; + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; begin - -- This C function is not always thread-safe. Protect against - -- concurrent access. - - Task_Lock.Lock; - Res := C_Getservbyport - (C.int (Short_To_Network (C.unsigned_short (Port))), SP); - - if Res = null then - Task_Lock.Unlock; + if Safe_Getservbyport + (C.int (Short_To_Network (C.unsigned_short (Port))), SP, + Res'Access, Buf'Address, Buflen) /= 0 + then Ada.Exceptions.Raise_Exception (Service_Error'Identity, "Service not found"); end if; -- Translate from the C format to the API format - declare - SE : constant Service_Entry_Type := To_Service_Entry (Res.all); - - begin - Task_Lock.Unlock; - return SE; - end; + return To_Service_Entry (Res); end Get_Service_By_Port; --------------------- @@ -1005,6 +913,7 @@ package body GNAT.Sockets is begin Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); + if Res /= Failure then To_Inet_Addr (Sin.Sin_Addr, Addr.Addr); Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); @@ -1024,9 +933,10 @@ package body GNAT.Sockets is is use type C.unsigned_char; - V8 : aliased Two_Int; + V8 : aliased Two_Ints; V4 : aliased C.int; V1 : aliased C.unsigned_char; + VT : aliased Timeval; Len : aliased C.int; Add : System.Address; Res : C.int; @@ -1045,10 +955,16 @@ package body GNAT.Sockets is No_Delay | Send_Buffer | Receive_Buffer | + Multicast_If | Error => Len := V4'Size / 8; Add := V4'Address; + when Send_Timeout | + Receive_Timeout => + Len := VT'Size / 8; + Add := VT'Address; + when Linger | Add_Membership | Drop_Membership => @@ -1091,12 +1007,18 @@ package body GNAT.Sockets is To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address); To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface); + when Multicast_If => + To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); + when Multicast_TTL => Opt.Time_To_Live := Integer (V1); when Multicast_Loop => Opt.Enabled := (V1 /= 0); + when Send_Timeout | + Receive_Timeout => + Opt.Timeout := To_Duration (VT); end case; return Opt; @@ -1233,9 +1155,9 @@ package body GNAT.Sockets is Result : Inet_Addr_Type; begin - -- Special case for the all-ones broadcast address: this address - -- has the same in_addr_t value as Failure, and thus cannot be - -- properly returned by inet_addr(3). + -- Special case for the all-ones broadcast address: this address has the + -- same in_addr_t value as Failure, and thus cannot be properly returned + -- by inet_addr(3). if Image = "255.255.255.255" then return Broadcast_Inet_Addr; @@ -1263,11 +1185,26 @@ package body GNAT.Sockets is -- Initialize -- ---------------- - procedure Initialize (Process_Blocking_IO : Boolean := False) is + procedure Initialize (Process_Blocking_IO : Boolean) is + Expected : constant Boolean := not Constants.Thread_Blocking_IO; + begin + if Process_Blocking_IO /= Expected then + raise Socket_Error with + "incorrect Process_Blocking_IO setting, expected " & Expected'Img; + end if; + + Initialize; + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is begin if not Initialized then Initialized := True; - Thin.Initialize (Process_Blocking_IO); + Thin.Initialize; end if; end Initialize; @@ -1379,32 +1316,11 @@ package body GNAT.Sockets is -- Raise_Host_Error -- ---------------------- - procedure Raise_Host_Error (Error : Integer) is - - function Host_Error_Message return String; - -- We do not use a C function like strerror because hstrerror - -- that would correspond seems to be obsolete. Return - -- appropriate string for error value. - - ------------------------ - -- Host_Error_Message -- - ------------------------ - - function Host_Error_Message return String is - begin - case Error is - when Constants.HOST_NOT_FOUND => return "Host not found"; - when Constants.TRY_AGAIN => return "Try again"; - when Constants.NO_RECOVERY => return "No recovery"; - when Constants.NO_DATA => return "No address"; - when others => return "Unknown error"; - end case; - end Host_Error_Message; - - -- Start of processing for Raise_Host_Error - + procedure Raise_Host_Error (H_Error : Integer) is begin - Ada.Exceptions.Raise_Exception (Host_Error'Identity, Host_Error_Message); + Ada.Exceptions.Raise_Exception (Host_Error'Identity, + Err_Code_Image (H_Error) + & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error))); end Raise_Host_Error; ------------------------ @@ -1413,26 +1329,10 @@ package body GNAT.Sockets is procedure Raise_Socket_Error (Error : Integer) is use type C.Strings.chars_ptr; - - function Image (E : Integer) return String; - - ----------- - -- Image -- - ----------- - - function Image (E : Integer) return String is - Msg : String := E'Img & "] "; - begin - Msg (Msg'First) := '['; - return Msg; - end Image; - - -- Start of processing for Raise_Socket_Error - begin - Ada.Exceptions.Raise_Exception - (Socket_Error'Identity, - Image (Error) & C.Strings.Value (Socket_Error_Message (Error))); + Ada.Exceptions.Raise_Exception (Socket_Error'Identity, + Err_Code_Image (Error) + & C.Strings.Value (Socket_Error_Message (Error))); end Raise_Socket_Error; ---------- @@ -1456,7 +1356,7 @@ package body GNAT.Sockets is Index, Stream.From); - Last := Index; + Last := Index; -- Exit when all or zero data received. Zero means that the socket -- peer is closed. @@ -1509,11 +1409,8 @@ package body GNAT.Sockets is Res : C.int; begin - Res := C_Recv - (C.int (Socket), - Item (Item'First)'Address, - Item'Length, - To_Int (Flags)); + Res := + C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); if Res = Failure then Raise_Socket_Error (Socket_Errno); @@ -1543,7 +1440,7 @@ package body GNAT.Sockets is Res := C_Recvfrom (C.int (Socket), - Item (Item'First)'Address, + Item'Address, Item'Length, To_Int (Flags), Sin'Unchecked_Access, @@ -1574,8 +1471,7 @@ package body GNAT.Sockets is case Error_Value is when Constants.HOST_NOT_FOUND => return Unknown_Host; when Constants.TRY_AGAIN => return Host_Name_Lookup_Failure; - when Constants.NO_RECOVERY => - return Non_Recoverable_Error; + when Constants.NO_RECOVERY => return Non_Recoverable_Error; when Constants.NO_DATA => return Unknown_Server_Error; when others => return Cannot_Resolve_Error; end case; @@ -1586,8 +1482,8 @@ package body GNAT.Sockets is when EACCES => return Permission_Denied; when EADDRINUSE => return Address_Already_In_Use; when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address; - when EAFNOSUPPORT => - return Address_Family_Not_Supported_By_Protocol; + when EAFNOSUPPORT => return + Address_Family_Not_Supported_By_Protocol; when EALREADY => return Operation_Already_In_Progress; when EBADF => return Bad_File_Descriptor; when ECONNABORTED => return Software_Caused_Connection_Abort; @@ -1607,8 +1503,8 @@ package body GNAT.Sockets is when EMSGSIZE => return Message_Too_Long; when ENAMETOOLONG => return File_Name_Too_Long; when ENETDOWN => return Network_Is_Down; - when ENETRESET => - return Network_Dropped_Connection_Because_Of_Reset; + when ENETRESET => return + Network_Dropped_Connection_Because_Of_Reset; when ENETUNREACH => return Network_Is_Unreachable; when ENOBUFS => return No_Buffer_Space_Available; when ENOPROTOOPT => return Protocol_Not_Available; @@ -1618,8 +1514,8 @@ package body GNAT.Sockets is when EPFNOSUPPORT => return Protocol_Family_Not_Supported; when EPROTONOSUPPORT => return Protocol_Not_Supported; when EPROTOTYPE => return Protocol_Wrong_Type_For_Socket; - when ESHUTDOWN => - return Cannot_Send_After_Transport_Endpoint_Shutdown; + when ESHUTDOWN => return + Cannot_Send_After_Transport_Endpoint_Shutdown; when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported; when ETIMEDOUT => return Connection_Timed_Out; when ETOOMANYREFS => return Too_Many_References; @@ -1639,11 +1535,12 @@ package body GNAT.Sockets is is Id : constant Exception_Id := Exception_Identity (Occurrence); Msg : constant String := Exception_Message (Occurrence); - First : Natural := Msg'First; + First : Natural; Last : Natural; Val : Integer; begin + First := Msg'First; while First <= Msg'Last and then Msg (First) not in '0' .. '9' loop @@ -1655,7 +1552,6 @@ package body GNAT.Sockets is end if; Last := First; - while Last < Msg'Last and then Msg (Last + 1) in '0' .. '9' loop @@ -1688,7 +1584,7 @@ package body GNAT.Sockets is Res := C_Readv (C.int (Socket), - Vector (Vector'First)'Address, + Vector'Address, Vector'Length); if Res = Failure then @@ -1716,7 +1612,7 @@ package body GNAT.Sockets is Res := C_Send (C.int (Socket), - Item (Item'First)'Address, + Item'Address, Item'Length, Set_Forced_Flags (To_Int (Flags))); @@ -1754,7 +1650,7 @@ package body GNAT.Sockets is Res := C_Sendto (C.int (Socket), - Item (Item'First)'Address, + Item'Address, Item'Length, Set_Forced_Flags (To_Int (Flags)), Sin'Unchecked_Access, @@ -1851,10 +1747,11 @@ package body GNAT.Sockets is Level : Level_Type := Socket_Level; Option : Option_Type) is - V8 : aliased Two_Int; + V8 : aliased Two_Ints; V4 : aliased C.int; V1 : aliased C.unsigned_char; - Len : aliased C.int; + VT : aliased Timeval; + Len : C.int; Add : System.Address := Null_Address; Res : C.int; @@ -1892,6 +1789,11 @@ package body GNAT.Sockets is Len := V8'Size / 8; Add := V8'Address; + when Multicast_If => + V4 := To_Int (To_In_Addr (Option.Outgoing_If)); + Len := V4'Size / 8; + Add := V4'Address; + when Multicast_TTL => V1 := C.unsigned_char (Option.Time_To_Live); Len := V1'Size / 8; @@ -1902,6 +1804,12 @@ package body GNAT.Sockets is Len := V1'Size / 8; Add := V1'Address; + when Send_Timeout | + Receive_Timeout => + VT := To_Timeval (Option.Timeout); + Len := VT'Size / 8; + Add := VT'Address; + end case; Res := C_Setsockopt @@ -1999,6 +1907,15 @@ package body GNAT.Sockets is return Integer (Socket); end To_C; + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (Val : Timeval) return Timeval_Duration is + begin + return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6; + end To_Duration; + ------------------- -- To_Host_Entry -- ------------------- @@ -2100,6 +2017,7 @@ package body GNAT.Sockets is if Flags (J) = -1 then Raise_Socket_Error (Constants.EOPNOTSUPP); end if; + Result := Result + Flags (J); end if; @@ -2125,19 +2043,16 @@ package body GNAT.Sockets is function To_Service_Entry (E : Servent) return Service_Entry_Type is use type C.size_t; - Official : constant String := - C.Strings.Value (E.S_Name); + Official : constant String := C.Strings.Value (E.S_Name); Aliases : constant Chars_Ptr_Array := Chars_Ptr_Pointers.Value (E.S_Aliases); -- S_Aliases points to a list of name aliases. The list is -- terminated by a NULL pointer. - Protocol : constant String := - C.Strings.Value (E.S_Proto); + Protocol : constant String := C.Strings.Value (E.S_Proto); - Result : Service_Entry_Type - (Aliases_Length => Aliases'Length - 1); + Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1); -- The last element is a null pointer Source : C.size_t; @@ -2159,7 +2074,6 @@ package body GNAT.Sockets is Port_Type (Network_To_Short (C.unsigned_short (E.S_Port))); Result.Protocol := To_Name (Protocol); - return Result; end To_Service_Entry; @@ -2176,25 +2090,25 @@ package body GNAT.Sockets is -- To_Timeval -- ---------------- - function To_Timeval (Val : Selector_Duration) return Timeval is - S : Timeval_Unit; - MS : Timeval_Unit; + function To_Timeval (Val : Timeval_Duration) return Timeval is + S : time_t; + uS : suseconds_t; begin -- If zero, set result as zero (otherwise it gets rounded down to -1) if Val = 0.0 then S := 0; - MS := 0; + uS := 0; -- Normal case where we do round down else - S := Timeval_Unit (Val - 0.5); - MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S))); + S := time_t (Val - 0.5); + uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S))); end if; - return (S, MS); + return (S, uS); end To_Timeval; -----------