------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                         G N A T . S O C K E T S                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2001-2005, 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 2,  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.  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,  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, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- 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_Conversion;

with Interfaces.C.Strings;

with GNAT.Sockets.Constants;
with GNAT.Sockets.Thin;          use GNAT.Sockets.Thin;
with GNAT.Task_Lock;

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;

package body GNAT.Sockets is

   use type C.int, System.Address;

   Finalized   : Boolean := False;
   Initialized : Boolean := False;

   ENOERROR : constant := 0;

   --  Correspondance tables

   Families : constant array (Family_Type) of C.int :=
     (Family_Inet  => Constants.AF_INET,
      Family_Inet6 => Constants.AF_INET6);

   Levels : constant array (Level_Type) of C.int :=
     (Socket_Level              => Constants.SOL_SOCKET,
      IP_Protocol_For_IP_Level  => Constants.IPPROTO_IP,
      IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
      IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);

   Modes : constant array (Mode_Type) of C.int :=
     (Socket_Stream   => Constants.SOCK_STREAM,
      Socket_Datagram => Constants.SOCK_DGRAM);

   Shutmodes : constant array (Shutmode_Type) of C.int :=
     (Shut_Read       => Constants.SHUT_RD,
      Shut_Write      => Constants.SHUT_WR,
      Shut_Read_Write => Constants.SHUT_RDWR);

   Requests : constant array (Request_Name) of C.int :=
     (Non_Blocking_IO => Constants.FIONBIO,
      N_Bytes_To_Read => Constants.FIONREAD);

   Options : constant array (Option_Name) of C.int :=
     (Keep_Alive      => Constants.SO_KEEPALIVE,
      Reuse_Address   => Constants.SO_REUSEADDR,
      Broadcast       => Constants.SO_BROADCAST,
      Send_Buffer     => Constants.SO_SNDBUF,
      Receive_Buffer  => Constants.SO_RCVBUF,
      Linger          => Constants.SO_LINGER,
      Error           => Constants.SO_ERROR,
      No_Delay        => Constants.TCP_NODELAY,
      Add_Membership  => Constants.IP_ADD_MEMBERSHIP,
      Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
      Multicast_If    => Constants.IP_MULTICAST_IF,
      Multicast_TTL   => Constants.IP_MULTICAST_TTL,
      Multicast_Loop  => Constants.IP_MULTICAST_LOOP,
      Send_Timeout    => Constants.SO_SNDTIMEO,
      Receive_Timeout => Constants.SO_RCVTIMEO);

   Flags : constant array (0 .. 3) of C.int :=
            (0 => Constants.MSG_OOB,     --  Process_Out_Of_Band_Data
             1 => Constants.MSG_PEEK,    --  Peek_At_Incoming_Data
             2 => Constants.MSG_WAITALL, --  Wait_For_A_Full_Reception
             3 => Constants.MSG_EOR);    --  Send_End_Of_Record

   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

   function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
   function To_Int     is new Ada.Unchecked_Conversion (In_Addr, C.int);

   function Err_Code_Image (E : Integer) return String;
   --  Return the value of E surrounded with brackets

   -----------------------
   -- Local subprograms --
   -----------------------

   function 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.

   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 Constants.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;
   --  Symetric 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 IP address in standard dot notation

   function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr;
   procedure To_Inet_Addr
     (Addr   : In_Addr;
      Result : out Inet_Addr_Type);
   --  Conversion functions

   function To_Host_Entry (E : Hostent) return Host_Entry_Type;
   --  Conversion function

   function To_Service_Entry (E : Servent) return Service_Entry_Type;
   --  Conversion function

   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);
   --  Raise Host_Error exception with message describing error code (note
   --  hstrerror seems to be obsolete) from h_errno.

   procedure Narrow (Item : in out Socket_Set_Type);
   --  Update Last as it may be greater than the real last socket

   --  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);

   ---------
   -- "+" --
   ---------

   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
      Buf : aliased Character := ASCII.NUL;
      Res : C.int;

   begin
      --  Send an empty array to unblock C select system call

      Res := C_Send (C.int (Selector.W_Sig_Socket), Buf'Address, 1,
                     Constants.MSG_Forced_Flags);
      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;
   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;

   ---------------
   -- 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;

   begin
      if Address.Family = Family_Inet6 then
         raise Socket_Error;
      end if;

      Set_Length (Sin'Unchecked_Access, Len);
      Set_Family (Sin'Unchecked_Access, Families (Address.Family));
      Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
      Set_Port
        (Sin'Unchecked_Access,
         Short_To_Network (C.unsigned_short (Address.Port)));

      Res := C_Bind (C.int (Socket), Sin'Address, Len);

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;
   end Bind_Socket;

   --------------------
   -- 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;
      Status       : out Selector_Status;
      Timeout      : Selector_Duration := Forever)
   is
      E_Socket_Set : Socket_Set_Type; --  (No_Socket, No_Socket_Set)
   begin
      Check_Selector
        (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
   end 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;
      Last : C.int;
      RSig : Socket_Type renames Selector.R_Sig_Socket;
      RSet : Socket_Set_Type;
      WSet : Socket_Set_Type;
      ESet : Socket_Set_Type;
      TVal : aliased Timeval;
      TPtr : Timeval_Access;

   begin
      begin
         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;

         --  Copy R_Socket_Set in RSet and add read signalling socket

         RSet := (Set  => New_Socket_Set (R_Socket_Set.Set),
                  Last => R_Socket_Set.Last);
         Set (RSet, RSig);

         --  Copy W_Socket_Set in WSet

         WSet := (Set  => New_Socket_Set (W_Socket_Set.Set),
                  Last => W_Socket_Set.Last);

         --  Copy E_Socket_Set in ESet

         ESet := (Set  => New_Socket_Set (E_Socket_Set.Set),
                  Last => E_Socket_Set.Last);

         Last := C.int'Max (C.int'Max (C.int (RSet.Last),
                                       C.int (WSet.Last)),
                                       C.int (ESet.Last));

         Res :=
           C_Select
            (Last + 1,
             RSet.Set,
             WSet.Set,
             ESet.Set,
             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 Is_Set (RSet, RSig) then
            Clear (RSet, RSig);

            declare
               Buf : Character;

            begin
               Res := C_Recv (C.int (RSig), Buf'Address, 1, 0);

               if Res = Failure then
                  Raise_Socket_Error (Socket_Errno);
               end if;
            end;

            Status := Aborted;

         elsif Res = 0 then
            Status := Expired;
         end if;

         --  Update RSet, WSet and ESet in regard to their new socket sets

         Narrow (RSet);
         Narrow (WSet);
         Narrow (ESet);

         --  Reset RSet as it should be if R_Sig_Socket was not added

         if Is_Empty (RSet) then
            Empty (RSet);
         end if;

         if Is_Empty (WSet) then
            Empty (WSet);
         end if;

         if Is_Empty (ESet) then
            Empty (ESet);
         end if;

         --  Deliver RSet, WSet and ESet

         Empty (R_Socket_Set);
         R_Socket_Set := RSet;

         Empty (W_Socket_Set);
         W_Socket_Set := WSet;

         Empty (E_Socket_Set);
         E_Socket_Set := ESet;

      exception

         when Socket_Error =>

            --  The local socket sets must be emptied before propagating
            --  Socket_Error so the associated storage is freed.

            Empty (RSet);
            Empty (WSet);
            Empty (ESet);
            raise;
      end;
   end Check_Selector;

   -----------
   -- Clear --
   -----------

   procedure Clear
     (Item   : in out Socket_Set_Type;
      Socket : Socket_Type)
   is
      Last : aliased C.int := C.int (Item.Last);
   begin
      if Item.Last /= No_Socket then
         Remove_Socket_From_Set (Item.Set, C.int (Socket));
         Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
         Item.Last := Socket_Type (Last);
      end if;
   end Clear;

   --------------------
   -- Close_Selector --
   --------------------

   procedure Close_Selector (Selector : in out Selector_Type) is
   begin

      --  Close the signalling sockets used internally for the implementation
      --  of Abort_Selector. Exceptions are ignored because these sockets
      --  are implementation artefacts of no interest to the user, and
      --  there is little that can be done if either Close_Socket call fails
      --  (which theoretically should not happen anyway). We also want to try
      --  to perform the second Close_Socket even if the first one failed.

      begin
         Close_Socket (Selector.R_Sig_Socket);
      exception
         when Socket_Error =>
            null;
      end;

      begin
         Close_Socket (Selector.W_Sig_Socket);
      exception
         when Socket_Error =>
            null;
      end;
   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 --
   --------------------

   procedure Connect_Socket
     (Socket : Socket_Type;
      Server : in out Sock_Addr_Type)
   is
      Res : C.int;
      Sin : aliased Sockaddr_In;
      Len : constant C.int := Sin'Size / 8;

   begin
      if Server.Family = Family_Inet6 then
         raise Socket_Error;
      end if;

      Set_Length (Sin'Unchecked_Access, Len);
      Set_Family (Sin'Unchecked_Access, Families (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);

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      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 := C_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 : in out Socket_Set_Type)
   is
   begin
      Empty (Target);
      if Source.Last /= No_Socket then
         Target.Set  := New_Socket_Set (Source.Set);
         Target.Last := Source.Last;
      end if;
   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;

   begin
      --  We open two signalling sockets. One of them is used to send data to
      --  the other, which is included in a C_Select socket set. The
      --  communication is used to force the call to C_Select to complete, and
      --  the waiting task to resume its execution.

      --  Create a listening socket

      S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);

      if S0 = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;

      --  Bind the socket to any unused port on localhost

      Sin.Sin_Addr.S_B1 := 127;
      Sin.Sin_Addr.S_B2 := 0;
      Sin.Sin_Addr.S_B3 := 0;
      Sin.Sin_Addr.S_B4 := 1;
      Sin.Sin_Port := 0;

      Res := C_Bind (S0, Sin'Address, Len);

      if Res = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Raise_Socket_Error (Err);
      end if;

      --  Get the port used by the socket

      Res := C_Getsockname (S0, Sin'Address, Len'Access);

      if Res = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Raise_Socket_Error (Err);
      end if;

      --  Set backlog to 1 to guarantee that exactly one call to connect(2)
      --  can succeed.

      Res := C_Listen (S0, 1);

      if Res = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Raise_Socket_Error (Err);
      end if;

      S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);

      if S1 = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Raise_Socket_Error (Err);
      end if;

      --  Do a connect and accept the connection

      Res := C_Connect (S1, Sin'Address, Len);

      if Res = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Res := C_Close (S1);
         Raise_Socket_Error (Err);
      end if;

      --  Since the call to connect(2) has suceeded and the backlog limit on
      --  the listening socket is 1, we know that there is now exactly one
      --  pending connection on S0, which is the one from S1.

      S2 := C_Accept (S0, Sin'Address, Len'Access);

      if S2 = Failure then
         Err := Socket_Errno;
         Res := C_Close (S0);
         Res := C_Close (S1);
         Raise_Socket_Error (Err);
      end if;

      Res := C_Close (S0);

      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);
   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 : in out Socket_Set_Type) is
   begin
      if Item.Set /= No_Socket_Set then
         Free_Socket_Set (Item.Set);
         Item.Set := No_Socket_Set;
      end if;

      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 is
   begin
      if not Finalized
        and then Initialized
      then
         Finalized := True;
         Thin.Finalize;
      end if;
   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, L'Unchecked_Access, S'Unchecked_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
   begin
      if Stream = null then
         raise Socket_Error;
      elsif 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);
      Res : Hostent_Access;
      Err : Integer;

   begin
      --  This C function is not always thread-safe. Protect against
      --  concurrent access.

      Task_Lock.Lock;
      Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET);

      if Res = null then
         Err := Host_Errno;
         Task_Lock.Unlock;
         Raise_Host_Error (Err);
      end if;

      --  Translate from the C format to the API format

      declare
         HE : constant Host_Entry_Type := To_Host_Entry (Res.all);

      begin
         Task_Lock.Unlock;
         return HE;
      end;
   end Get_Host_By_Address;

   ----------------------
   -- Get_Host_By_Name --
   ----------------------

   function Get_Host_By_Name (Name : String) return Host_Entry_Type is
      HN  : constant C.char_array := C.To_C (Name);
      Res : Hostent_Access;
      Err : Integer;

   begin
      --  Detect IP address name and redirect to Inet_Addr

      if Is_IP_Address (Name) then
         return Get_Host_By_Address (Inet_Addr (Name));
      end if;

      --  This C function is not always thread-safe. Protect against
      --  concurrent access.

      Task_Lock.Lock;
      Res := C_Gethostbyname (HN);

      if Res = null then
         Err := Host_Errno;
         Task_Lock.Unlock;
         Raise_Host_Error (Err);
      end if;

      --  Translate from the C format to the API format

      declare
         HE : constant Host_Entry_Type := To_Host_Entry (Res.all);
      begin
         Task_Lock.Unlock;
         return HE;
      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);
      Res : Servent_Access;

   begin
      --  This C function is not always thread-safe. Protect against
      --  concurrent access.

      Task_Lock.Lock;
      Res := C_Getservbyname (SN, SP);

      if Res = null then
         Task_Lock.Unlock;
         Ada.Exceptions.Raise_Exception
           (Service_Error'Identity, "Service not found");
      end if;

      --  Translate from the C format to the API format

      declare
         SE : constant Service_Entry_Type := To_Service_Entry (Res.all);

      begin
         Task_Lock.Unlock;
         return SE;
      end;
   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);
      Res : Servent_Access;

   begin
      --  This C function is not always thread-safe. Protect against
      --  concurrent access.

      Task_Lock.Lock;
      Res := C_Getservbyport
        (C.int (Short_To_Network (C.unsigned_short (Port))), SP);

      if Res = null then
         Task_Lock.Unlock;
         Ada.Exceptions.Raise_Exception
           (Service_Error'Identity, "Service not found");
      end if;

      --  Translate from the C format to the API format

      declare
         SE : constant Service_Entry_Type := To_Service_Entry (Res.all);

      begin
         Task_Lock.Unlock;
         return SE;
      end;
   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) return Option_Type
   is
      use type C.unsigned_char;

      V8  : aliased Two_Int;
      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);

   begin
      case Name is
         when Multicast_Loop  |
              Multicast_TTL   =>
            Len := V1'Size / 8;
            Add := V1'Address;

         when Keep_Alive      |
              Reuse_Address   |
              Broadcast       |
              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 =>
            Len := V8'Size / 8;
            Add := V8'Address;

      end case;

      Res :=
        C_Getsockopt
          (C.int (Socket),
           Levels (Level),
           Options (Name),
           Add, Len'Unchecked_Access);

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;

      case Name is
         when Keep_Alive      |
              Reuse_Address   |
              Broadcast       |
              No_Delay        =>
            Opt.Enabled := (V4 /= 0);

         when Linger          =>
            Opt.Enabled := (V8 (V8'First) /= 0);
            Opt.Seconds := Natural (V8 (V8'Last));

         when Send_Buffer     |
              Receive_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  =>
            Opt.Enabled := (V1 /= 0);

         when Send_Timeout    |
              Receive_Timeout =>
            Opt.Timeout := To_Duration (VT);

      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
      if Hex then
         Separator := ':';
      else
         Separator := '.';
      end if;

      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;

   ---------------
   -- Inet_Addr --
   ---------------

   function Inet_Addr (Image : String) return Inet_Addr_Type is
      use Interfaces.C.Strings;

      Img    : chars_ptr;
      Res    : C.int;
      Result : Inet_Addr_Type;

   begin
      --  Special case for the all-ones broadcast address: this address
      --  has the same in_addr_t value as Failure, and thus cannot be
      --  properly returned by inet_addr(3).

      if Image = "255.255.255.255" then
         return Broadcast_Inet_Addr;

      --  Special case for an empty Image as on some platforms (e.g. Windows)
      --  calling Inet_Addr("") will not return an error.

      elsif Image = "" then
         Raise_Socket_Error (Constants.EINVAL);
      end if;

      Img := New_String (Image);
      Res := C_Inet_Addr (Img);
      Free (Img);

      if Res = Failure then
         Raise_Socket_Error (Constants.EINVAL);
      end if;

      To_Inet_Addr (To_In_Addr (Res), Result);
      return Result;
   end Inet_Addr;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (Process_Blocking_IO : Boolean := False) is
   begin
      if not Initialized then
         Initialized := True;
         Thin.Initialize (Process_Blocking_IO);
      end if;
   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
   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_Set --
   ------------

   function Is_Set
     (Item   : Socket_Set_Type;
      Socket : Socket_Type) return Boolean
   is
   begin
      return Item.Last /= No_Socket
        and then Socket <= Item.Last
        and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
   end Is_Set;

   -------------------
   -- Listen_Socket --
   -------------------

   procedure Listen_Socket
     (Socket : Socket_Type;
      Length : Positive := 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.Set /= No_Socket_Set then
         Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
         Item.Last := Socket_Type (Last);
      end if;
   end Narrow;

   -------------------
   -- 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;

   -----------------
   -- 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) is

      function Host_Error_Message return String;
      --  We do not use a C function like strerror because hstrerror that would
      --  correspond is obsolete. Return appropriate string for error value.

      ------------------------
      -- Host_Error_Message --
      ------------------------

      function Host_Error_Message return String is
      begin
         case H_Error is
            when Constants.HOST_NOT_FOUND => return "Host not found";
            when Constants.TRY_AGAIN      => return "Try again";
            when Constants.NO_RECOVERY    => return "No recovery";
            when Constants.NO_DATA        => return "No address";
            when others                   => return "Unknown error";
         end case;
      end Host_Error_Message;

   --  Start of processing for Raise_Host_Error

   begin
      Ada.Exceptions.Raise_Exception (Host_Error'Identity,
        Err_Code_Image (H_Error)
        & Host_Error_Message);
   end Raise_Host_Error;

   ------------------------
   -- Raise_Socket_Error --
   ------------------------

   procedure Raise_Socket_Error (Error : Integer) is
      use type C.Strings.chars_ptr;
   begin
      Ada.Exceptions.Raise_Exception (Socket_Error'Identity,
        Err_Code_Image (Error)
        & C.Strings.Value (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
      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,
            Stream.From);

         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;

   ----------
   -- 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
      use type Ada.Streams.Stream_Element_Offset;

      Res : C.int;

   begin
      Res := C_Recv
        (C.int (Socket),
         Item (Item'First)'Address,
         Item'Length,
         To_Int (Flags));

      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 --
   --------------------

   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
      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,
           To_Int (Flags),
           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);

      To_Inet_Addr (Sin.Sin_Addr, From.Addr);
      From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
   end Receive_Socket;

   -------------------
   -- Resolve_Error --
   -------------------

   function Resolve_Error
     (Error_Value : Integer;
      From_Errno  : Boolean := True) return Error_Type
   is
      use GNAT.Sockets.Constants;

   begin
      if not From_Errno then
         case Error_Value is
            when Constants.HOST_NOT_FOUND => return Unknown_Host;
            when Constants.TRY_AGAIN      => return Host_Name_Lookup_Failure;
            when Constants.NO_RECOVERY    =>
               return Non_Recoverable_Error;
            when Constants.NO_DATA        => return Unknown_Server_Error;
            when others                   => return Cannot_Resolve_Error;
         end case;
      end if;

      case Error_Value is
         when ENOERROR        => return Success;
         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 ECONNABORTED    => return Software_Caused_Connection_Abort;
         when ECONNREFUSED    => return Connection_Refused;
         when ECONNRESET      => return Connection_Reset_By_Peer;
         when EDESTADDRREQ    => return Destination_Address_Required;
         when EFAULT          => return Bad_Address;
         when EHOSTDOWN       => return Host_Is_Down;
         when EHOSTUNREACH    => return No_Route_To_Host;
         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 ELOOP           => return Too_Many_Symbolic_Links;
         when EMFILE          => return Too_Many_Open_Files;
         when EMSGSIZE        => return Message_Too_Long;
         when ENAMETOOLONG    => return File_Name_Too_Long;
         when ENETDOWN        => return Network_Is_Down;
         when ENETRESET       =>
            return Network_Dropped_Connection_Because_Of_Reset;
         when 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 ENOTSOCK        => return Socket_Operation_On_Non_Socket;
         when EOPNOTSUPP      => return Operation_Not_Supported;
         when EPFNOSUPPORT    => return Protocol_Family_Not_Supported;
         when EPROTONOSUPPORT => return Protocol_Not_Supported;
         when EPROTOTYPE      => return Protocol_Wrong_Type_For_Socket;
         when ESHUTDOWN       =>
            return Cannot_Send_After_Transport_Endpoint_Shutdown;
         when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
         when ETIMEDOUT       => return Connection_Timed_Out;
         when ETOOMANYREFS    => return Too_Many_References;
         when EWOULDBLOCK     => return Resource_Temporarily_Unavailable;
         when others          => null;
      end case;

      return Cannot_Resolve_Error;
   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;

   --------------------
   -- Receive_Vector --
   --------------------

   procedure Receive_Vector
     (Socket : Socket_Type;
      Vector : Vector_Type;
      Count  : out Ada.Streams.Stream_Element_Count)
   is
      Res : C.int;

   begin
      Res :=
        C_Readv
          (C.int (Socket),
           Vector (Vector'First)'Address,
           Vector'Length);

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;

      Count := Ada.Streams.Stream_Element_Count (Res);
   end Receive_Vector;

   -----------------
   -- 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
      use type Ada.Streams.Stream_Element_Offset;

      Res : C.int;

   begin
      Res :=
        C_Send
          (C.int (Socket),
           Item (Item'First)'Address,
           Item'Length,
           Set_Forced_Flags (To_Int (Flags)));

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;

      Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
   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
      use type Ada.Streams.Stream_Element_Offset;

      Res : C.int;
      Sin : aliased Sockaddr_In;
      Len : constant C.int := Sin'Size / 8;

   begin
      Set_Length (Sin'Unchecked_Access, Len);
      Set_Family (Sin'Unchecked_Access, Families (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)));

      Res := C_Sendto
        (C.int (Socket),
         Item (Item'First)'Address,
         Item'Length,
         Set_Forced_Flags (To_Int (Flags)),
         Sin'Unchecked_Access,
         Len);

      if Res = Failure then
         Raise_Socket_Error (Socket_Errno);
      end if;

      Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
   end Send_Socket;

   -----------------
   -- Send_Vector --
   -----------------

   procedure Send_Vector
     (Socket : Socket_Type;
      Vector : Vector_Type;
      Count  : out Ada.Streams.Stream_Element_Count)
   is
      Res            : C.int;
      Iov_Count      : C.int;
      This_Iov_Count : C.int;

   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

         if Vector'Length - Iov_Count > Constants.IOV_MAX then
            This_Iov_Count := Constants.IOV_MAX;
         else
            This_Iov_Count := Vector'Length - Iov_Count;
         end if;

         pragma Warnings (On);

         Res :=
           C_Writev
             (C.int (Socket),
              Vector (Vector'First + Integer (Iov_Count))'Address,
              This_Iov_Count);

         if Res = 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.Set = No_Socket_Set then
         Item.Set  := New_Socket_Set (No_Socket_Set);
         Item.Last := Socket;

      elsif Item.Last < Socket then
         Item.Last := Socket;
      end if;

      Insert_Socket_In_Set (Item.Set, 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 Constants.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
      V8  : aliased Two_Int;
      V4  : aliased C.int;
      V1  : aliased C.unsigned_char;
      VT  : aliased Timeval;
      Len : C.int;
      Add : System.Address := Null_Address;
      Res : C.int;

   begin
      case Option.Name is
         when Keep_Alive      |
              Reuse_Address   |
              Broadcast       |
              No_Delay        =>
            V4  := C.int (Boolean'Pos (Option.Enabled));
            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 Send_Buffer     |
              Receive_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  =>
            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
        (C.int (Socket),
         Levels (Level),
         Options (Option.Name),
         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.

      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 --
   ---------------------

   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_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) return Host_Entry_Type is
      use type C.size_t;

      Official : constant String :=
                  C.Strings.Value (E.H_Name);

      Aliases : constant Chars_Ptr_Array :=
                  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 (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

      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;

      Source := Addresses'First;
      Target := Result.Addresses'First;
      while Target <= Result.Addresses_Length loop
         To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
         Source := Source + 1;
         Target := Target + 1;
      end loop;

      return Result;
   end To_Host_Entry;

   ----------------
   -- To_In_Addr --
   ----------------

   function To_In_Addr (Addr : Inet_Addr_Type) return Thin.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;
   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 (Constants.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) return Service_Entry_Type is
      use type C.size_t;

      Official : constant String :=
                  C.Strings.Value (E.S_Name);

      Aliases : constant Chars_Ptr_Array :=
                  Chars_Ptr_Pointers.Value (E.S_Aliases);
      --  S_Aliases points to a list of name aliases. The list is
      --  terminated by a NULL pointer.

      Protocol : constant String :=
                   C.Strings.Value (E.S_Proto);

      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 (E.S_Port)));

      Result.Protocol := To_Name (Protocol);

      return Result;
   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;

   -----------
   -- Write --
   -----------

   procedure Write
     (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;
   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          := 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;
   end Write;

end GNAT.Sockets;