diff options
Diffstat (limited to 'gcc/ada/libgnat/g-socket.adb')
| -rw-r--r-- | gcc/ada/libgnat/g-socket.adb | 2786 |
1 files changed, 2786 insertions, 0 deletions
diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb new file mode 100644 index 0000000..9b2ad7f --- /dev/null +++ b/gcc/ada/libgnat/g-socket.adb @@ -0,0 +1,2786 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- 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.Finalization; +with Ada.Unchecked_Conversion; + +with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; + +with GNAT.Sockets.Linker_Options; +pragma Warnings (Off, GNAT.Sockets.Linker_Options); +-- Need to include pragma Linker_Options which is platform dependent + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.Task_Lock; + +package body GNAT.Sockets is + + package C renames Interfaces.C; + + ENOERROR : constant := 0; + + Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; + Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; + -- 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. + + -- Correspondence tables + + Levels : constant array (Level_Type) of C.int := + (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 => SOSC.SOCK_STREAM, + Socket_Datagram => SOSC.SOCK_DGRAM); + + Shutmodes : constant array (Shutmode_Type) of C.int := + (Shut_Read => SOSC.SHUT_RD, + Shut_Write => SOSC.SHUT_WR, + Shut_Read_Write => SOSC.SHUT_RDWR); + + Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T := + (Non_Blocking_IO => SOSC.FIONBIO, + N_Bytes_To_Read => SOSC.FIONREAD); + + Options : constant array (Specific_Option_Name) of C.int := + (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, + Busy_Polling => SOSC.SO_BUSY_POLL); + -- ??? 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; + + Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; + -- Use to print in hexadecimal format + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) return Error_Type; + -- Associate an enumeration value (error_type) to an error value (errno). + -- From_Errno prevents from mixing h_errno with errno. + + function To_Name (N : String) return Name_Type; + function To_String (HN : Name_Type) return String; + -- Conversion functions + + 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_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 in hex or decimal mode + + function Is_IP_Address (Name : String) return Boolean; + -- Return true when Name is an IPv4 address in dotted quad notation + + procedure Netdb_Lock; + pragma Inline (Netdb_Lock); + procedure Netdb_Unlock; + pragma Inline (Netdb_Unlock); + -- Lock/unlock operation used to protect netdb access for platforms that + -- require such protection. + + 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 (E : Hostent_Access) return Host_Entry_Type; + -- Conversion function + + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; + -- Conversion function + + function Value (S : System.Address) return String; + -- Same as Interfaces.C.Strings.Value but taking a System.Address + + 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 (H_Error : Integer; Name : String); + -- Raise Host_Error exception with message describing error code (note + -- hstrerror seems to be obsolete) from h_errno. Name is the name + -- or address that was being looked up. + + procedure Narrow (Item : in out Socket_Set_Type); + -- Update Last as it may be greater than the real last socket + + procedure Check_For_Fd_Set (Fd : Socket_Type); + pragma Inline (Check_For_Fd_Set); + -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to + -- FD_SETSIZE, on platforms where fd_set is a bitmap. + + function Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) return C.int; + pragma Inline (Connect_Socket); + -- Underlying implementation for the Connect_Socket procedures + + -- 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_Access is + access all Datagram_Socket_Stream_Type; + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- 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_Access is + access all Stream_Socket_Stream_Type; + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + 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, + -- or the null selector. + + --------- + -- "+" -- + --------- + + 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 + if not Is_Open (Selector) then + raise Program_Error with "closed selector"; + + elsif Selector.Is_Null then + raise Program_Error with "null selector"; + + end if; + + -- 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; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + 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); + + 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; + + --------------- + -- Addresses -- + --------------- + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) return Inet_Addr_Type + is + begin + return E.Addresses (N); + end Addresses; + + ---------------------- + -- Addresses_Length -- + ---------------------- + + function Addresses_Length (E : Host_Entry_Type) return Natural is + begin + return E.Addresses_Length; + end Addresses_Length; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (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 -- + -------------------- + + function Aliases_Length (E : Host_Entry_Type) return Natural is + begin + 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 -- + ----------------- + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + -- This assumes that Address.Family = Family_Inet??? + + begin + if Address.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + 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); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Bind_Socket; + + ---------------------- + -- Check_For_Fd_Set -- + ---------------------- + + procedure Check_For_Fd_Set (Fd : Socket_Type) is + use SOSC; + + begin + -- On Windows, fd_set is a FD_SETSIZE array of socket ids: + -- no check required. Warnings suppressed because condition + -- is known at compile time. + + if Target_OS = Windows then + + return; + + -- On other platforms, fd_set is an FD_SETSIZE bitmap: check + -- that Fd is within range (otherwise behavior is undefined). + + elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then + raise Constraint_Error + with "invalid value for socket set: " & Image (Fd); + end if; + end Check_For_Fd_Set; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + 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; + + procedure Check_Selector + (Selector : 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; + Last : C.int; + RSig : Socket_Type := No_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 + + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; + + -- Add read signalling socket, if present + + if not Selector.Is_Null then + RSig := Selector.R_Sig_Socket; + Set (R_Socket_Set, RSig); + end if; + + 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)); + + -- Zero out fd_set for empty Socket_Set_Type objects + + Normalize_Empty_Socket_Set (R_Socket_Set); + Normalize_Empty_Socket_Set (W_Socket_Set); + Normalize_Empty_Socket_Set (E_Socket_Set); + + Res := + C_Select + (Last + 1, + R_Socket_Set.Set'Access, + W_Socket_Set.Set'Access, + E_Socket_Set.Set'Access, + TPtr); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + -- If Select was resumed because of read signalling socket, read this + -- data and remove socket from set. + + if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then + Clear (R_Socket_Set, RSig); + + Res := Signalling_Fds.Read (C.int (RSig)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Status := Aborted; + + elsif Res = 0 then + Status := Expired; + end if; + + -- Update socket sets in regard to their new contents + + Narrow (R_Socket_Set); + Narrow (W_Socket_Set); + Narrow (E_Socket_Set); + end Check_Selector; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Socket_Set_Type; + Socket : Socket_Type) + is + Last : aliased C.int := C.int (Item.Last); + + begin + Check_For_Fd_Set (Socket); + + 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; + end Clear; + + -------------------- + -- Close_Selector -- + -------------------- + + procedure Close_Selector (Selector : in out Selector_Type) is + begin + -- Nothing to do if selector already in closed state + + if Selector.Is_Null or else not Is_Open (Selector) then + 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; + + ------------------ + -- Close_Socket -- + ------------------ + + procedure Close_Socket (Socket : Socket_Type) is + Res : C.int; + + begin + Res := C_Close (C.int (Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Close_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + function Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) return C.int + is + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + + begin + if Server.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + 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))); + + return C_Connect (C.int (Socket), Sin'Address, Len); + end Connect_Socket; + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) + is + begin + if Connect_Socket (Socket, Server) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end 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 + + Conn_Err : aliased Integer; + -- Error status of the socket after completion of select(2) + + Res : C.int; + Conn_Err_Size : aliased C.int := Conn_Err'Size / 8; + -- For getsockopt(2) call + + 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 return Failure with errno set + -- to EINPROGRESS. + + Res := Connect_Socket (Socket, Server); + if Res = Failure then + Conn_Err := Socket_Errno; + if Conn_Err /= SOSC.EINPROGRESS then + Raise_Socket_Error (Conn_Err); + end if; + end if; + + -- Wait for socket to become available for writing (unless the Timeout + -- is zero, in which case we consider that it has already expired, and + -- we do not need to wait at all). + + if Timeout = 0.0 then + Status := Expired; + + else + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + end if; + + -- Check error condition (the asynchronous connect may have terminated + -- with an error, e.g. ECONNREFUSED) if select(2) completed. + + if Status = Completed then + Res := C_Getsockopt + (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR, + Conn_Err'Address, Conn_Err_Size'Access); + + if Res /= 0 then + Conn_Err := Socket_Errno; + end if; + + else + Conn_Err := 0; + end if; + + -- Reset the socket to blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => False); + Control_Socket (Socket, Request => Req); + + -- Report error condition if any + + if Conn_Err /= 0 then + Raise_Socket_Error (Conn_Err); + end if; + end Connect_Socket; + + -------------------- + -- Control_Socket -- + -------------------- + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type) + is + Arg : aliased C.int; + Res : C.int; + + begin + case Request.Name is + when Non_Blocking_IO => + Arg := C.int (Boolean'Pos (Request.Enabled)); + + when N_Bytes_To_Read => + null; + end case; + + Res := Socket_Ioctl + (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Request.Name is + when Non_Blocking_IO => + null; + + 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 + Two_Fds : aliased Fd_Pair; + Res : C.int; + + begin + if Is_Open (Selector) then + -- Raise exception to prevent socket descriptor leak + + raise Program_Error with "selector already open"; + 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. + + Res := Signalling_Fds.Create (Two_Fds'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); + Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); + end Create_Selector; + + ------------------- + -- Create_Socket -- + ------------------- + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream) + is + Res : C.int; + + begin + Res := C_Socket (Families (Family), Modes (Mode), 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + end Create_Socket; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : out Socket_Set_Type) is + begin + 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 + -- 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 : not null Stream_Access) return Sock_Addr_Type + is + begin + 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; + end Get_Address; + + ------------------------- + -- Get_Host_By_Address -- + ------------------------- + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) return Host_Entry_Type + is + pragma Unreferenced (Family); + + 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 + Netdb_Lock; + + if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, + Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err), Image (Address)); + end if; + + begin + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + exception + when others => + Netdb_Unlock; + raise; + end; + end Get_Host_By_Address; + + ---------------------- + -- Get_Host_By_Name -- + ---------------------- + + function Get_Host_By_Name (Name : String) return Host_Entry_Type is + begin + -- If the given name actually is the string representation of + -- an IP address, use Get_Host_By_Address instead. + + if Is_IP_Address (Name) then + return Get_Host_By_Address (Inet_Addr (Name)); + end if; + + declare + 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 + Netdb_Lock; + + if C_Gethostbyname + (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err), Name); + end if; + + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end; + end Get_Host_By_Name; + + ------------------- + -- Get_Peer_Name -- + ------------------- + + 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); + + begin + if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + 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 + Netdb_Lock; + + if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + 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 + Netdb_Lock; + + if C_Getservbyport + (C.int (Short_To_Network (C.unsigned_short (Port))), SP, + Res'Access, Buf'Address, Buflen) /= 0 + then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Service_By_Port; + + --------------------- + -- Get_Socket_Name -- + --------------------- + + function Get_Socket_Name + (Socket : Socket_Type) return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : C.int; + Addr : Sock_Addr_Type := No_Sock_Addr; + + 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)); + end if; + + return Addr; + end Get_Socket_Name; + + ----------------------- + -- Get_Socket_Option -- + ----------------------- + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name; + Optname : Interfaces.C.int := -1) return Option_Type + is + use SOSC; + use type C.unsigned_char; + + 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; + Opt : Option_Type (Name); + Onm : Interfaces.C.int; + + begin + if Name in Specific_Option_Name then + Onm := Options (Name); + + elsif Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Optname; + end if; + + case Name is + when Multicast_Loop + | Multicast_TTL + | Receive_Packet_Info + => + Len := V1'Size / 8; + Add := V1'Address; + + when Broadcast + | Busy_Polling + | Error + | Generic_Option + | Keep_Alive + | Multicast_If + | No_Delay + | Receive_Buffer + | Reuse_Address + | Send_Buffer + => + Len := V4'Size / 8; + Add := V4'Address; + + when Receive_Timeout + | Send_Timeout + => + -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a + -- struct timeval, but on Windows it is a milliseconds count in + -- a DWORD. + + if Target_OS = Windows then + Len := V4'Size / 8; + Add := V4'Address; + + else + Len := VT'Size / 8; + Add := VT'Address; + end if; + + when Add_Membership + | Drop_Membership + | Linger + => + Len := V8'Size / 8; + Add := V8'Address; + end case; + + Res := + C_Getsockopt + (C.int (Socket), + Levels (Level), + Onm, + Add, Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Name is + when Generic_Option => + Opt.Optname := Onm; + Opt.Optval := V4; + + when Broadcast + | Keep_Alive + | No_Delay + | Reuse_Address + => + Opt.Enabled := (V4 /= 0); + + when Busy_Polling => + Opt.Microseconds := Natural (V4); + + when Linger => + Opt.Enabled := (V8 (V8'First) /= 0); + Opt.Seconds := Natural (V8 (V8'Last)); + + when Receive_Buffer + | Send_Buffer + => + Opt.Size := Natural (V4); + + when Error => + Opt.Error := Resolve_Error (Integer (V4)); + + when 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 + | Receive_Packet_Info + => + Opt.Enabled := (V1 /= 0); + + when Receive_Timeout + | Send_Timeout + => + if Target_OS = Windows then + + -- Timeout is in milliseconds, actual value is 500 ms + + -- returned value (unless it is 0). + + if V4 = 0 then + Opt.Timeout := 0.0; + else + Opt.Timeout := Natural (V4) * 0.001 + 0.500; + end if; + + else + Opt.Timeout := To_Duration (VT); + end if; + end case; + + return Opt; + end Get_Socket_Option; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String is + Name : aliased C.char_array (1 .. 64); + Res : C.int; + + begin + Res := C_Gethostname (Name'Address, Name'Length); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + return C.To_Ada (Name); + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image + (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. + + Buffer : String (1 .. 4 * Val'Length); + Length : Natural := 1; + Separator : Character; + + procedure Img10 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in decimal format + + 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 : 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); + Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); + Length := Length + 2; + end Img16; + + -- Start of processing for Image + + begin + Separator := (if Hex then ':' else '.'); + + for J in Val'Range loop + if Hex then + Img16 (Val (J)); + else + Img10 (Val (J)); + end if; + + if J /= Val'Last then + Buffer (Length) := Separator; + Length := Length + 1; + end if; + end loop; + + return Buffer (1 .. Length - 1); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Inet_Addr_Type) return String is + begin + if Value.Family = Family_Inet then + return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + else + return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + 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; + + ----------- + -- Image -- + ----------- + + function Image (Socket : Socket_Type) return String is + begin + return Socket'Img; + end Image; + + ----------- + -- 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; + + Img : aliased char_array := To_C (Image); + Addr : aliased C.int; + Res : C.int; + Result : Inet_Addr_Type; + + begin + -- Special case for an empty Image as on some platforms (e.g. Windows) + -- calling Inet_Addr("") will not return an error. + + if Image = "" then + Raise_Socket_Error (SOSC.EINVAL); + end if; + + Res := Inet_Pton (SOSC.AF_INET, Img'Address, 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 (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 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; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Socket_Set_Type) return Boolean is + begin + return Item.Last = No_Socket; + end Is_Empty; + + ------------------- + -- Is_IP_Address -- + ------------------- + + function Is_IP_Address (Name : String) return Boolean is + Dots : Natural := 0; + + begin + -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots, + -- and there must be at least one digit around each. + + for J in Name'Range loop + if Name (J) = '.' then + + -- Check that the dot is not in first or last position, and that + -- it is followed by a digit. Note that we already know that it is + -- preceded by a digit, or we would have returned earlier on. + + if J in Name'First + 1 .. Name'Last - 1 + and then Name (J + 1) in '0' .. '9' + then + Dots := Dots + 1; + + -- Definitely not a proper dotted quad + + else + return False; + end if; + + elsif Name (J) not in '0' .. '9' then + return False; + end if; + end loop; + + return Dots in 1 .. 3; + end Is_IP_Address; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (S : Selector_Type) return Boolean is + begin + if S.Is_Null then + return True; + + else + -- 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 if; + end Is_Open; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean + is + begin + Check_For_Fd_Set (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; + + ------------------- + -- Listen_Socket -- + ------------------- + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Natural := 15) + is + Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); + begin + 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; + + ---------------- + -- Netdb_Lock -- + ---------------- + + procedure Netdb_Lock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Lock; + end if; + end Netdb_Lock; + + ------------------ + -- Netdb_Unlock -- + ------------------ + + procedure Netdb_Unlock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Unlock; + end if; + end Netdb_Unlock; + + -------------------------------- + -- 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 -- + ------------------- + + function Official_Name (E : Host_Entry_Type) return String is + begin + return To_String (E.Official); + end Official_Name; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Official); + end Official_Name; + + -------------------- + -- Wait_On_Socket -- + -------------------- + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + 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 + -- Create selector if not provided by the user + + 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; + + else + S := Selector.all'Access; + end if; + + if For_Read then + Set (R_Fd_Set, Socket); + else + Set (W_Fd_Set, Socket); + end if; + + Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); + + if Selector = null then + Close_Selector (S.all); + end if; + end Wait_On_Socket; + + ----------------- + -- Port_Number -- + ----------------- + + function Port_Number (S : Service_Entry_Type) return Port_Type is + begin + return S.Port; + end Port_Number; + + ------------------- + -- Protocol_Name -- + ------------------- + + function Protocol_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Protocol); + end Protocol_Name; + + ---------------------- + -- Raise_Host_Error -- + ---------------------- + + procedure Raise_Host_Error (H_Error : Integer; Name : String) is + function Dedot (Value : String) return String is + (if Value /= "" and then Value (Value'Last) = '.' then + Value (Value'First .. Value'Last - 1) + else + Value); + -- Removes dot at the end of error message + + begin + raise Host_Error with + Err_Code_Image (H_Error) + & Dedot (Host_Error_Messages.Host_Error_Message (H_Error)) + & ": " & Name; + end Raise_Host_Error; + + ------------------------ + -- Raise_Socket_Error -- + ------------------------ + + procedure Raise_Socket_Error (Error : Integer) is + begin + raise Socket_Error with + Err_Code_Image (Error) & Socket_Error_Message (Error); + end Raise_Socket_Error; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + Receive_Socket + (Stream.Socket, + Item, + Last, + Stream.From); + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + 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 + 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 Index < First or else Index = Max; + + First := Index + 1; + 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 + is + use GNAT.Sockets.SOSC; + + begin + if not From_Errno then + case Error_Value is + 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; + + -- 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; + + -- 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. + -- + -- But we have to leave warnings off because the compiler is also + -- smart enough to note that when two errnos have the same value, + -- the second if condition is useless. + 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; + pragma Warnings (On); + + end Resolve_Error; + + ----------------------- + -- Resolve_Exception -- + ----------------------- + + function Resolve_Exception + (Occurrence : Exception_Occurrence) return Error_Type + is + 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 + First := First + 1; + end loop; + + if First > Msg'Last then + return Cannot_Resolve_Error; + end if; + + Last := First; + while Last < Msg'Last + and then Msg (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + + Val := Integer'Value (Msg (First .. Last)); + + if Id = Socket_Error_Id then + return Resolve_Error (Val); + + elsif Id = Host_Error_Id then + return Resolve_Error (Val, False); + + else + return Cannot_Resolve_Error; + end if; + end Resolve_Exception; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + 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; + To : Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + Send_Socket + (Socket, Item, Last, To => To'Unrestricted_Access, 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; + To : access Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + + Sin : aliased Sockaddr_In; + C_To : System.Address; + Len : C.int; + + begin + 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'Address, + Item'Length, + Set_Forced_Flags (To_Int (Flags)), + C_To, + Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + 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 + Check_For_Fd_Set (Socket); + + 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; + + Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); + end Set; + + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + + ---------------------- + -- 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 -- + ----------------------- + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type) + is + use SOSC; + + V8 : aliased Two_Ints; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + VT : aliased Timeval; + Len : C.int; + Add : System.Address := Null_Address; + Res : C.int; + Onm : C.int; + + begin + case Option.Name is + when Generic_Option => + V4 := Option.Optval; + Len := V4'Size / 8; + Add := V4'Address; + + when Broadcast + | Keep_Alive + | No_Delay + | Reuse_Address + => + V4 := C.int (Boolean'Pos (Option.Enabled)); + Len := V4'Size / 8; + Add := V4'Address; + + when Busy_Polling => + V4 := C.int (Option.Microseconds); + Len := V4'Size / 8; + Add := V4'Address; + + when Linger => + V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); + V8 (V8'Last) := C.int (Option.Seconds); + Len := V8'Size / 8; + Add := V8'Address; + + when Receive_Buffer + | Send_Buffer + => + V4 := C.int (Option.Size); + Len := V4'Size / 8; + Add := V4'Address; + + when Error => + V4 := C.int (Boolean'Pos (True)); + Len := V4'Size / 8; + Add := V4'Address; + + when Add_Membership + | Drop_Membership + => + 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 + | Receive_Packet_Info + => + V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); + Len := V1'Size / 8; + Add := V1'Address; + + when Receive_Timeout + | Send_Timeout + => + if Target_OS = Windows then + + -- On Windows, the timeout is a DWORD in milliseconds, and + -- the actual timeout is 500 ms + the given value (unless it + -- is 0). + + V4 := C.int (Option.Timeout / 0.001); + + if V4 > 500 then + V4 := V4 - 500; + + elsif V4 > 0 then + V4 := 1; + end if; + + Len := V4'Size / 8; + Add := V4'Address; + + else + VT := To_Timeval (Option.Timeout); + Len := VT'Size / 8; + Add := VT'Address; + end if; + end case; + + if Option.Name in Specific_Option_Name then + Onm := Options (Option.Name); + + elsif Option.Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Option.Optname; + end if; + + Res := C_Setsockopt + (C.int (Socket), + Levels (Level), + Onm, + Add, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + 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. + + if Default_Bit_Order = High_Order_First then + return S; + + -- 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 -- + --------------------- + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write) + is + Res : C.int; + + begin + Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Shutdown_Socket; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) return Stream_Access + is + S : Datagram_Socket_Stream_Access; + + begin + S := new Datagram_Socket_Stream_Type; + S.Socket := Socket; + S.To := Send_To; + S.From := Get_Socket_Name (Socket); + return Stream_Access (S); + end Stream; + + ------------ + -- Stream -- + ------------ + + 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; + + ------------ + -- To_Ada -- + ------------ + + function To_Ada (Fd : Integer) return Socket_Type is + begin + return Socket_Type (Fd); + end To_Ada; + + ---------- + -- To_C -- + ---------- + + function To_C (Socket : Socket_Type) return Integer is + begin + 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 (E : Hostent_Access) return Host_Entry_Type is + use type C.size_t; + + Aliases_Count, Addresses_Count : Natural; + + -- H_Length is not used because it is currently only ever set to 4, as + -- we only handle the case of H_Addrtype being AF_INET. + + begin + if Hostent_H_Addrtype (E) /= SOSC.AF_INET then + Raise_Socket_Error (SOSC.EPFNOSUPPORT); + end if; + + Aliases_Count := 0; + while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + Addresses_Count := 0; + while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop + Addresses_Count := Addresses_Count + 1; + end loop; + + return Result : Host_Entry_Type + (Aliases_Length => Aliases_Count, + Addresses_Length => Addresses_Count) + do + Result.Official := To_Name (Value (Hostent_H_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Hostent_H_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + for J in Result.Addresses'Range loop + declare + Addr : In_Addr; + + -- Hostent_H_Addr (E, <index>) may return an address that is + -- not correctly aligned for In_Addr, so we need to use + -- an intermediate copy operation on a type with an alignment + -- of 1 to recover the value. + + subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); + Unaligned_Addr : Addr_Buf_T; + for Unaligned_Addr'Address + use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Unaligned_Addr); + + Aligned_Addr : Addr_Buf_T; + for Aligned_Addr'Address use Addr'Address; + pragma Import (Ada, Aligned_Addr); + + begin + Aligned_Addr := Unaligned_Addr; + To_Inet_Addr (Addr, Result.Addresses (J)); + end; + end loop; + end return; + end To_Host_Entry; + + ---------------- + -- To_In_Addr -- + ---------------- + + 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_B2 => C.unsigned_char (Addr.Sin_V4 (2)), + S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), + S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); + end if; + + raise Socket_Error with "IPv6 not supported"; + end To_In_Addr; + + ------------------ + -- To_Inet_Addr -- + ------------------ + + 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_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 + Aliases_Count : Natural; + + begin + Aliases_Count := 0; + while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do + Result.Official := To_Name (Value (Servent_S_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Servent_S_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + Result.Protocol := To_Name (Value (Servent_S_Proto (E))); + Result.Port := + Port_Type (Network_To_Short (Servent_S_Port (E))); + end return; + end To_Service_Entry; + + --------------- + -- To_String -- + --------------- + + 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 : 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; + 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; + + ----------- + -- Value -- + ----------- + + function Value (S : System.Address) return String is + Str : String (1 .. Positive'Last); + for Str'Address use S; + pragma Import (Ada, Str); + + Terminator : Positive := Str'First; + + begin + while Str (Terminator) /= ASCII.NUL loop + Terminator := Terminator + 1; + end loop; + + return Str (1 .. Terminator - 1); + end Value; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + Last : Stream_Element_Offset; + + begin + Send_Socket + (Stream.Socket, + Item, + Last, + Stream.To); + + -- It is an error if not all of the data has been sent + + if Last /= Item'Last then + Raise_Socket_Error (Socket_Errno); + end if; + end Write; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + 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 (Stream.Socket, Item (First .. Max), Index, null); + + -- 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 successful 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 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; |