-- --
-- B o d y --
-- --
--- $Revision: 1.21 $
--- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2009, 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- --
-- 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 GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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, --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Streams; use Ada.Streams;
-with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Unchecked_Deallocation;
+with Ada.Streams; use Ada.Streams;
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Finalization;
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Sockets.Constants;
-with GNAT.Sockets.Thin; use GNAT.Sockets.Thin;
-with GNAT.Task_Lock;
+with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
+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);
--- Need to include pragma Linker_Options which is platform dependent.
+-- Need to include pragma Linker_Options which is platform dependent
-with System; use System;
+with System; use System;
+with System.Communication; use System.Communication;
+with System.CRTL; use System.CRTL;
package body GNAT.Sockets is
- use type C.int, System.Address;
+ package C renames Interfaces.C;
+
+ use type C.int;
- Finalized : Boolean := False;
- Initialized : Boolean := False;
+ ENOERROR : constant := 0;
- -- Correspondance tables
+ Netdb_Buffer_Size : constant := SOSC.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.
- Families : constant array (Family_Type) of C.int :=
- (Family_Inet => Constants.AF_INET,
- Family_Inet6 => Constants.AF_INET6);
+ -- Correspondence tables
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 => SOSC.SOL_SOCKET,
+ IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP,
+ IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
+ IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
Modes : constant array (Mode_Type) of C.int :=
- (Socket_Stream => Constants.SOCK_STREAM,
- Socket_Datagram => Constants.SOCK_DGRAM);
+ (Socket_Stream => SOSC.SOCK_STREAM,
+ Socket_Datagram => SOSC.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 => SOSC.SHUT_RD,
+ Shut_Write => SOSC.SHUT_WR,
+ Shut_Read_Write => SOSC.SHUT_RDWR);
Requests : constant array (Request_Name) of C.int :=
- (Non_Blocking_IO => Constants.FIONBIO,
- N_Bytes_To_Read => Constants.FIONREAD);
+ (Non_Blocking_IO => SOSC.FIONBIO,
+ N_Bytes_To_Read => SOSC.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 => SOSC.SO_KEEPALIVE,
+ Reuse_Address => SOSC.SO_REUSEADDR,
+ Broadcast => SOSC.SO_BROADCAST,
+ Send_Buffer => SOSC.SO_SNDBUF,
+ Receive_Buffer => SOSC.SO_RCVBUF,
+ Linger => SOSC.SO_LINGER,
+ Error => SOSC.SO_ERROR,
+ No_Delay => SOSC.TCP_NODELAY,
+ Add_Membership => SOSC.IP_ADD_MEMBERSHIP,
+ Drop_Membership => SOSC.IP_DROP_MEMBERSHIP,
+ Multicast_If => SOSC.IP_MULTICAST_IF,
+ Multicast_TTL => SOSC.IP_MULTICAST_TTL,
+ Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
+ Receive_Packet_Info => SOSC.IP_PKTINFO,
+ Send_Timeout => SOSC.SO_SNDTIMEO,
+ Receive_Timeout => SOSC.SO_RCVTIMEO);
+ -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
+ -- but for Linux compatibility this constant is the same as IP_PKTINFO.
+
+ Flags : constant array (0 .. 3) of C.int :=
+ (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data
+ 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data
+ 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception
+ 3 => SOSC.MSG_EOR); -- Send_End_Of_Record
Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
- Host_Error_Id : constant Exception_Id := Host_Error'Identity;
+ Host_Error_Id : constant Exception_Id := Host_Error'Identity;
Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
-- Use to print in hexadecimal format
- 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);
-
-----------------------
-- Local subprograms --
-----------------------
function Resolve_Error
(Error_Value : Integer;
- From_Errno : Boolean := True)
- return Error_Type;
- -- Associate an enumeration value (error_type) to en error value
- -- (errno). From_Errno prevents from mixing h_errno with errno.
+ From_Errno : Boolean := True) return Error_Type;
+ -- Associate an enumeration value (error_type) to en error value (errno).
+ -- From_Errno prevents from mixing h_errno with errno.
- function To_Host_Name (N : String) return Host_Name_Type;
- function To_String (HN : Host_Name_Type) return String;
+ function To_Name (N : String) return Name_Type;
+ function To_String (HN : Name_Type) return String;
-- Conversion functions
- function Port_To_Network
- (Port : C.unsigned_short)
- return C.unsigned_short;
- pragma Inline (Port_To_Network);
+ function To_Int (F : Request_Flag_Type) return C.int;
+ -- Return the int value corresponding to the specified flags combination
+
+ function Set_Forced_Flags (F : C.int) return C.int;
+ -- Return F with the bits from SOSC.MSG_Forced_Flags forced set
+
+ function Short_To_Network
+ (S : C.unsigned_short) return C.unsigned_short;
+ pragma Inline (Short_To_Network);
-- Convert a port number into a network port number
- function Network_To_Port
- (Net_Port : C.unsigned_short)
- return C.unsigned_short
- renames Port_To_Network;
- -- Symetric operation
+ function Network_To_Short
+ (S : C.unsigned_short) return C.unsigned_short
+ renames Short_To_Network;
+ -- Symmetric operation
function Image
(Val : Inet_Addr_VN_Type;
- Hex : Boolean := False)
- return String;
- -- Output an array of inet address components either in
- -- hexadecimal or in decimal mode.
+ Hex : Boolean := False) return String;
+ -- Output an array of inet address components in hex or decimal mode
+
+ function Is_IP_Address (Name : String) return Boolean;
+ -- Return true when Name is an IP address in standard dot notation
- function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr;
- function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type;
+ function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
+ procedure To_Inet_Addr
+ (Addr : In_Addr;
+ Result : out Inet_Addr_Type);
-- Conversion functions
- function To_Host_Entry (Host : Hostent) return Host_Entry_Type;
+ function To_Host_Entry (E : Hostent) return Host_Entry_Type;
-- Conversion function
- function To_Timeval (Val : Duration) return Timeval;
- -- Separate Val in seconds and microseconds
+ function To_Service_Entry (E : Servent_Access) return Service_Entry_Type;
+ -- Conversion function
- procedure Raise_Socket_Error (Error : Integer);
- -- Raise Socket_Error with an exception message describing
- -- the error code.
+ function To_Timeval (Val : Timeval_Duration) return Timeval;
+ -- Separate Val in seconds and microseconds
- procedure Raise_Host_Error (Error : Integer);
- -- Raise Host_Error exception with message describing error code
- -- (note hstrerror seems to be obsolete).
+ function To_Duration (Val : Timeval) return Timeval_Duration;
+ -- Reconstruct a Duration value from a Timeval record (seconds and
+ -- microseconds).
- -- Types needed for Socket_Set_Type
+ procedure Raise_Socket_Error (Error : Integer);
+ -- Raise Socket_Error with an exception message describing the error code
+ -- from errno.
- type Socket_Set_Record is new Fd_Set;
+ procedure Raise_Host_Error (H_Error : Integer);
+ -- Raise Host_Error exception with message describing error code (note
+ -- hstrerror seems to be obsolete) from h_errno.
- procedure Free is
- new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type);
+ procedure Narrow (Item : in out Socket_Set_Type);
+ -- Update Last as it may be greater than the real last socket
-- Types needed for Datagram_Socket_Stream_Type
- type Datagram_Socket_Stream_Type is new Root_Stream_Type with
- record
- Socket : Socket_Type;
- To : Sock_Addr_Type;
- From : Sock_Addr_Type;
- end record;
+ type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
+ Socket : Socket_Type;
+ To : Sock_Addr_Type;
+ From : Sock_Addr_Type;
+ end record;
type Datagram_Socket_Stream_Access is
access all Datagram_Socket_Stream_Type;
-- Types needed for Stream_Socket_Stream_Type
- type Stream_Socket_Stream_Type is new Root_Stream_Type with
- record
- Socket : Socket_Type;
- end record;
+ type Stream_Socket_Stream_Type is new Root_Stream_Type with record
+ Socket : Socket_Type;
+ end record;
type Stream_Socket_Stream_Access is
access all Stream_Socket_Stream_Type;
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array);
+ procedure Stream_Write
+ (Socket : Socket_Type;
+ Item : Ada.Streams.Stream_Element_Array;
+ To : access Sock_Addr_Type);
+ -- Common implementation for the Write operation of Datagram_Socket_Stream_
+ -- Type and Stream_Socket_Stream_Type.
+
+ procedure Wait_On_Socket
+ (Socket : Socket_Type;
+ For_Read : Boolean;
+ Timeout : Selector_Duration;
+ Selector : access Selector_Type := null;
+ Status : out Selector_Status);
+ -- Common code for variants of socket operations supporting a timeout:
+ -- block in Check_Selector on Socket for at most the indicated timeout.
+ -- If For_Read is True, Socket is added to the read set for this call, else
+ -- it is added to the write set. If no selector is provided, a local one is
+ -- created for this call and destroyed prior to returning.
+
+ type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
+ with null record;
+ -- This type is used to generate automatic calls to Initialize and Finalize
+ -- during the elaboration and finalization of this package. A single object
+ -- of this type must exist at library level.
+
+ function Err_Code_Image (E : Integer) return String;
+ -- Return the value of E surrounded with brackets
+
+ procedure Initialize (X : in out Sockets_Library_Controller);
+ procedure Finalize (X : in out Sockets_Library_Controller);
+
+ procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
+ -- If S is the empty set (detected by Last = No_Socket), make sure its
+ -- fd_set component is actually cleared. Note that the case where it is
+ -- not can occur for an uninitialized Socket_Set_Type object.
+
+ function Is_Open (S : Selector_Type) return Boolean;
+ -- Return True for an "open" Selector_Type object, i.e. one for which
+ -- Create_Selector has been called and Close_Selector has not been called.
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
+ begin
+ return L or R;
+ end "+";
+
--------------------
-- Abort_Selector --
--------------------
procedure Abort_Selector (Selector : Selector_Type) is
+ Res : C.int;
+
begin
- -- Send an empty array to unblock C select system call
+ if not Is_Open (Selector) then
+ raise Program_Error with "closed selector";
+ end if;
- if Selector.In_Progress then
- declare
- Buf : Character;
- Res : C.int;
- begin
- Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0);
- end;
+ -- Send one byte to unblock select system call
+
+ Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
end if;
end Abort_Selector;
begin
Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
+
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Socket := Socket_Type (Res);
- Address.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
+ To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
+ Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
+ end Accept_Socket;
+
+ -------------------
+ -- Accept_Socket --
+ -------------------
+
+ procedure Accept_Socket
+ (Server : Socket_Type;
+ Socket : out Socket_Type;
+ Address : out Sock_Addr_Type;
+ Timeout : Selector_Duration;
+ Selector : access Selector_Type := null;
+ Status : out Selector_Status)
+ is
+ begin
+ if Selector /= null and then not Is_Open (Selector.all) then
+ raise Program_Error with "closed selector";
+ end if;
+
+ -- Wait for socket to become available for reading
+
+ Wait_On_Socket
+ (Socket => Server,
+ For_Read => True,
+ Timeout => Timeout,
+ Selector => Selector,
+ Status => Status);
+
+ -- Accept connection if available
+
+ if Status = Completed then
+ Accept_Socket (Server, Socket, Address);
+ else
+ Socket := No_Socket;
+ end if;
end Accept_Socket;
---------------
---------------
function Addresses
- (E : Host_Entry_Type;
- N : Positive := 1)
- return Inet_Addr_Type
+ (E : Host_Entry_Type;
+ N : Positive := 1) return Inet_Addr_Type
is
begin
return E.Addresses (N);
-------------
function Aliases
- (E : Host_Entry_Type;
- N : Positive := 1)
- return String
+ (E : Host_Entry_Type;
+ N : Positive := 1) return String
is
begin
return To_String (E.Aliases (N));
end Aliases;
+ -------------
+ -- Aliases --
+ -------------
+
+ function Aliases
+ (S : Service_Entry_Type;
+ N : Positive := 1) return String
+ is
+ begin
+ return To_String (S.Aliases (N));
+ end Aliases;
+
--------------------
-- Aliases_Length --
--------------------
return E.Aliases_Length;
end Aliases_Length;
+ --------------------
+ -- Aliases_Length --
+ --------------------
+
+ function Aliases_Length (S : Service_Entry_Type) return Natural is
+ begin
+ return S.Aliases_Length;
+ end Aliases_Length;
+
-----------------
-- Bind_Socket --
-----------------
is
Res : C.int;
Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Len : constant C.int := Sin'Size / 8;
+ -- This assumes that Address.Family = Family_Inet???
begin
if Address.Family = Family_Inet6 then
- raise Socket_Error;
+ raise Socket_Error with "IPv6 not supported";
end if;
- Sin.Sin_Family := C.unsigned_short (Families (Address.Family));
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (Address.Port));
+ Set_Family (Sin.Sin_Family, 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)));
Res := C_Bind (C.int (Socket), Sin'Address, Len);
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
- Timeout : Duration := Forever)
+ Timeout : Selector_Duration := Forever)
+ is
+ E_Socket_Set : Socket_Set_Type;
+ begin
+ Check_Selector
+ (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
+ end Check_Selector;
+
+ --------------------
+ -- Check_Selector --
+ --------------------
+
+ procedure Check_Selector
+ (Selector : in out Selector_Type;
+ R_Socket_Set : in out Socket_Set_Type;
+ W_Socket_Set : in out Socket_Set_Type;
+ E_Socket_Set : in out Socket_Set_Type;
+ Status : out Selector_Status;
+ Timeout : Selector_Duration := Forever)
is
Res : C.int;
- Len : C.int;
- RSet : aliased Fd_Set;
- WSet : aliased Fd_Set;
+ Last : C.int;
+ RSig : constant Socket_Type := Selector.R_Sig_Socket;
TVal : aliased Timeval;
TPtr : Timeval_Access;
begin
+ if not Is_Open (Selector) then
+ raise Program_Error with "closed selector";
+ end if;
+
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;
TPtr := TVal'Unchecked_Access;
end if;
- -- Copy R_Socket_Set in RSet and add read signalling socket.
+ -- Add read signalling socket
- if R_Socket_Set = null then
- RSet := Null_Fd_Set;
- else
- RSet := Fd_Set (R_Socket_Set.all);
- end if;
+ Set (R_Socket_Set, RSig);
- Set (RSet, C.int (Selector.R_Sig_Socket));
- Len := Max (RSet) + 1;
+ Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
+ C.int (W_Socket_Set.Last)),
+ C.int (E_Socket_Set.Last));
- -- Copy W_Socket_Set in WSet.
+ -- Zero out fd_set for empty Socket_Set_Type objects
- if W_Socket_Set = null then
- WSet := Null_Fd_Set;
- else
- WSet := Fd_Set (W_Socket_Set.all);
- end if;
- Len := C.int'Max (Max (RSet) + 1, Len);
+ Normalize_Empty_Socket_Set (R_Socket_Set);
+ Normalize_Empty_Socket_Set (W_Socket_Set);
+ Normalize_Empty_Socket_Set (E_Socket_Set);
- Selector.In_Progress := True;
Res :=
C_Select
- (Len,
- RSet'Unchecked_Access,
- WSet'Unchecked_Access,
- null, TPtr);
- Selector.In_Progress := False;
+ (Last + 1,
+ R_Socket_Set.Set'Access,
+ W_Socket_Set.Set'Access,
+ E_Socket_Set.Set'Access,
+ 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, C.int (Selector.R_Sig_Socket)) then
- Clear (RSet, C.int (Selector.R_Sig_Socket));
+ -- If Select was resumed because of read signalling socket, read this
+ -- data and remove socket from set.
- declare
- Buf : Character;
- begin
- Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0);
- end;
+ if Is_Set (R_Socket_Set, RSig) then
+ Clear (R_Socket_Set, RSig);
- -- Select was resumed because of read signalling socket, but
- -- the call is said aborted only when there is no other read
- -- or write event.
+ Res := Signalling_Fds.Read (C.int (RSig));
- if Is_Empty (RSet)
- and then Is_Empty (WSet)
- then
- Status := Aborted;
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
end if;
+ Status := Aborted;
+
elsif Res = 0 then
Status := Expired;
end if;
- if R_Socket_Set /= null then
- R_Socket_Set.all := Socket_Set_Record (RSet);
- end if;
+ -- Update socket sets in regard to their new contents
- if W_Socket_Set /= null then
- W_Socket_Set.all := Socket_Set_Record (WSet);
- end if;
+ Narrow (R_Socket_Set);
+ Narrow (W_Socket_Set);
+ Narrow (E_Socket_Set);
end Check_Selector;
-----------
(Item : in out Socket_Set_Type;
Socket : Socket_Type)
is
+ Last : aliased C.int := C.int (Item.Last);
begin
- if Item = null then
- Item := new Socket_Set_Record;
- Empty (Fd_Set (Item.all));
+ if Item.Last /= No_Socket then
+ Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
+ Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
+ Item.Last := Socket_Type (Last);
end if;
-
- Clear (Fd_Set (Item.all), C.int (Socket));
end Clear;
--------------------
procedure Close_Selector (Selector : in out Selector_Type) is
begin
- begin
- Close_Socket (Selector.R_Sig_Socket);
- exception when Socket_Error =>
- null;
- end;
+ if not Is_Open (Selector) then
- begin
- Close_Socket (Selector.W_Sig_Socket);
- exception when Socket_Error =>
- null;
- end;
+ -- Selector already in closed state: nothing to do
+
+ return;
+ end if;
+
+ -- Close the signalling file descriptors used internally for the
+ -- implementation of Abort_Selector.
+
+ 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
+ -- (erroneous) subsequent attempt to use this selector properly fails.
+
+ Selector.R_Sig_Socket := No_Socket;
+ Selector.W_Sig_Socket := No_Socket;
end Close_Selector;
------------------
procedure Connect_Socket
(Socket : Socket_Type;
- Server : in out Sock_Addr_Type)
+ Server : Sock_Addr_Type)
is
Res : C.int;
Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Len : constant C.int := Sin'Size / 8;
begin
if Server.Family = Family_Inet6 then
- raise Socket_Error;
+ raise Socket_Error with "IPv6 not supported";
end if;
- Sin.Sin_Family := C.unsigned_short (Families (Server.Family));
- Sin.Sin_Addr := To_In_Addr (Server.Addr);
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (Server.Port));
+ Set_Family (Sin.Sin_Family, Server.Family);
+ Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
+ Set_Port
+ (Sin'Unchecked_Access,
+ Short_To_Network (C.unsigned_short (Server.Port)));
Res := C_Connect (C.int (Socket), Sin'Address, Len);
end Connect_Socket;
--------------------
+ -- Connect_Socket --
+ --------------------
+
+ procedure Connect_Socket
+ (Socket : Socket_Type;
+ Server : Sock_Addr_Type;
+ Timeout : Selector_Duration;
+ Selector : access Selector_Type := null;
+ Status : out Selector_Status)
+ is
+ Req : Request_Type;
+ -- Used to set Socket to non-blocking I/O
+
+ begin
+ if Selector /= null and then not Is_Open (Selector.all) then
+ raise Program_Error with "closed selector";
+ end if;
+
+ -- Set the socket to non-blocking I/O
+
+ Req := (Name => Non_Blocking_IO, Enabled => True);
+ Control_Socket (Socket, Request => Req);
+
+ -- Start operation (non-blocking), will raise Socket_Error with
+ -- EINPROGRESS.
+
+ begin
+ Connect_Socket (Socket, Server);
+ exception
+ when E : Socket_Error =>
+ if Resolve_Exception (E) = Operation_Now_In_Progress then
+ null;
+ else
+ raise;
+ end if;
+ end;
+
+ -- Wait for socket to become available for writing
+
+ Wait_On_Socket
+ (Socket => Socket,
+ For_Read => False,
+ Timeout => Timeout,
+ Selector => Selector,
+ Status => Status);
+
+ -- Reset the socket to blocking I/O
+
+ Req := (Name => Non_Blocking_IO, Enabled => False);
+ Control_Socket (Socket, Request => Req);
+ end Connect_Socket;
+
+ --------------------
-- Control_Socket --
--------------------
when N_Bytes_To_Read =>
null;
-
end case;
- Res := C_Ioctl
- (C.int (Socket),
- Requests (Request.Name),
- Arg'Unchecked_Access);
+ Res := Socket_Ioctl
+ (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
when N_Bytes_To_Read =>
Request.Size := Natural (Arg);
-
end case;
end Control_Socket;
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy
+ (Source : Socket_Set_Type;
+ Target : out Socket_Set_Type)
+ is
+ begin
+ Target := Source;
+ end Copy;
+
---------------------
-- Create_Selector --
---------------------
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 socket to send a signal
- -- to a another socket that always included in a C_Select
- -- socket set. When received, it resumes the task suspended in
- -- C_Select.
-
- -- 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;
-
- -- Sin is already correctly initialized. Bind the socket to any
- -- unused port.
-
- 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;
-
- Res := C_Listen (S0, 2);
- if Res = Failure then
- Err := Socket_Errno;
- Res := C_Close (S0);
- Raise_Socket_Error (Err);
- end if;
+ if Is_Open (Selector) then
+ -- Raise exception to prevent socket descriptor leak
- 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);
+ raise Program_Error with "selector already open";
end if;
- -- Use INADDR_LOOPBACK
-
- Sin.Sin_Addr.S_B1 := 127;
- Sin.Sin_Addr.S_B2 := 0;
- Sin.Sin_Addr.S_B3 := 0;
- Sin.Sin_Addr.S_B4 := 1;
-
- -- 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;
+ -- 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.
- 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 := Signalling_Fds.Create (Two_Fds'Access);
- Res := C_Close (S0);
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;
-------------------
-- Empty --
-----------
- procedure Empty (Item : in out Socket_Set_Type) is
+ procedure Empty (Item : out Socket_Set_Type) is
begin
- if Item /= null then
- Free (Item);
- end if;
+ Reset_Socket_Set (Item.Set'Access);
+ 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 --
+ --------------
+
+ procedure Finalize (X : in out Sockets_Library_Controller) is
+ pragma Unreferenced (X);
+
+ begin
+ -- Finalization operation for the GNAT.Sockets package
+
+ Thin.Finalize;
+ end Finalize;
+
--------------
-- Finalize --
--------------
procedure Finalize is
begin
- if not Finalized
- and then Initialized
- then
- Finalized := True;
- Thin.Finalize;
- end if;
+ -- This is a dummy placeholder for an obsolete API.
+ -- The real finalization actions are in Initialize primitive operation
+ -- of Sockets_Library_Controller.
+
+ null;
end Finalize;
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (Item : in out Socket_Set_Type;
+ Socket : out Socket_Type)
+ is
+ S : aliased C.int;
+ L : aliased C.int := C.int (Item.Last);
+
+ begin
+ if Item.Last /= No_Socket then
+ Get_Socket_From_Set
+ (Item.Set'Access, Last => L'Access, Socket => S'Access);
+ Item.Last := Socket_Type (L);
+ Socket := Socket_Type (S);
+ else
+ Socket := No_Socket;
+ end if;
+ end Get;
+
-----------------
-- Get_Address --
-----------------
- function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is
+ function Get_Address
+ (Stream : not null Stream_Access) return Sock_Addr_Type
+ is
begin
- if Stream = null then
- raise Socket_Error;
-
- elsif Stream.all in Datagram_Socket_Stream_Type then
+ if Stream.all in Datagram_Socket_Stream_Type then
return Datagram_Socket_Stream_Type (Stream.all).From;
-
else
return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
end if;
function Get_Host_By_Address
(Address : Inet_Addr_Type;
- Family : Family_Type := Family_Inet)
- return Host_Entry_Type
+ Family : Family_Type := Family_Inet) return Host_Entry_Type
is
- HA : aliased In_Addr := To_In_Addr (Address);
- Res : Hostent_Access;
- Err : Integer;
-
- begin
- -- This C function is not always thread-safe. Protect against
- -- concurrent access.
+ pragma Unreferenced (Family);
- Task_Lock.Lock;
- Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET);
+ 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;
- if Res = null then
- Err := Socket_Errno;
- Task_Lock.Unlock;
- Raise_Host_Error (Err);
+ begin
+ if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.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 : 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;
----------------------
-- Get_Host_By_Name --
----------------------
- function Get_Host_By_Name
- (Name : String)
- return Host_Entry_Type
- is
- HN : C.char_array := C.To_C (Name);
- Res : Hostent_Access;
- Err : Integer;
-
+ function Get_Host_By_Name (Name : String) return Host_Entry_Type is
begin
- -- This C function is not always thread-safe. Protect against
- -- concurrent access.
+ -- Detect IP address name and redirect to Inet_Addr
- Task_Lock.Lock;
- Res := C_Gethostbyname (HN);
-
- if Res = null then
- Err := Socket_Errno;
- Task_Lock.Unlock;
- Raise_Host_Error (Err);
+ if Is_IP_Address (Name) then
+ return Get_Host_By_Address (Inet_Addr (Name));
end if;
- -- Translate from the C format to the API format
-
declare
- HE : 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;
-- Get_Peer_Name --
-------------------
- function Get_Peer_Name
- (Socket : Socket_Type)
- return Sock_Addr_Type
- is
+ function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
Sin : aliased Sockaddr_In;
Len : aliased C.int := Sin'Size / 8;
Res : Sock_Addr_Type (Family_Inet);
Raise_Socket_Error (Socket_Errno);
end if;
- Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
+ To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
+ Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
return Res;
end Get_Peer_Name;
+ -------------------------
+ -- Get_Service_By_Name --
+ -------------------------
+
+ function Get_Service_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);
+ Buflen : constant C.int := Netdb_Buffer_Size;
+ Buf : aliased C.char_array (1 .. Netdb_Buffer_Size);
+ Res : aliased Servent;
+
+ begin
+ if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
+ raise Service_Error with "Service not found";
+ end if;
+
+ -- Translate from the C format to the API format
+
+ return To_Service_Entry (Res'Unchecked_Access);
+ end Get_Service_By_Name;
+
+ -------------------------
+ -- Get_Service_By_Port --
+ -------------------------
+
+ function Get_Service_By_Port
+ (Port : Port_Type;
+ Protocol : String) return Service_Entry_Type
+ is
+ 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
+ if Safe_Getservbyport
+ (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
+ Res'Access, Buf'Address, Buflen) /= 0
+ then
+ raise Service_Error with "Service not found";
+ end if;
+
+ -- Translate from the C format to the API format
+
+ return To_Service_Entry (Res'Unchecked_Access);
+ end Get_Service_By_Port;
+
---------------------
-- Get_Socket_Name --
---------------------
function Get_Socket_Name
- (Socket : Socket_Type)
- return Sock_Addr_Type
+ (Socket : Socket_Type) return Sock_Addr_Type
is
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
- Res : Sock_Addr_Type (Family_Inet);
+ Sin : aliased Sockaddr_In;
+ Len : aliased C.int := Sin'Size / 8;
+ Res : C.int;
+ Addr : Sock_Addr_Type := No_Sock_Addr;
begin
- if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
+ Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
- Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
+ if Res /= Failure then
+ To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
+ Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
+ end if;
- return Res;
+ return Addr;
end Get_Socket_Name;
-----------------------
function Get_Socket_Option
(Socket : Socket_Type;
Level : Level_Type := Socket_Level;
- Name : Option_Name)
- return Option_Type
+ Name : Option_Name) return Option_Type
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;
begin
case Name is
- when Multicast_Loop |
- Multicast_TTL =>
+ when Multicast_Loop |
+ Multicast_TTL |
+ Receive_Packet_Info =>
Len := V1'Size / 8;
Add := V1'Address;
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 =>
end case;
- Res := C_Getsockopt
- (C.int (Socket),
- Levels (Level),
- Options (Name),
- Add, Len'Unchecked_Access);
+ Res :=
+ C_Getsockopt
+ (C.int (Socket),
+ Levels (Level),
+ Options (Name),
+ Add, Len'Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
when Add_Membership |
Drop_Membership =>
- Opt.Multiaddr := To_Inet_Addr (To_In_Addr (V8 (V8'First)));
- Opt.Interface := To_Inet_Addr (To_In_Addr (V8 (V8'Last)));
+ 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 =>
+ when Multicast_Loop |
+ Receive_Packet_Info =>
Opt.Enabled := (V1 /= 0);
+ when Send_Timeout |
+ Receive_Timeout =>
+ Opt.Timeout := To_Duration (VT);
end case;
return Opt;
-----------
function Image
- (Val : Inet_Addr_VN_Type;
- Hex : Boolean := False)
- return String
+ (Val : Inet_Addr_VN_Type;
+ Hex : Boolean := False) return String
is
-- The largest Inet_Addr_Comp_Type image occurs with IPv4. It
-- has at most a length of 3 plus one '.' character.
procedure Img16 (V : Inet_Addr_Comp_Type);
-- Append to Buffer image of V in hexadecimal format
+ -----------
+ -- Img10 --
+ -----------
+
procedure Img10 (V : Inet_Addr_Comp_Type) is
Img : constant String := V'Img;
- Len : Natural := Img'Length - 1;
-
+ Len : constant Natural := Img'Length - 1;
begin
Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
Length := Length + Len;
end Img10;
+ -----------
+ -- Img16 --
+ -----------
+
procedure Img16 (V : Inet_Addr_Comp_Type) is
begin
Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1);
-- Start of processing for Image
begin
- if Hex then
- Separator := ':';
- else
- Separator := '.';
- end if;
+ Separator := (if Hex then ':' else '.');
for J in Val'Range loop
if Hex then
function Image (Value : Sock_Addr_Type) return String is
Port : constant String := Value.Port'Img;
-
begin
return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
end Image;
return Socket'Img;
end Image;
- ---------------
- -- Inet_Addr --
- ---------------
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Item : Socket_Set_Type) return String is
+ Socket_Set : Socket_Set_Type := Item;
+
+ begin
+ declare
+ Last_Img : constant String := Socket_Set.Last'Img;
+ Buffer : String
+ (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
+ Index : Positive := 1;
+ Socket : Socket_Type;
+
+ begin
+ while not Is_Empty (Socket_Set) loop
+ Get (Socket_Set, Socket);
+
+ declare
+ Socket_Img : constant String := Socket'Img;
+ begin
+ Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
+ Index := Index + Socket_Img'Length;
+ end;
+ end loop;
+
+ return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
+ end;
+ end Image;
+
+ ---------------
+ -- Inet_Addr --
+ ---------------
function Inet_Addr (Image : String) return Inet_Addr_Type is
+ use Interfaces.C;
use Interfaces.C.Strings;
- Img : chars_ptr := New_String (Image);
- Res : C.int;
- Err : Integer;
+ Img : aliased char_array := To_C (Image);
+ Cp : constant chars_ptr := To_Chars_Ptr (Img'Unchecked_Access);
+ Addr : aliased C.int;
+ Res : C.int;
+ Result : Inet_Addr_Type;
begin
- Res := C_Inet_Addr (Img);
- Err := Errno;
- Free (Img);
+ -- Special case for an empty Image as on some platforms (e.g. Windows)
+ -- calling Inet_Addr("") will not return an error.
- if Res = Failure then
- Raise_Socket_Error (Err);
+ if Image = "" then
+ Raise_Socket_Error (SOSC.EINVAL);
end if;
- return To_Inet_Addr (To_In_Addr (Res));
+ Res := Inet_Pton (SOSC.AF_INET, Cp, Addr'Address);
+
+ if Res < 0 then
+ Raise_Socket_Error (Socket_Errno);
+
+ elsif Res = 0 then
+ Raise_Socket_Error (SOSC.EINVAL);
+ end if;
+
+ To_Inet_Addr (To_In_Addr (Addr), Result);
+ return Result;
end Inet_Addr;
----------------
-- Initialize --
----------------
- procedure Initialize (Process_Blocking_IO : Boolean := False) is
+ procedure Initialize (X : in out Sockets_Library_Controller) is
+ pragma Unreferenced (X);
+
+ begin
+ Thin.Initialize;
+ end Initialize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Process_Blocking_IO : Boolean) is
+ Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
+
begin
- if not Initialized then
- Initialized := True;
- Thin.Initialize (Process_Blocking_IO);
+ if Process_Blocking_IO /= Expected then
+ raise Socket_Error with
+ "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
end if;
+
+ -- This is a dummy placeholder for an obsolete API
+
+ -- Real initialization actions are in Initialize primitive operation
+ -- of Sockets_Library_Controller.
+
+ null;
+ end Initialize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ -- This is a dummy placeholder for an obsolete API
+
+ -- Real initialization actions are in Initialize primitive operation
+ -- of Sockets_Library_Controller.
+
+ null;
end Initialize;
--------------
function Is_Empty (Item : Socket_Set_Type) return Boolean is
begin
- return Item = null or else Is_Empty (Fd_Set (Item.all));
+ return Item.Last = No_Socket;
end Is_Empty;
+ -------------------
+ -- Is_IP_Address --
+ -------------------
+
+ function Is_IP_Address (Name : String) return Boolean is
+ begin
+ for J in Name'Range loop
+ if Name (J) /= '.'
+ and then Name (J) not in '0' .. '9'
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_IP_Address;
+
+ -------------
+ -- Is_Open --
+ -------------
+
+ function Is_Open (S : Selector_Type) return Boolean is
+ begin
+ -- Either both controlling socket descriptors are valid (case of an
+ -- open selector) or neither (case of a closed selector).
+
+ pragma Assert ((S.R_Sig_Socket /= No_Socket)
+ =
+ (S.W_Sig_Socket /= No_Socket));
+
+ return S.R_Sig_Socket /= No_Socket;
+ end Is_Open;
+
------------
-- Is_Set --
------------
Socket : Socket_Type) return Boolean
is
begin
- return Item /= null
- and then Is_Set (Fd_Set (Item.all), C.int (Socket));
+ return Item.Last /= No_Socket
+ and then Socket <= Item.Last
+ and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
end Is_Set;
-------------------
procedure Listen_Socket
(Socket : Socket_Type;
- Length : Positive := 15)
+ Length : Natural := 15)
is
- Res : C.int;
-
+ Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
begin
- Res := C_Listen (C.int (Socket), C.int (Length));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end Listen_Socket;
+ ------------
+ -- Narrow --
+ ------------
+
+ procedure Narrow (Item : in out Socket_Set_Type) is
+ Last : aliased C.int := C.int (Item.Last);
+ begin
+ if Item.Last /= No_Socket then
+ Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
+ Item.Last := Socket_Type (Last);
+ end if;
+ end Narrow;
+
+ --------------------------------
+ -- Normalize_Empty_Socket_Set --
+ --------------------------------
+
+ procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
+ begin
+ if S.Last = No_Socket then
+ Reset_Socket_Set (S.Set'Access);
+ end if;
+ end Normalize_Empty_Socket_Set;
+
-------------------
-- Official_Name --
-------------------
return To_String (E.Official);
end Official_Name;
- ---------------------
- -- Port_To_Network --
- ---------------------
+ -------------------
+ -- Official_Name --
+ -------------------
+
+ function Official_Name (S : Service_Entry_Type) return String is
+ begin
+ return To_String (S.Official);
+ end Official_Name;
+
+ --------------------
+ -- Wait_On_Socket --
+ --------------------
- function Port_To_Network
- (Port : C.unsigned_short)
- return C.unsigned_short
+ procedure Wait_On_Socket
+ (Socket : Socket_Type;
+ For_Read : Boolean;
+ Timeout : Selector_Duration;
+ Selector : access Selector_Type := null;
+ Status : out Selector_Status)
is
- use type C.unsigned_short;
+ type Local_Selector_Access is access Selector_Type;
+ for Local_Selector_Access'Storage_Size use Selector_Type'Size;
+
+ S : Selector_Access;
+ -- Selector to use for waiting
+
+ R_Fd_Set : Socket_Set_Type;
+ W_Fd_Set : Socket_Set_Type;
+
begin
- if Default_Bit_Order = High_Order_First then
+ -- Create selector if not provided by the user
- -- No conversion needed. On these platforms, htons() defaults
- -- to a null procedure.
+ if Selector = null then
+ declare
+ Local_S : constant Local_Selector_Access := new Selector_Type;
+ begin
+ S := Local_S.all'Unchecked_Access;
+ Create_Selector (S.all);
+ end;
- return Port;
+ else
+ S := Selector.all'Access;
+ end if;
+ if For_Read then
+ Set (R_Fd_Set, Socket);
else
- -- We need to swap the high and low byte on this short to make
- -- the port number network compliant.
+ Set (W_Fd_Set, Socket);
+ end if;
+
+ Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
- return (Port / 256) + (Port mod 256) * 256;
+ if Selector = null then
+ Close_Selector (S.all);
end if;
- end Port_To_Network;
+ end Wait_On_Socket;
- ----------------------
- -- Raise_Host_Error --
- ----------------------
+ -----------------
+ -- Port_Number --
+ -----------------
- procedure Raise_Host_Error (Error : Integer) is
+ function Port_Number (S : Service_Entry_Type) return Port_Type is
+ begin
+ return S.Port;
+ end Port_Number;
- function 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.
+ -------------------
+ -- Protocol_Name --
+ -------------------
- function 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_ADDRESS => return "No address";
- when others => return "Unknown error";
- end case;
- end Error_Message;
+ function Protocol_Name (S : Service_Entry_Type) return String is
+ begin
+ return To_String (S.Protocol);
+ end Protocol_Name;
- -- Start of processing for Raise_Host_Error
+ ----------------------
+ -- Raise_Host_Error --
+ ----------------------
+ procedure Raise_Host_Error (H_Error : Integer) is
begin
- Ada.Exceptions.Raise_Exception (Host_Error'Identity, Error_Message);
+ raise Host_Error with
+ 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;
- function Image (E : Integer) return String is
- Msg : String := E'Img & "] ";
- begin
- Msg (Msg'First) := '[';
- return Msg;
- end Image;
-
begin
- Ada.Exceptions.Raise_Exception
- (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error));
+ raise Socket_Error with
+ 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.
+ -- Exit when all or zero data received. Zero means that the socket
+ -- peer is closed.
exit when Index < First or else Index = Max;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset)
is
+ pragma Warnings (Off, Stream);
+
First : Ada.Streams.Stream_Element_Offset := Item'First;
Index : Ada.Streams.Stream_Element_Offset := First - 1;
Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
Receive_Socket (Stream.Socket, Item (First .. Max), Index);
Last := Index;
- -- Exit when all or zero data received. Zero means that
- -- the socket peer is closed.
+ -- Exit when all or zero data received. Zero means that the socket
+ -- peer is closed.
exit when Index < First or else Index = Max;
end loop;
end Read;
+ --------------------
+ -- Receive_Socket --
+ --------------------
+
+ procedure Receive_Socket
+ (Socket : Socket_Type;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ Res : C.int;
+
+ begin
+ Res :=
+ C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Last := Last_Index (First => Item'First, Count => size_t (Res));
+ end Receive_Socket;
+
+ --------------------
+ -- Receive_Socket --
+ --------------------
+
+ procedure Receive_Socket
+ (Socket : Socket_Type;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset;
+ From : out Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ Res : C.int;
+ Sin : aliased Sockaddr_In;
+ Len : aliased C.int := Sin'Size / 8;
+
+ begin
+ Res :=
+ C_Recvfrom
+ (C.int (Socket),
+ Item'Address,
+ Item'Length,
+ To_Int (Flags),
+ Sin'Address,
+ Len'Access);
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Last := Last_Index (First => Item'First, Count => size_t (Res));
+
+ To_Inet_Addr (Sin.Sin_Addr, From.Addr);
+ From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
+ end Receive_Socket;
+
+ --------------------
+ -- Receive_Vector --
+ --------------------
+
+ procedure Receive_Vector
+ (Socket : Socket_Type;
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ Res : ssize_t;
+
+ Msg : Msghdr :=
+ (Msg_Name => System.Null_Address,
+ Msg_Namelen => 0,
+ Msg_Iov => Vector'Address,
+
+ -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other
+ -- platforms) when the supplied vector is longer than IOV_MAX,
+ -- so use minimum of the two lengths.
+
+ Msg_Iovlen => SOSC.Msg_Iovlen_T'Min
+ (Vector'Length, SOSC.IOV_MAX),
+
+ Msg_Control => System.Null_Address,
+ Msg_Controllen => 0,
+ Msg_Flags => 0);
+
+ begin
+ Res :=
+ C_Recvmsg
+ (C.int (Socket),
+ Msg'Address,
+ To_Int (Flags));
+
+ if Res = ssize_t (Failure) then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Count := Ada.Streams.Stream_Element_Count (Res);
+ end Receive_Vector;
+
-------------------
-- Resolve_Error --
-------------------
function Resolve_Error
(Error_Value : Integer;
- From_Errno : Boolean := True)
- return Error_Type
+ From_Errno : Boolean := True) return Error_Type
is
- use GNAT.Sockets.Constants;
+ use GNAT.Sockets.SOSC;
begin
if not From_Errno then
case Error_Value is
- when HOST_NOT_FOUND => return Unknown_Host;
- when TRY_AGAIN => return Host_Name_Lookup_Failure;
- when NO_RECOVERY => return No_Address_Associated_With_Name;
- when NO_ADDRESS => return Unknown_Server_Error;
- when others => return Cannot_Resolve_Error;
+ when SOSC.HOST_NOT_FOUND => return Unknown_Host;
+ when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure;
+ when SOSC.NO_RECOVERY => return Non_Recoverable_Error;
+ when SOSC.NO_DATA => return Unknown_Server_Error;
+ when others => return Cannot_Resolve_Error;
end case;
end if;
- case Error_Value 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 EALREADY => return Operation_Already_In_Progress;
- when EBADF => return Bad_File_Descriptor;
- when ECONNREFUSED => return Connection_Refused;
- when EFAULT => return Bad_Address;
- when EINPROGRESS => return Operation_Now_In_Progress;
- when EINTR => return Interrupted_System_Call;
- when EINVAL => return Invalid_Argument;
- when EIO => return Input_Output_Error;
- when EISCONN => return Transport_Endpoint_Already_Connected;
- when EMSGSIZE => return Message_Too_Long;
- when ENETUNREACH => return Network_Is_Unreachable;
- when ENOBUFS => return No_Buffer_Space_Available;
- when ENOPROTOOPT => return Protocol_Not_Available;
- when ENOTCONN => return Transport_Endpoint_Not_Connected;
- when EOPNOTSUPP => return Operation_Not_Supported;
- when EPROTONOSUPPORT => return Protocol_Not_Supported;
- when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
- when ETIMEDOUT => return Connection_Timed_Out;
- when EWOULDBLOCK => return Resource_Temporarily_Unavailable;
- when others => return Cannot_Resolve_Error;
- end case;
+
+ -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
+ -- can't include it in the case statement below.
+
+ pragma Warnings (Off);
+ -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
+
+ if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
+ return Resource_Temporarily_Unavailable;
+ end if;
+
+ pragma Warnings (On);
+
+ -- This is not a case statement because if a particular error
+ -- number constant is not defined, s-oscons-tmplt.c defines
+ -- it to -1. If multiple constants are not defined, they
+ -- would each be -1 and result in a "duplicate value in case" error.
+ if Error_Value = ENOERROR then
+ return Success;
+ elsif Error_Value = EACCES then
+ return Permission_Denied;
+ elsif Error_Value = EADDRINUSE then
+ return Address_Already_In_Use;
+ elsif Error_Value = EADDRNOTAVAIL then
+ return Cannot_Assign_Requested_Address;
+ elsif Error_Value = EAFNOSUPPORT then
+ return Address_Family_Not_Supported_By_Protocol;
+ elsif Error_Value = EALREADY then
+ return Operation_Already_In_Progress;
+ elsif Error_Value = EBADF then
+ return Bad_File_Descriptor;
+ elsif Error_Value = ECONNABORTED then
+ return Software_Caused_Connection_Abort;
+ elsif Error_Value = ECONNREFUSED then
+ return Connection_Refused;
+ elsif Error_Value = ECONNRESET then
+ return Connection_Reset_By_Peer;
+ elsif Error_Value = EDESTADDRREQ then
+ return Destination_Address_Required;
+ elsif Error_Value = EFAULT then
+ return Bad_Address;
+ elsif Error_Value = EHOSTDOWN then
+ return Host_Is_Down;
+ elsif Error_Value = EHOSTUNREACH then
+ return No_Route_To_Host;
+ elsif Error_Value = EINPROGRESS then
+ return Operation_Now_In_Progress;
+ elsif Error_Value = EINTR then
+ return Interrupted_System_Call;
+ elsif Error_Value = EINVAL then
+ return Invalid_Argument;
+ elsif Error_Value = EIO then
+ return Input_Output_Error;
+ elsif Error_Value = EISCONN then
+ return Transport_Endpoint_Already_Connected;
+ elsif Error_Value = ELOOP then
+ return Too_Many_Symbolic_Links;
+ elsif Error_Value = EMFILE then
+ return Too_Many_Open_Files;
+ elsif Error_Value = EMSGSIZE then
+ return Message_Too_Long;
+ elsif Error_Value = ENAMETOOLONG then
+ return File_Name_Too_Long;
+ elsif Error_Value = ENETDOWN then
+ return Network_Is_Down;
+ elsif Error_Value = ENETRESET then
+ return Network_Dropped_Connection_Because_Of_Reset;
+ elsif Error_Value = ENETUNREACH then
+ return Network_Is_Unreachable;
+ elsif Error_Value = ENOBUFS then
+ return No_Buffer_Space_Available;
+ elsif Error_Value = ENOPROTOOPT then
+ return Protocol_Not_Available;
+ elsif Error_Value = ENOTCONN then
+ return Transport_Endpoint_Not_Connected;
+ elsif Error_Value = ENOTSOCK then
+ return Socket_Operation_On_Non_Socket;
+ elsif Error_Value = EOPNOTSUPP then
+ return Operation_Not_Supported;
+ elsif Error_Value = EPFNOSUPPORT then
+ return Protocol_Family_Not_Supported;
+ elsif Error_Value = EPIPE then
+ return Broken_Pipe;
+ elsif Error_Value = EPROTONOSUPPORT then
+ return Protocol_Not_Supported;
+ elsif Error_Value = EPROTOTYPE then
+ return Protocol_Wrong_Type_For_Socket;
+ elsif Error_Value = ESHUTDOWN then
+ return Cannot_Send_After_Transport_Endpoint_Shutdown;
+ elsif Error_Value = ESOCKTNOSUPPORT then
+ return Socket_Type_Not_Supported;
+ elsif Error_Value = ETIMEDOUT then
+ return Connection_Timed_Out;
+ elsif Error_Value = ETOOMANYREFS then
+ return Too_Many_References;
+ elsif Error_Value = EWOULDBLOCK then
+ return Resource_Temporarily_Unavailable;
+ else
+ return Cannot_Resolve_Error;
+ end if;
end Resolve_Error;
-----------------------
-----------------------
function Resolve_Exception
- (Occurrence : Exception_Occurrence)
- return Error_Type
+ (Occurrence : Exception_Occurrence) return Error_Type
is
- Id : Exception_Id := Exception_Identity (Occurrence);
- Msg : constant String := Exception_Message (Occurrence);
- First : Natural := Msg'First;
+ Id : constant Exception_Id := Exception_Identity (Occurrence);
+ Msg : constant String := Exception_Message (Occurrence);
+ 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
end if;
end Resolve_Exception;
- --------------------
- -- Receive_Socket --
- --------------------
-
- procedure Receive_Socket
- (Socket : Socket_Type;
- Item : out Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset)
- is
- use type Ada.Streams.Stream_Element_Offset;
-
- Res : C.int;
-
- begin
- Res := C_Recv
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0);
-
- if Res = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
-
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
- end Receive_Socket;
-
- --------------------
- -- Receive_Socket --
- --------------------
+ -----------------
+ -- Send_Socket --
+ -----------------
- procedure Receive_Socket
+ procedure Send_Socket
(Socket : Socket_Type;
- Item : out Ada.Streams.Stream_Element_Array;
+ Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
- From : out Sock_Addr_Type)
+ Flags : Request_Flag_Type := No_Request_Flag)
is
- use type Ada.Streams.Stream_Element_Offset;
-
- Res : C.int;
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
-
begin
- Res := C_Recvfrom
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0,
- Sin'Unchecked_Access,
- Len'Unchecked_Access);
-
- if Res = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
-
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
-
- From.Addr := To_Inet_Addr (Sin.Sin_Addr);
- From.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
- end Receive_Socket;
+ Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
+ end Send_Socket;
-----------------
-- Send_Socket --
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset)
+ Last : out Ada.Streams.Stream_Element_Offset;
+ To : Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag)
is
- use type Ada.Streams.Stream_Element_Offset;
-
- Res : C.int;
-
begin
- Res := C_Send
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0);
-
- if Res = Failure then
- Raise_Socket_Error (Socket_Errno);
- end if;
-
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
+ Send_Socket
+ (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
end Send_Socket;
-----------------
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
- To : Sock_Addr_Type)
+ To : access Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag)
is
- use type Ada.Streams.Stream_Element_Offset;
+ Res : C.int;
- Res : C.int;
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Sin : aliased Sockaddr_In;
+ C_To : System.Address;
+ Len : C.int;
begin
- Sin.Sin_Family := C.unsigned_short (Families (To.Family));
- Sin.Sin_Addr := To_In_Addr (To.Addr);
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (To.Port));
+ if To /= null then
+ Set_Family (Sin.Sin_Family, To.Family);
+ Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
+ Set_Port
+ (Sin'Unchecked_Access,
+ Short_To_Network (C.unsigned_short (To.Port)));
+ C_To := Sin'Address;
+ Len := Sin'Size / 8;
+
+ else
+ C_To := System.Null_Address;
+ Len := 0;
+ end if;
Res := C_Sendto
(C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0,
- Sin'Unchecked_Access,
+ Item'Address,
+ Item'Length,
+ Set_Forced_Flags (To_Int (Flags)),
+ C_To,
Len);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
+ Last := Last_Index (First => Item'First, Count => size_t (Res));
end Send_Socket;
+ -----------------
+ -- Send_Vector --
+ -----------------
+
+ procedure Send_Vector
+ (Socket : Socket_Type;
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ use SOSC;
+ use Interfaces.C;
+
+ Res : ssize_t;
+ Iov_Count : SOSC.Msg_Iovlen_T;
+ This_Iov_Count : SOSC.Msg_Iovlen_T;
+ Msg : Msghdr;
+
+ begin
+ Count := 0;
+ Iov_Count := 0;
+ while Iov_Count < Vector'Length loop
+
+ pragma Warnings (Off);
+ -- Following test may be compile time known on some targets
+
+ This_Iov_Count :=
+ (if Vector'Length - Iov_Count > SOSC.IOV_MAX
+ then SOSC.IOV_MAX
+ else Vector'Length - Iov_Count);
+
+ pragma Warnings (On);
+
+ Msg :=
+ (Msg_Name => System.Null_Address,
+ Msg_Namelen => 0,
+ Msg_Iov => Vector
+ (Vector'First + Integer (Iov_Count))'Address,
+ Msg_Iovlen => This_Iov_Count,
+ Msg_Control => System.Null_Address,
+ Msg_Controllen => 0,
+ Msg_Flags => 0);
+
+ Res :=
+ C_Sendmsg
+ (C.int (Socket),
+ Msg'Address,
+ Set_Forced_Flags (To_Int (Flags)));
+
+ if Res = ssize_t (Failure) then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Count := Count + Ada.Streams.Stream_Element_Count (Res);
+ Iov_Count := Iov_Count + This_Iov_Count;
+ end loop;
+ end Send_Vector;
+
---------
-- Set --
---------
procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
begin
- if Item = null then
- Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set));
+ if Item.Last = No_Socket then
+
+ -- Uninitialized socket set, make sure it is properly zeroed out
+
+ Reset_Socket_Set (Item.Set'Access);
+ Item.Last := Socket;
+
+ elsif Item.Last < Socket then
+ Item.Last := Socket;
end if;
- Set (Fd_Set (Item.all), C.int (Socket));
+ Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
end Set;
+ ----------------------
+ -- Set_Forced_Flags --
+ ----------------------
+
+ function Set_Forced_Flags (F : C.int) return C.int is
+ use type C.unsigned;
+ function To_unsigned is
+ new Ada.Unchecked_Conversion (C.int, C.unsigned);
+ function To_int is
+ new Ada.Unchecked_Conversion (C.unsigned, C.int);
+ begin
+ return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
+ end Set_Forced_Flags;
+
-----------------------
-- Set_Socket_Option --
-----------------------
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;
when Add_Membership |
Drop_Membership =>
- V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr));
- V8 (V8'Last) := To_Int (To_In_Addr (Option.Interface));
+ V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
+ V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
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;
Add := V1'Address;
- when Multicast_Loop =>
+ when Multicast_Loop |
+ Receive_Packet_Info =>
V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
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
end if;
end Set_Socket_Option;
+ ----------------------
+ -- Short_To_Network --
+ ----------------------
+
+ function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
+ use type C.unsigned_short;
+
+ begin
+ -- Big-endian case. No conversion needed. On these platforms,
+ -- htons() defaults to a null procedure.
+
+ pragma Warnings (Off);
+ -- Since the test can generate "always True/False" warning
+
+ if Default_Bit_Order = High_Order_First then
+ return S;
+
+ pragma Warnings (On);
+
+ -- Little-endian case. We must swap the high and low bytes of this
+ -- short to make the port number network compliant.
+
+ else
+ return (S / 256) + (S mod 256) * 256;
+ end if;
+ end Short_To_Network;
+
---------------------
-- Shutdown_Socket --
---------------------
begin
Res := C_Shutdown (C.int (Socket), Shutmodes (How));
+
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
function Stream
(Socket : Socket_Type;
- Send_To : Sock_Addr_Type)
- return Stream_Access
+ Send_To : Sock_Addr_Type) return Stream_Access
is
S : Datagram_Socket_Stream_Access;
begin
- S := new Datagram_Socket_Stream_Type;
+ S := new Datagram_Socket_Stream_Type;
S.Socket := Socket;
S.To := Send_To;
S.From := Get_Socket_Name (Socket);
-- Stream --
------------
- function Stream
- (Socket : Socket_Type)
- return Stream_Access
- is
+ function Stream (Socket : Socket_Type) return Stream_Access is
S : Stream_Socket_Stream_Access;
-
begin
S := new Stream_Socket_Stream_Type;
S.Socket := Socket;
return Stream_Access (S);
end Stream;
+ ------------------
+ -- Stream_Write --
+ ------------------
+
+ procedure Stream_Write
+ (Socket : Socket_Type;
+ Item : Ada.Streams.Stream_Element_Array;
+ To : access Sock_Addr_Type)
+ is
+ First : Ada.Streams.Stream_Element_Offset;
+ Index : Ada.Streams.Stream_Element_Offset;
+ Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
+
+ begin
+ First := Item'First;
+ Index := First - 1;
+ while First <= Max loop
+ Send_Socket (Socket, Item (First .. Max), Index, To);
+
+ -- Exit when all or zero data sent. Zero means that the socket has
+ -- been closed by peer.
+
+ exit when Index < First or else Index = Max;
+
+ First := Index + 1;
+ end loop;
+
+ -- For an empty array, we have First > Max, and hence Index >= Max (no
+ -- error, the loop above is never executed). After a succesful send,
+ -- Index = Max. The only remaining case, Index < Max, is therefore
+ -- always an actual send failure.
+
+ if Index < Max then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+ end Stream_Write;
+
----------
-- To_C --
----------
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 --
-------------------
- function To_Host_Entry
- (Host : Hostent)
- return Host_Entry_Type
- is
+ function To_Host_Entry (E : Hostent) return Host_Entry_Type is
use type C.size_t;
Official : constant String :=
- C.Strings.Value (Host.H_Name);
+ C.Strings.Value (E.H_Name);
Aliases : constant Chars_Ptr_Array :=
- Chars_Ptr_Pointers.Value (Host.H_Aliases);
- -- H_Aliases points to a list of name aliases. The list is
- -- terminated by a NULL pointer.
+ Chars_Ptr_Pointers.Value (E.H_Aliases);
+ -- H_Aliases points to a list of name aliases. The list is terminated by
+ -- a NULL pointer.
Addresses : constant In_Addr_Access_Array :=
- In_Addr_Access_Pointers.Value (Host.H_Addr_List);
- -- H_Addr_List points to a list of binary addresses (in network
- -- byte order). The list is terminated by a NULL pointer.
-
+ In_Addr_Access_Pointers.Value (E.H_Addr_List);
+ -- H_Addr_List points to a list of binary addresses (in network byte
+ -- order). The list is terminated by a NULL pointer.
+ --
-- H_Length is not used because it is currently only set to 4.
-- H_Addrtype is always AF_INET
- Result : Host_Entry_Type
- (Aliases_Length => Aliases'Length - 1,
- Addresses_Length => Addresses'Length - 1);
- -- The last element is a null pointer.
+ Result : Host_Entry_Type
+ (Aliases_Length => Aliases'Length - 1,
+ Addresses_Length => Addresses'Length - 1);
+ -- The last element is a null pointer
Source : C.size_t;
Target : Natural;
begin
- Result.Official := To_Host_Name (Official);
+ Result.Official := To_Name (Official);
Source := Aliases'First;
Target := Result.Aliases'First;
while Target <= Result.Aliases_Length loop
Result.Aliases (Target) :=
- To_Host_Name (C.Strings.Value (Aliases (Source)));
+ To_Name (C.Strings.Value (Aliases (Source)));
Source := Source + 1;
Target := Target + 1;
end loop;
Source := Addresses'First;
Target := Result.Addresses'First;
while Target <= Result.Addresses_Length loop
- Result.Addresses (Target) :=
- To_Inet_Addr (Addresses (Source).all);
+ To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
Source := Source + 1;
Target := Target + 1;
end loop;
return Result;
end To_Host_Entry;
- ------------------
- -- To_Host_Name --
- ------------------
-
- function To_Host_Name (N : String) return Host_Name_Type is
- begin
- return (N'Length, N);
- end To_Host_Name;
-
----------------
-- To_In_Addr --
----------------
- function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
+ function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
begin
if Addr.Family = Family_Inet then
return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
end if;
- raise Socket_Error;
+ raise Socket_Error with "IPv6 not supported";
end To_In_Addr;
------------------
-- To_Inet_Addr --
------------------
- function To_Inet_Addr
- (Addr : In_Addr)
- return Inet_Addr_Type
- is
- Result : Inet_Addr_Type;
-
+ procedure To_Inet_Addr
+ (Addr : In_Addr;
+ Result : out Inet_Addr_Type) is
begin
Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
+ end To_Inet_Addr;
+
+ ------------
+ -- To_Int --
+ ------------
+
+ function To_Int (F : Request_Flag_Type) return C.int
+ is
+ Current : Request_Flag_Type := F;
+ Result : C.int := 0;
+
+ begin
+ for J in Flags'Range loop
+ exit when Current = 0;
+
+ if Current mod 2 /= 0 then
+ if Flags (J) = -1 then
+ Raise_Socket_Error (SOSC.EOPNOTSUPP);
+ end if;
+
+ Result := Result + Flags (J);
+ end if;
+
+ Current := Current / 2;
+ end loop;
return Result;
- end To_Inet_Addr;
+ end To_Int;
+
+ -------------
+ -- To_Name --
+ -------------
+
+ function To_Name (N : String) return Name_Type is
+ begin
+ return Name_Type'(N'Length, N);
+ end To_Name;
+
+ ----------------------
+ -- To_Service_Entry --
+ ----------------------
+
+ function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
+ use type C.size_t;
+
+ Official : constant String := C.Strings.Value (Servent_S_Name (E));
+
+ Aliases : constant Chars_Ptr_Array :=
+ Chars_Ptr_Pointers.Value (Servent_S_Aliases (E));
+ -- S_Aliases points to a list of name aliases. The list is
+ -- terminated by a NULL pointer.
+
+ Protocol : constant String := C.Strings.Value (Servent_S_Proto (E));
+
+ Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
+ -- The last element is a null pointer
+
+ Source : C.size_t;
+ Target : Natural;
+
+ begin
+ Result.Official := To_Name (Official);
+
+ Source := Aliases'First;
+ Target := Result.Aliases'First;
+ while Target <= Result.Aliases_Length loop
+ Result.Aliases (Target) :=
+ To_Name (C.Strings.Value (Aliases (Source)));
+ Source := Source + 1;
+ Target := Target + 1;
+ end loop;
+
+ Result.Port :=
+ Port_Type (Network_To_Short (C.unsigned_short (Servent_S_Port (E))));
+
+ Result.Protocol := To_Name (Protocol);
+ return Result;
+ end To_Service_Entry;
---------------
-- To_String --
---------------
- function To_String (HN : Host_Name_Type) return String is
+ function To_String (HN : Name_Type) return String is
begin
return HN.Name (1 .. HN.Length);
end To_String;
-- To_Timeval --
----------------
- function To_Timeval (Val : Duration) return Timeval is
- S : Timeval_Unit := Timeval_Unit (Val);
- MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S)));
+ function To_Timeval (Val : Timeval_Duration) return Timeval is
+ S : time_t;
+ uS : suseconds_t;
begin
- return (S, MS);
+ -- If zero, set result as zero (otherwise it gets rounded down to -1)
+
+ if Val = 0.0 then
+ S := 0;
+ uS := 0;
+
+ -- Normal case where we do round down
+
+ else
+ S := time_t (Val - 0.5);
+ uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
+ end if;
+
+ return (S, uS);
end To_Timeval;
-----------
(Stream : in out Datagram_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array)
is
- First : Ada.Streams.Stream_Element_Offset := Item'First;
- Index : Ada.Streams.Stream_Element_Offset := First - 1;
- Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
-
begin
- loop
- Send_Socket
- (Stream.Socket,
- Item (First .. Max),
- Index,
- Stream.To);
-
- -- Exit when all or zero data sent. Zero means that the
- -- socket has been closed by peer.
-
- exit when Index < First or else Index = Max;
-
- First := Index + 1;
- end loop;
-
- if Index /= Max then
- raise Socket_Error;
- end if;
+ Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
end Write;
-----------
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array)
is
- First : Ada.Streams.Stream_Element_Offset := Item'First;
- Index : Ada.Streams.Stream_Element_Offset := First - 1;
- Max : constant Ada.Streams.Stream_Element_Offset := Item'Last;
-
begin
- loop
- Send_Socket (Stream.Socket, Item (First .. Max), Index);
-
- -- Exit when all or zero data sent. Zero means that the
- -- socket has been closed by peer.
-
- exit when Index < First or else Index = Max;
-
- First := Index + 1;
- end loop;
-
- if Index /= Max then
- raise Socket_Error;
- end if;
+ Stream_Write (Stream.Socket, Item, To => null);
end Write;
+ Sockets_Library_Controller_Object : Sockets_Library_Controller;
+ pragma Unreferenced (Sockets_Library_Controller_Object);
+ -- The elaboration and finalization of this object perform the required
+ -- initialization and cleanup actions for the sockets library.
+
end GNAT.Sockets;
OSDN Git Service
