-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-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);
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;
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 --
-----------------------
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
--------------------
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;
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)));
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;
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;
-----------
-- 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;
------------------
when N_Bytes_To_Read =>
null;
-
end case;
Res := C_Ioctl
---------------------
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;
-------------------
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 --
--------------
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;
----------------------
----------------------
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
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;
(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;
-------------------------
(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;
---------------------
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));
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;
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 =>
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;
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;
-- 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;
-- 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;
------------------------
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;
----------
Index,
Stream.From);
- Last := Index;
+ Last := Index;
-- Exit when all or zero data received. Zero means that the socket
-- peer is closed.
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);
Res :=
C_Recvfrom
(C.int (Socket),
- Item (Item'First)'Address,
+ Item'Address,
Item'Length,
To_Int (Flags),
Sin'Unchecked_Access,
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;
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;
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;
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;
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
end if;
Last := First;
-
while Last < Msg'Last
and then Msg (Last + 1) in '0' .. '9'
loop
Res :=
C_Readv
(C.int (Socket),
- Vector (Vector'First)'Address,
+ Vector'Address,
Vector'Length);
if Res = Failure then
Res :=
C_Send
(C.int (Socket),
- Item (Item'First)'Address,
+ Item'Address,
Item'Length,
Set_Forced_Flags (To_Int (Flags)));
Res := C_Sendto
(C.int (Socket),
- Item (Item'First)'Address,
+ Item'Address,
Item'Length,
Set_Forced_Flags (To_Int (Flags)),
Sin'Unchecked_Access,
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;
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;
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
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 --
-------------------
if Flags (J) = -1 then
Raise_Socket_Error (Constants.EOPNOTSUPP);
end if;
+
Result := Result + Flags (J);
end if;
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;
Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
Result.Protocol := To_Name (Protocol);
-
return Result;
end To_Service_Entry;
-- 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;
-----------
OSDN Git Service
