gcc/ada/g-socket.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                         G N A T . S O C K E T S                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2001-2009, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Streams;              use Ada.Streams;
  35 with Ada.Exceptions;           use Ada.Exceptions;
  36 with Ada.Finalization;
  37 with Ada.Unchecked_Conversion;
  38
  39 with Interfaces.C.Strings;
  40
  41 with GNAT.Sockets.Thin_Common;          use GNAT.Sockets.Thin_Common;
  42 with GNAT.Sockets.Thin;                 use GNAT.Sockets.Thin;
  43 with GNAT.Sockets.Thin.Task_Safe_NetDB; use GNAT.Sockets.Thin.Task_Safe_NetDB;
  44
  45 with GNAT.Sockets.Linker_Options;
  46 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
  47 --  Need to include pragma Linker_Options which is platform dependent
  48
  49 with System; use System;
  50
  51 package body GNAT.Sockets is
  52
  53    package C renames Interfaces.C;
  54
  55    use type C.int;
  56
  57    ENOERROR : constant := 0;
  58
  59    Empty_Socket_Set : Socket_Set_Type;
  60    --  Variable set in Initialize, and then used internally to provide an
  61    --  initial value for Socket_Set_Type objects.
  62
  63    Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
  64    --  The network database functions gethostbyname, gethostbyaddr,
  65    --  getservbyname and getservbyport can either be guaranteed task safe by
  66    --  the operating system, or else return data through a user-provided buffer
  67    --  to ensure concurrent uses do not interfere.
  68
  69    --  Correspondence tables
  70
  71    Levels : constant array (Level_Type) of C.int :=
  72               (Socket_Level              => SOSC.SOL_SOCKET,
  73                IP_Protocol_For_IP_Level  => SOSC.IPPROTO_IP,
  74                IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP,
  75                IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP);
  76
  77    Modes : constant array (Mode_Type) of C.int :=
  78              (Socket_Stream   => SOSC.SOCK_STREAM,
  79               Socket_Datagram => SOSC.SOCK_DGRAM);
  80
  81    Shutmodes : constant array (Shutmode_Type) of C.int :=
  82                  (Shut_Read       => SOSC.SHUT_RD,
  83                   Shut_Write      => SOSC.SHUT_WR,
  84                   Shut_Read_Write => SOSC.SHUT_RDWR);
  85
  86    Requests : constant array (Request_Name) of C.int :=
  87                 (Non_Blocking_IO => SOSC.FIONBIO,
  88                  N_Bytes_To_Read => SOSC.FIONREAD);
  89
  90    Options : constant array (Option_Name) of C.int :=
  91                (Keep_Alive          => SOSC.SO_KEEPALIVE,
  92                 Reuse_Address       => SOSC.SO_REUSEADDR,
  93                 Broadcast           => SOSC.SO_BROADCAST,
  94                 Send_Buffer         => SOSC.SO_SNDBUF,
  95                 Receive_Buffer      => SOSC.SO_RCVBUF,
  96                 Linger              => SOSC.SO_LINGER,
  97                 Error               => SOSC.SO_ERROR,
  98                 No_Delay            => SOSC.TCP_NODELAY,
  99                 Add_Membership      => SOSC.IP_ADD_MEMBERSHIP,
 100                 Drop_Membership     => SOSC.IP_DROP_MEMBERSHIP,
 101                 Multicast_If        => SOSC.IP_MULTICAST_IF,
 102                 Multicast_TTL       => SOSC.IP_MULTICAST_TTL,
 103                 Multicast_Loop      => SOSC.IP_MULTICAST_LOOP,
 104                 Receive_Packet_Info => SOSC.IP_PKTINFO,
 105                 Send_Timeout        => SOSC.SO_SNDTIMEO,
 106                 Receive_Timeout     => SOSC.SO_RCVTIMEO);
 107    --  ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
 108    --  but for Linux compatibility this constant is the same as IP_PKTINFO.
 109
 110    Flags : constant array (0 .. 3) of C.int :=
 111              (0 => SOSC.MSG_OOB,     --  Process_Out_Of_Band_Data
 112               1 => SOSC.MSG_PEEK,    --  Peek_At_Incoming_Data
 113               2 => SOSC.MSG_WAITALL, --  Wait_For_A_Full_Reception
 114               3 => SOSC.MSG_EOR);    --  Send_End_Of_Record
 115
 116    Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
 117    Host_Error_Id   : constant Exception_Id := Host_Error'Identity;
 118
 119    Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
 120    --  Use to print in hexadecimal format
 121
 122    -----------------------
 123    -- Local subprograms --
 124    -----------------------
 125
 126    function Resolve_Error
 127      (Error_Value : Integer;
 128       From_Errno  : Boolean := True) return Error_Type;
 129    --  Associate an enumeration value (error_type) to en error value (errno).
 130    --  From_Errno prevents from mixing h_errno with errno.
 131
 132    function To_Name   (N  : String) return Name_Type;
 133    function To_String (HN : Name_Type) return String;
 134    --  Conversion functions
 135
 136    function To_Int (F : Request_Flag_Type) return C.int;
 137    --  Return the int value corresponding to the specified flags combination
 138
 139    function Set_Forced_Flags (F : C.int) return C.int;
 140    --  Return F with the bits from SOSC.MSG_Forced_Flags forced set
 141
 142    function Short_To_Network
 143      (S : C.unsigned_short) return C.unsigned_short;
 144    pragma Inline (Short_To_Network);
 145    --  Convert a port number into a network port number
 146
 147    function Network_To_Short
 148      (S : C.unsigned_short) return C.unsigned_short
 149    renames Short_To_Network;
 150    --  Symmetric operation
 151
 152    function Image
 153      (Val :  Inet_Addr_VN_Type;
 154       Hex :  Boolean := False) return String;
 155    --  Output an array of inet address components in hex or decimal mode
 156
 157    function Is_IP_Address (Name : String) return Boolean;
 158    --  Return true when Name is an IP address in standard dot notation
 159
 160    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr;
 161    procedure To_Inet_Addr
 162      (Addr   : In_Addr;
 163       Result : out Inet_Addr_Type);
 164    --  Conversion functions
 165
 166    function To_Host_Entry (E : Hostent) return Host_Entry_Type;
 167    --  Conversion function
 168
 169    function To_Service_Entry (E : Servent) return Service_Entry_Type;
 170    --  Conversion function
 171
 172    function To_Timeval (Val : Timeval_Duration) return Timeval;
 173    --  Separate Val in seconds and microseconds
 174
 175    function To_Duration (Val : Timeval) return Timeval_Duration;
 176    --  Reconstruct a Duration value from a Timeval record (seconds and
 177    --  microseconds).
 178
 179    procedure Raise_Socket_Error (Error : Integer);
 180    --  Raise Socket_Error with an exception message describing the error code
 181    --  from errno.
 182
 183    procedure Raise_Host_Error (H_Error : Integer);
 184    --  Raise Host_Error exception with message describing error code (note
 185    --  hstrerror seems to be obsolete) from h_errno.
 186
 187    procedure Narrow (Item : in out Socket_Set_Type);
 188    --  Update Last as it may be greater than the real last socket
 189
 190    --  Types needed for Datagram_Socket_Stream_Type
 191
 192    type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
 193       Socket : Socket_Type;
 194       To     : Sock_Addr_Type;
 195       From   : Sock_Addr_Type;
 196    end record;
 197
 198    type Datagram_Socket_Stream_Access is
 199      access all Datagram_Socket_Stream_Type;
 200
 201    procedure Read
 202      (Stream : in out Datagram_Socket_Stream_Type;
 203       Item   : out Ada.Streams.Stream_Element_Array;
 204       Last   : out Ada.Streams.Stream_Element_Offset);
 205
 206    procedure Write
 207      (Stream : in out Datagram_Socket_Stream_Type;
 208       Item   : Ada.Streams.Stream_Element_Array);
 209
 210    --  Types needed for Stream_Socket_Stream_Type
 211
 212    type Stream_Socket_Stream_Type is new Root_Stream_Type with record
 213       Socket : Socket_Type;
 214    end record;
 215
 216    type Stream_Socket_Stream_Access is
 217      access all Stream_Socket_Stream_Type;
 218
 219    procedure Read
 220      (Stream : in out Stream_Socket_Stream_Type;
 221       Item   : out Ada.Streams.Stream_Element_Array;
 222       Last   : out Ada.Streams.Stream_Element_Offset);
 223
 224    procedure Write
 225      (Stream : in out Stream_Socket_Stream_Type;
 226       Item   : Ada.Streams.Stream_Element_Array);
 227
 228    procedure Stream_Write
 229      (Socket : Socket_Type;
 230       Item   : Ada.Streams.Stream_Element_Array;
 231       To     : access Sock_Addr_Type);
 232    --  Common implementation for the Write operation of Datagram_Socket_Stream_
 233    --  Type and Stream_Socket_Stream_Type.
 234
 235    procedure Wait_On_Socket
 236      (Socket    : Socket_Type;
 237       For_Read  : Boolean;
 238       Timeout   : Selector_Duration;
 239       Selector  : access Selector_Type := null;
 240       Status    : out Selector_Status);
 241    --  Common code for variants of socket operations supporting a timeout:
 242    --  block in Check_Selector on Socket for at most the indicated timeout.
 243    --  If For_Read is True, Socket is added to the read set for this call, else
 244    --  it is added to the write set. If no selector is provided, a local one is
 245    --  created for this call and destroyed prior to returning.
 246
 247    type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
 248      with null record;
 249    --  This type is used to generate automatic calls to Initialize and Finalize
 250    --  during the elaboration and finalization of this package. A single object
 251    --  of this type must exist at library level.
 252
 253    function Err_Code_Image (E : Integer) return String;
 254    --  Return the value of E surrounded with brackets
 255
 256    function Last_Index
 257      (First : Stream_Element_Offset;
 258       Count : C.int) return Stream_Element_Offset;
 259    --  Compute the Last OUT parameter for the various Receive_Socket
 260    --  subprograms: returns First + Count - 1, except for the case
 261    --  where First = Stream_Element_Offset'First and Res = 0, in which
 262    --  case Stream_Element_Offset'Last is returned instead.
 263
 264    procedure Initialize (X : in out Sockets_Library_Controller);
 265    procedure Finalize   (X : in out Sockets_Library_Controller);
 266
 267    ---------
 268    -- "+" --
 269    ---------
 270
 271    function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
 272    begin
 273       return L or R;
 274    end "+";
 275
 276    --------------------
 277    -- Abort_Selector --
 278    --------------------
 279
 280    procedure Abort_Selector (Selector : Selector_Type) is
 281       Res : C.int;
 282
 283    begin
 284       --  Send one byte to unblock select system call
 285
 286       Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
 287
 288       if Res = Failure then
 289          Raise_Socket_Error (Socket_Errno);
 290       end if;
 291    end Abort_Selector;
 292
 293    -------------------
 294    -- Accept_Socket --
 295    -------------------
 296
 297    procedure Accept_Socket
 298      (Server  : Socket_Type;
 299       Socket  : out Socket_Type;
 300       Address : out Sock_Addr_Type)
 301    is
 302       Res : C.int;
 303       Sin : aliased Sockaddr_In;
 304       Len : aliased C.int := Sin'Size / 8;
 305
 306    begin
 307       Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
 308
 309       if Res = Failure then
 310          Raise_Socket_Error (Socket_Errno);
 311       end if;
 312
 313       Socket := Socket_Type (Res);
 314
 315       To_Inet_Addr (Sin.Sin_Addr, Address.Addr);
 316       Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 317    end Accept_Socket;
 318
 319    -------------------
 320    -- Accept_Socket --
 321    -------------------
 322
 323    procedure Accept_Socket
 324      (Server   : Socket_Type;
 325       Socket   : out Socket_Type;
 326       Address  : out Sock_Addr_Type;
 327       Timeout  : Selector_Duration;
 328       Selector : access Selector_Type := null;
 329       Status   : out Selector_Status)
 330    is
 331    begin
 332       --  Wait for socket to become available for reading
 333
 334       Wait_On_Socket
 335         (Socket    => Server,
 336          For_Read  => True,
 337          Timeout   => Timeout,
 338          Selector  => Selector,
 339          Status    => Status);
 340
 341       --  Accept connection if available
 342
 343       if Status = Completed then
 344          Accept_Socket (Server, Socket, Address);
 345       else
 346          Socket := No_Socket;
 347       end if;
 348    end Accept_Socket;
 349
 350    ---------------
 351    -- Addresses --
 352    ---------------
 353
 354    function Addresses
 355      (E : Host_Entry_Type;
 356       N : Positive := 1) return Inet_Addr_Type
 357    is
 358    begin
 359       return E.Addresses (N);
 360    end Addresses;
 361
 362    ----------------------
 363    -- Addresses_Length --
 364    ----------------------
 365
 366    function Addresses_Length (E : Host_Entry_Type) return Natural is
 367    begin
 368       return E.Addresses_Length;
 369    end Addresses_Length;
 370
 371    -------------
 372    -- Aliases --
 373    -------------
 374
 375    function Aliases
 376      (E : Host_Entry_Type;
 377       N : Positive := 1) return String
 378    is
 379    begin
 380       return To_String (E.Aliases (N));
 381    end Aliases;
 382
 383    -------------
 384    -- Aliases --
 385    -------------
 386
 387    function Aliases
 388      (S : Service_Entry_Type;
 389       N : Positive := 1) return String
 390    is
 391    begin
 392       return To_String (S.Aliases (N));
 393    end Aliases;
 394
 395    --------------------
 396    -- Aliases_Length --
 397    --------------------
 398
 399    function Aliases_Length (E : Host_Entry_Type) return Natural is
 400    begin
 401       return E.Aliases_Length;
 402    end Aliases_Length;
 403
 404    --------------------
 405    -- Aliases_Length --
 406    --------------------
 407
 408    function Aliases_Length (S : Service_Entry_Type) return Natural is
 409    begin
 410       return S.Aliases_Length;
 411    end Aliases_Length;
 412
 413    -----------------
 414    -- Bind_Socket --
 415    -----------------
 416
 417    procedure Bind_Socket
 418      (Socket  : Socket_Type;
 419       Address : Sock_Addr_Type)
 420    is
 421       Res : C.int;
 422       Sin : aliased Sockaddr_In;
 423       Len : constant C.int := Sin'Size / 8;
 424       --  This assumes that Address.Family = Family_Inet???
 425
 426    begin
 427       if Address.Family = Family_Inet6 then
 428          raise Socket_Error with "IPv6 not supported";
 429       end if;
 430
 431       Set_Family  (Sin.Sin_Family, Address.Family);
 432       Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr));
 433       Set_Port
 434         (Sin'Unchecked_Access,
 435          Short_To_Network (C.unsigned_short (Address.Port)));
 436
 437       Res := C_Bind (C.int (Socket), Sin'Address, Len);
 438
 439       if Res = Failure then
 440          Raise_Socket_Error (Socket_Errno);
 441       end if;
 442    end Bind_Socket;
 443
 444    --------------------
 445    -- Check_Selector --
 446    --------------------
 447
 448    procedure Check_Selector
 449      (Selector     : in out Selector_Type;
 450       R_Socket_Set : in out Socket_Set_Type;
 451       W_Socket_Set : in out Socket_Set_Type;
 452       Status       : out Selector_Status;
 453       Timeout      : Selector_Duration := Forever)
 454    is
 455       E_Socket_Set : Socket_Set_Type := Empty_Socket_Set;
 456    begin
 457       Check_Selector
 458         (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
 459    end Check_Selector;
 460
 461    --------------------
 462    -- Check_Selector --
 463    --------------------
 464
 465    procedure Check_Selector
 466      (Selector     : in out Selector_Type;
 467       R_Socket_Set : in out Socket_Set_Type;
 468       W_Socket_Set : in out Socket_Set_Type;
 469       E_Socket_Set : in out Socket_Set_Type;
 470       Status       : out Selector_Status;
 471       Timeout      : Selector_Duration := Forever)
 472    is
 473       Res  : C.int;
 474       Last : C.int;
 475       RSig : Socket_Type renames Selector.R_Sig_Socket;
 476       TVal : aliased Timeval;
 477       TPtr : Timeval_Access;
 478
 479    begin
 480       Status := Completed;
 481
 482       --  No timeout or Forever is indicated by a null timeval pointer
 483
 484       if Timeout = Forever then
 485          TPtr := null;
 486       else
 487          TVal := To_Timeval (Timeout);
 488          TPtr := TVal'Unchecked_Access;
 489       end if;
 490
 491       --  Add read signalling socket
 492
 493       Set (R_Socket_Set, RSig);
 494
 495       Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last),
 496                                     C.int (W_Socket_Set.Last)),
 497                                     C.int (E_Socket_Set.Last));
 498
 499       Res :=
 500         C_Select
 501          (Last + 1,
 502           R_Socket_Set.Set'Access,
 503           W_Socket_Set.Set'Access,
 504           E_Socket_Set.Set'Access,
 505           TPtr);
 506
 507       if Res = Failure then
 508          Raise_Socket_Error (Socket_Errno);
 509       end if;
 510
 511       --  If Select was resumed because of read signalling socket, read this
 512       --  data and remove socket from set.
 513
 514       if Is_Set (R_Socket_Set, RSig) then
 515          Clear (R_Socket_Set, RSig);
 516
 517          Res := Signalling_Fds.Read (C.int (RSig));
 518
 519          if Res = Failure then
 520             Raise_Socket_Error (Socket_Errno);
 521          end if;
 522
 523          Status := Aborted;
 524
 525       elsif Res = 0 then
 526          Status := Expired;
 527       end if;
 528
 529       --  Update socket sets in regard to their new contents
 530
 531       Narrow (R_Socket_Set);
 532       Narrow (W_Socket_Set);
 533       Narrow (E_Socket_Set);
 534    end Check_Selector;
 535
 536    -----------
 537    -- Clear --
 538    -----------
 539
 540    procedure Clear
 541      (Item   : in out Socket_Set_Type;
 542       Socket : Socket_Type)
 543    is
 544       Last : aliased C.int := C.int (Item.Last);
 545    begin
 546       if Item.Last /= No_Socket then
 547          Remove_Socket_From_Set (Item.Set'Access, C.int (Socket));
 548          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
 549          Item.Last := Socket_Type (Last);
 550       end if;
 551    end Clear;
 552
 553    --------------------
 554    -- Close_Selector --
 555    --------------------
 556
 557    procedure Close_Selector (Selector : in out Selector_Type) is
 558    begin
 559       --  Close the signalling file descriptors used internally for the
 560       --  implementation of Abort_Selector.
 561
 562       Signalling_Fds.Close (C.int (Selector.R_Sig_Socket));
 563       Signalling_Fds.Close (C.int (Selector.W_Sig_Socket));
 564
 565       --  Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any
 566       --  (erroneous) subsequent attempt to use this selector properly fails.
 567
 568       Selector.R_Sig_Socket := No_Socket;
 569       Selector.W_Sig_Socket := No_Socket;
 570    end Close_Selector;
 571
 572    ------------------
 573    -- Close_Socket --
 574    ------------------
 575
 576    procedure Close_Socket (Socket : Socket_Type) is
 577       Res : C.int;
 578
 579    begin
 580       Res := C_Close (C.int (Socket));
 581
 582       if Res = Failure then
 583          Raise_Socket_Error (Socket_Errno);
 584       end if;
 585    end Close_Socket;
 586
 587    --------------------
 588    -- Connect_Socket --
 589    --------------------
 590
 591    procedure Connect_Socket
 592      (Socket : Socket_Type;
 593       Server : Sock_Addr_Type)
 594    is
 595       Res : C.int;
 596       Sin : aliased Sockaddr_In;
 597       Len : constant C.int := Sin'Size / 8;
 598
 599    begin
 600       if Server.Family = Family_Inet6 then
 601          raise Socket_Error with "IPv6 not supported";
 602       end if;
 603
 604       Set_Family  (Sin.Sin_Family, Server.Family);
 605       Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
 606       Set_Port
 607         (Sin'Unchecked_Access,
 608          Short_To_Network (C.unsigned_short (Server.Port)));
 609
 610       Res := C_Connect (C.int (Socket), Sin'Address, Len);
 611
 612       if Res = Failure then
 613          Raise_Socket_Error (Socket_Errno);
 614       end if;
 615    end Connect_Socket;
 616
 617    --------------------
 618    -- Connect_Socket --
 619    --------------------
 620
 621    procedure Connect_Socket
 622      (Socket   : Socket_Type;
 623       Server   : Sock_Addr_Type;
 624       Timeout  : Selector_Duration;
 625       Selector : access Selector_Type := null;
 626       Status   : out Selector_Status)
 627    is
 628       Req : Request_Type;
 629       --  Used to set Socket to non-blocking I/O
 630
 631    begin
 632       --  Set the socket to non-blocking I/O
 633
 634       Req := (Name => Non_Blocking_IO, Enabled => True);
 635       Control_Socket (Socket, Request => Req);
 636
 637       --  Start operation (non-blocking), will raise Socket_Error with
 638       --  EINPROGRESS.
 639
 640       begin
 641          Connect_Socket (Socket, Server);
 642       exception
 643          when E : Socket_Error =>
 644             if Resolve_Exception (E) = Operation_Now_In_Progress then
 645                null;
 646             else
 647                raise;
 648             end if;
 649       end;
 650
 651       --  Wait for socket to become available for writing
 652
 653       Wait_On_Socket
 654         (Socket    => Socket,
 655          For_Read  => False,
 656          Timeout   => Timeout,
 657          Selector  => Selector,
 658          Status    => Status);
 659
 660       --  Reset the socket to blocking I/O
 661
 662       Req := (Name => Non_Blocking_IO, Enabled => False);
 663       Control_Socket (Socket, Request => Req);
 664    end Connect_Socket;
 665
 666    --------------------
 667    -- Control_Socket --
 668    --------------------
 669
 670    procedure Control_Socket
 671      (Socket  : Socket_Type;
 672       Request : in out Request_Type)
 673    is
 674       Arg : aliased C.int;
 675       Res : C.int;
 676
 677    begin
 678       case Request.Name is
 679          when Non_Blocking_IO =>
 680             Arg := C.int (Boolean'Pos (Request.Enabled));
 681
 682          when N_Bytes_To_Read =>
 683             null;
 684       end case;
 685
 686       Res := Socket_Ioctl
 687                (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
 688
 689       if Res = Failure then
 690          Raise_Socket_Error (Socket_Errno);
 691       end if;
 692
 693       case Request.Name is
 694          when Non_Blocking_IO =>
 695             null;
 696
 697          when N_Bytes_To_Read =>
 698             Request.Size := Natural (Arg);
 699       end case;
 700    end Control_Socket;
 701
 702    ----------
 703    -- Copy --
 704    ----------
 705
 706    procedure Copy
 707      (Source : Socket_Set_Type;
 708       Target : in out Socket_Set_Type)
 709    is
 710    begin
 711       Target := Source;
 712    end Copy;
 713
 714    ---------------------
 715    -- Create_Selector --
 716    ---------------------
 717
 718    procedure Create_Selector (Selector : out Selector_Type) is
 719       Two_Fds : aliased Fd_Pair;
 720       Res     : C.int;
 721
 722    begin
 723       --  We open two signalling file descriptors. One of them is used to send
 724       --  data to the other, which is included in a C_Select socket set. The
 725       --  communication is used to force a call to C_Select to complete, and
 726       --  the waiting task to resume its execution.
 727
 728       Res := Signalling_Fds.Create (Two_Fds'Access);
 729
 730       if Res = Failure then
 731          Raise_Socket_Error (Socket_Errno);
 732       end if;
 733
 734       Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
 735       Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
 736    end Create_Selector;
 737
 738    -------------------
 739    -- Create_Socket --
 740    -------------------
 741
 742    procedure Create_Socket
 743      (Socket : out Socket_Type;
 744       Family : Family_Type := Family_Inet;
 745       Mode   : Mode_Type   := Socket_Stream)
 746    is
 747       Res : C.int;
 748
 749    begin
 750       Res := C_Socket (Families (Family), Modes (Mode), 0);
 751
 752       if Res = Failure then
 753          Raise_Socket_Error (Socket_Errno);
 754       end if;
 755
 756       Socket := Socket_Type (Res);
 757    end Create_Socket;
 758
 759    -----------
 760    -- Empty --
 761    -----------
 762
 763    procedure Empty  (Item : in out Socket_Set_Type) is
 764    begin
 765       Reset_Socket_Set (Item.Set'Access);
 766       Item.Last := No_Socket;
 767    end Empty;
 768
 769    --------------------
 770    -- Err_Code_Image --
 771    --------------------
 772
 773    function Err_Code_Image (E : Integer) return String is
 774       Msg : String := E'Img & "] ";
 775    begin
 776       Msg (Msg'First) := '[';
 777       return Msg;
 778    end Err_Code_Image;
 779
 780    --------------
 781    -- Finalize --
 782    --------------
 783
 784    procedure Finalize (X : in out Sockets_Library_Controller) is
 785       pragma Unreferenced (X);
 786
 787    begin
 788       --  Finalization operation for the GNAT.Sockets package
 789
 790       Thin.Finalize;
 791    end Finalize;
 792
 793    --------------
 794    -- Finalize --
 795    --------------
 796
 797    procedure Finalize is
 798    begin
 799       --  This is a dummy placeholder for an obsolete API.
 800       --  The real finalization actions are in Initialize primitive operation
 801       --  of Sockets_Library_Controller.
 802
 803       null;
 804    end Finalize;
 805
 806    ---------
 807    -- Get --
 808    ---------
 809
 810    procedure Get
 811      (Item   : in out Socket_Set_Type;
 812       Socket : out Socket_Type)
 813    is
 814       S : aliased C.int;
 815       L : aliased C.int := C.int (Item.Last);
 816
 817    begin
 818       if Item.Last /= No_Socket then
 819          Get_Socket_From_Set
 820            (Item.Set'Access, Last => L'Access, Socket => S'Access);
 821          Item.Last := Socket_Type (L);
 822          Socket    := Socket_Type (S);
 823       else
 824          Socket := No_Socket;
 825       end if;
 826    end Get;
 827
 828    -----------------
 829    -- Get_Address --
 830    -----------------
 831
 832    function Get_Address
 833      (Stream : not null Stream_Access) return Sock_Addr_Type
 834    is
 835    begin
 836       if Stream.all in Datagram_Socket_Stream_Type then
 837          return Datagram_Socket_Stream_Type (Stream.all).From;
 838       else
 839          return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
 840       end if;
 841    end Get_Address;
 842
 843    -------------------------
 844    -- Get_Host_By_Address --
 845    -------------------------
 846
 847    function Get_Host_By_Address
 848      (Address : Inet_Addr_Type;
 849       Family  : Family_Type := Family_Inet) return Host_Entry_Type
 850    is
 851       pragma Unreferenced (Family);
 852
 853       HA     : aliased In_Addr := To_In_Addr (Address);
 854       Buflen : constant C.int := Netdb_Buffer_Size;
 855       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 856       Res    : aliased Hostent;
 857       Err    : aliased C.int;
 858
 859    begin
 860       if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET,
 861                              Res'Access, Buf'Address, Buflen, Err'Access) /= 0
 862       then
 863          Raise_Host_Error (Integer (Err));
 864       end if;
 865
 866       return To_Host_Entry (Res);
 867    end Get_Host_By_Address;
 868
 869    ----------------------
 870    -- Get_Host_By_Name --
 871    ----------------------
 872
 873    function Get_Host_By_Name (Name : String) return Host_Entry_Type is
 874    begin
 875       --  Detect IP address name and redirect to Inet_Addr
 876
 877       if Is_IP_Address (Name) then
 878          return Get_Host_By_Address (Inet_Addr (Name));
 879       end if;
 880
 881       declare
 882          HN     : constant C.char_array := C.To_C (Name);
 883          Buflen : constant C.int := Netdb_Buffer_Size;
 884          Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 885          Res    : aliased Hostent;
 886          Err    : aliased C.int;
 887
 888       begin
 889          if Safe_Gethostbyname
 890            (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
 891          then
 892             Raise_Host_Error (Integer (Err));
 893          end if;
 894
 895          return To_Host_Entry (Res);
 896       end;
 897    end Get_Host_By_Name;
 898
 899    -------------------
 900    -- Get_Peer_Name --
 901    -------------------
 902
 903    function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
 904       Sin : aliased Sockaddr_In;
 905       Len : aliased C.int := Sin'Size / 8;
 906       Res : Sock_Addr_Type (Family_Inet);
 907
 908    begin
 909       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
 910          Raise_Socket_Error (Socket_Errno);
 911       end if;
 912
 913       To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
 914       Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 915
 916       return Res;
 917    end Get_Peer_Name;
 918
 919    -------------------------
 920    -- Get_Service_By_Name --
 921    -------------------------
 922
 923    function Get_Service_By_Name
 924      (Name     : String;
 925       Protocol : String) return Service_Entry_Type
 926    is
 927       SN     : constant C.char_array := C.To_C (Name);
 928       SP     : constant C.char_array := C.To_C (Protocol);
 929       Buflen : constant C.int := Netdb_Buffer_Size;
 930       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 931       Res    : aliased Servent;
 932
 933    begin
 934       if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
 935          raise Service_Error with "Service not found";
 936       end if;
 937
 938       --  Translate from the C format to the API format
 939
 940       return To_Service_Entry (Res);
 941    end Get_Service_By_Name;
 942
 943    -------------------------
 944    -- Get_Service_By_Port --
 945    -------------------------
 946
 947    function Get_Service_By_Port
 948      (Port     : Port_Type;
 949       Protocol : String) return Service_Entry_Type
 950    is
 951       SP     : constant C.char_array := C.To_C (Protocol);
 952       Buflen : constant C.int := Netdb_Buffer_Size;
 953       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 954       Res    : aliased Servent;
 955
 956    begin
 957       if Safe_Getservbyport
 958         (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
 959          Res'Access, Buf'Address, Buflen) /= 0
 960       then
 961          raise Service_Error with "Service not found";
 962       end if;
 963
 964       --  Translate from the C format to the API format
 965
 966       return To_Service_Entry (Res);
 967    end Get_Service_By_Port;
 968
 969    ---------------------
 970    -- Get_Socket_Name --
 971    ---------------------
 972
 973    function Get_Socket_Name
 974      (Socket : Socket_Type) return Sock_Addr_Type
 975    is
 976       Sin  : aliased Sockaddr_In;
 977       Len  : aliased C.int := Sin'Size / 8;
 978       Res  : C.int;
 979       Addr : Sock_Addr_Type := No_Sock_Addr;
 980
 981    begin
 982       Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
 983
 984       if Res /= Failure then
 985          To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
 986          Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 987       end if;
 988
 989       return Addr;
 990    end Get_Socket_Name;
 991
 992    -----------------------
 993    -- Get_Socket_Option --
 994    -----------------------
 995
 996    function Get_Socket_Option
 997      (Socket : Socket_Type;
 998       Level  : Level_Type := Socket_Level;
 999       Name   : Option_Name) return Option_Type
1000    is
1001       use type C.unsigned_char;
1002
1003       V8  : aliased Two_Ints;
1004       V4  : aliased C.int;
1005       V1  : aliased C.unsigned_char;
1006       VT  : aliased Timeval;
1007       Len : aliased C.int;
1008       Add : System.Address;
1009       Res : C.int;
1010       Opt : Option_Type (Name);
1011
1012    begin
1013       case Name is
1014          when Multicast_Loop      |
1015               Multicast_TTL       |
1016               Receive_Packet_Info =>
1017             Len := V1'Size / 8;
1018             Add := V1'Address;
1019
1020          when Keep_Alive      |
1021               Reuse_Address   |
1022               Broadcast       |
1023               No_Delay        |
1024               Send_Buffer     |
1025               Receive_Buffer  |
1026               Multicast_If    |
1027               Error           =>
1028             Len := V4'Size / 8;
1029             Add := V4'Address;
1030
1031          when Send_Timeout    |
1032               Receive_Timeout =>
1033             Len := VT'Size / 8;
1034             Add := VT'Address;
1035
1036          when Linger          |
1037               Add_Membership  |
1038               Drop_Membership =>
1039             Len := V8'Size / 8;
1040             Add := V8'Address;
1041
1042       end case;
1043
1044       Res :=
1045         C_Getsockopt
1046           (C.int (Socket),
1047            Levels (Level),
1048            Options (Name),
1049            Add, Len'Access);
1050
1051       if Res = Failure then
1052          Raise_Socket_Error (Socket_Errno);
1053       end if;
1054
1055       case Name is
1056          when Keep_Alive      |
1057               Reuse_Address   |
1058               Broadcast       |
1059               No_Delay        =>
1060             Opt.Enabled := (V4 /= 0);
1061
1062          when Linger          =>
1063             Opt.Enabled := (V8 (V8'First) /= 0);
1064             Opt.Seconds := Natural (V8 (V8'Last));
1065
1066          when Send_Buffer     |
1067               Receive_Buffer  =>
1068             Opt.Size := Natural (V4);
1069
1070          when Error           =>
1071             Opt.Error := Resolve_Error (Integer (V4));
1072
1073          when Add_Membership  |
1074               Drop_Membership =>
1075             To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1076             To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1077
1078          when Multicast_If    =>
1079             To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1080
1081          when Multicast_TTL   =>
1082             Opt.Time_To_Live := Integer (V1);
1083
1084          when Multicast_Loop      |
1085               Receive_Packet_Info =>
1086             Opt.Enabled := (V1 /= 0);
1087
1088          when Send_Timeout    |
1089               Receive_Timeout =>
1090             Opt.Timeout := To_Duration (VT);
1091       end case;
1092
1093       return Opt;
1094    end Get_Socket_Option;
1095
1096    ---------------
1097    -- Host_Name --
1098    ---------------
1099
1100    function Host_Name return String is
1101       Name : aliased C.char_array (1 .. 64);
1102       Res  : C.int;
1103
1104    begin
1105       Res := C_Gethostname (Name'Address, Name'Length);
1106
1107       if Res = Failure then
1108          Raise_Socket_Error (Socket_Errno);
1109       end if;
1110
1111       return C.To_Ada (Name);
1112    end Host_Name;
1113
1114    -----------
1115    -- Image --
1116    -----------
1117
1118    function Image
1119      (Val : Inet_Addr_VN_Type;
1120       Hex : Boolean := False) return String
1121    is
1122       --  The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1123       --  has at most a length of 3 plus one '.' character.
1124
1125       Buffer    : String (1 .. 4 * Val'Length);
1126       Length    : Natural := 1;
1127       Separator : Character;
1128
1129       procedure Img10 (V : Inet_Addr_Comp_Type);
1130       --  Append to Buffer image of V in decimal format
1131
1132       procedure Img16 (V : Inet_Addr_Comp_Type);
1133       --  Append to Buffer image of V in hexadecimal format
1134
1135       -----------
1136       -- Img10 --
1137       -----------
1138
1139       procedure Img10 (V : Inet_Addr_Comp_Type) is
1140          Img : constant String := V'Img;
1141          Len : constant Natural := Img'Length - 1;
1142       begin
1143          Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1144          Length := Length + Len;
1145       end Img10;
1146
1147       -----------
1148       -- Img16 --
1149       -----------
1150
1151       procedure Img16 (V : Inet_Addr_Comp_Type) is
1152       begin
1153          Buffer (Length)     := Hex_To_Char (Natural (V / 16) + 1);
1154          Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1155          Length := Length + 2;
1156       end Img16;
1157
1158    --  Start of processing for Image
1159
1160    begin
1161       Separator := (if Hex then ':' else '.');
1162
1163       for J in Val'Range loop
1164          if Hex then
1165             Img16 (Val (J));
1166          else
1167             Img10 (Val (J));
1168          end if;
1169
1170          if J /= Val'Last then
1171             Buffer (Length) := Separator;
1172             Length := Length + 1;
1173          end if;
1174       end loop;
1175
1176       return Buffer (1 .. Length - 1);
1177    end Image;
1178
1179    -----------
1180    -- Image --
1181    -----------
1182
1183    function Image (Value : Inet_Addr_Type) return String is
1184    begin
1185       if Value.Family = Family_Inet then
1186          return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1187       else
1188          return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1189       end if;
1190    end Image;
1191
1192    -----------
1193    -- Image --
1194    -----------
1195
1196    function Image (Value : Sock_Addr_Type) return String is
1197       Port : constant String := Value.Port'Img;
1198    begin
1199       return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1200    end Image;
1201
1202    -----------
1203    -- Image --
1204    -----------
1205
1206    function Image (Socket : Socket_Type) return String is
1207    begin
1208       return Socket'Img;
1209    end Image;
1210
1211    -----------
1212    -- Image --
1213    -----------
1214
1215    function Image (Item : Socket_Set_Type) return String is
1216       Socket_Set : Socket_Set_Type := Item;
1217
1218    begin
1219       declare
1220          Last_Img : constant String := Socket_Set.Last'Img;
1221          Buffer   : String
1222                       (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1223          Index    : Positive := 1;
1224          Socket   : Socket_Type;
1225
1226       begin
1227          while not Is_Empty (Socket_Set) loop
1228             Get (Socket_Set, Socket);
1229
1230             declare
1231                Socket_Img : constant String := Socket'Img;
1232             begin
1233                Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1234                Index := Index + Socket_Img'Length;
1235             end;
1236          end loop;
1237
1238          return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1239       end;
1240    end Image;
1241
1242    ---------------
1243    -- Inet_Addr --
1244    ---------------
1245
1246    function Inet_Addr (Image : String) return Inet_Addr_Type is
1247       use Interfaces.C;
1248       use Interfaces.C.Strings;
1249
1250       Img    : aliased char_array := To_C (Image);
1251       Cp     : constant chars_ptr := To_Chars_Ptr (Img'Unchecked_Access);
1252       Addr   : aliased C.int;
1253       Res    : C.int;
1254       Result : Inet_Addr_Type;
1255
1256    begin
1257       --  Special case for an empty Image as on some platforms (e.g. Windows)
1258       --  calling Inet_Addr("") will not return an error.
1259
1260       if Image = "" then
1261          Raise_Socket_Error (SOSC.EINVAL);
1262       end if;
1263
1264       Res := Inet_Pton (SOSC.AF_INET, Cp, Addr'Address);
1265
1266       if Res < 0 then
1267          Raise_Socket_Error (Socket_Errno);
1268
1269       elsif Res = 0 then
1270          Raise_Socket_Error (SOSC.EINVAL);
1271       end if;
1272
1273       To_Inet_Addr (To_In_Addr (Addr), Result);
1274       return Result;
1275    end Inet_Addr;
1276
1277    ----------------
1278    -- Initialize --
1279    ----------------
1280
1281    procedure Initialize (X : in out Sockets_Library_Controller) is
1282       pragma Unreferenced (X);
1283
1284    begin
1285       --  Initialization operation for the GNAT.Sockets package
1286
1287       Empty_Socket_Set.Last := No_Socket;
1288       Reset_Socket_Set (Empty_Socket_Set.Set'Access);
1289       Thin.Initialize;
1290    end Initialize;
1291
1292    ----------------
1293    -- Initialize --
1294    ----------------
1295
1296    procedure Initialize (Process_Blocking_IO : Boolean) is
1297       Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1298
1299    begin
1300       if Process_Blocking_IO /= Expected then
1301          raise Socket_Error with
1302            "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1303       end if;
1304
1305       --  This is a dummy placeholder for an obsolete API
1306
1307       --  Real initialization actions are in Initialize primitive operation
1308       --  of Sockets_Library_Controller.
1309
1310       null;
1311    end Initialize;
1312
1313    ----------------
1314    -- Initialize --
1315    ----------------
1316
1317    procedure Initialize is
1318    begin
1319       --  This is a dummy placeholder for an obsolete API
1320
1321       --  Real initialization actions are in Initialize primitive operation
1322       --  of Sockets_Library_Controller.
1323
1324       null;
1325    end Initialize;
1326
1327    --------------
1328    -- Is_Empty --
1329    --------------
1330
1331    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1332    begin
1333       return Item.Last = No_Socket;
1334    end Is_Empty;
1335
1336    -------------------
1337    -- Is_IP_Address --
1338    -------------------
1339
1340    function Is_IP_Address (Name : String) return Boolean is
1341    begin
1342       for J in Name'Range loop
1343          if Name (J) /= '.'
1344            and then Name (J) not in '0' .. '9'
1345          then
1346             return False;
1347          end if;
1348       end loop;
1349
1350       return True;
1351    end Is_IP_Address;
1352
1353    ------------
1354    -- Is_Set --
1355    ------------
1356
1357    function Is_Set
1358      (Item   : Socket_Set_Type;
1359       Socket : Socket_Type) return Boolean
1360    is
1361    begin
1362       return Item.Last /= No_Socket
1363         and then Socket <= Item.Last
1364         and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1365    end Is_Set;
1366
1367    ----------------
1368    -- Last_Index --
1369    ----------------
1370
1371    function Last_Index
1372      (First : Stream_Element_Offset;
1373       Count : C.int) return Stream_Element_Offset
1374    is
1375    begin
1376       if First = Stream_Element_Offset'First and then Count = 0 then
1377          return Stream_Element_Offset'Last;
1378       else
1379          return First + Stream_Element_Offset (Count - 1);
1380       end if;
1381    end Last_Index;
1382
1383    -------------------
1384    -- Listen_Socket --
1385    -------------------
1386
1387    procedure Listen_Socket
1388      (Socket : Socket_Type;
1389       Length : Natural := 15)
1390    is
1391       Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1392    begin
1393       if Res = Failure then
1394          Raise_Socket_Error (Socket_Errno);
1395       end if;
1396    end Listen_Socket;
1397
1398    ------------
1399    -- Narrow --
1400    ------------
1401
1402    procedure Narrow (Item : in out Socket_Set_Type) is
1403       Last : aliased C.int := C.int (Item.Last);
1404    begin
1405       if Item.Last /= No_Socket then
1406          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1407          Item.Last := Socket_Type (Last);
1408       end if;
1409    end Narrow;
1410
1411    -------------------
1412    -- Official_Name --
1413    -------------------
1414
1415    function Official_Name (E : Host_Entry_Type) return String is
1416    begin
1417       return To_String (E.Official);
1418    end Official_Name;
1419
1420    -------------------
1421    -- Official_Name --
1422    -------------------
1423
1424    function Official_Name (S : Service_Entry_Type) return String is
1425    begin
1426       return To_String (S.Official);
1427    end Official_Name;
1428
1429    --------------------
1430    -- Wait_On_Socket --
1431    --------------------
1432
1433    procedure Wait_On_Socket
1434      (Socket    : Socket_Type;
1435       For_Read  : Boolean;
1436       Timeout   : Selector_Duration;
1437       Selector  : access Selector_Type := null;
1438       Status    : out Selector_Status)
1439    is
1440       type Local_Selector_Access is access Selector_Type;
1441       for Local_Selector_Access'Storage_Size use Selector_Type'Size;
1442
1443       S : Selector_Access;
1444       --  Selector to use for waiting
1445
1446       R_Fd_Set : Socket_Set_Type;
1447       W_Fd_Set : Socket_Set_Type;
1448       --  Socket sets, empty at elaboration
1449
1450    begin
1451       --  Create selector if not provided by the user
1452
1453       if Selector = null then
1454          declare
1455             Local_S : constant Local_Selector_Access := new Selector_Type;
1456          begin
1457             S := Local_S.all'Unchecked_Access;
1458             Create_Selector (S.all);
1459          end;
1460
1461       else
1462          S := Selector.all'Access;
1463       end if;
1464
1465       if For_Read then
1466          Set (R_Fd_Set, Socket);
1467       else
1468          Set (W_Fd_Set, Socket);
1469       end if;
1470
1471       Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
1472
1473       --  Cleanup actions (required in all cases to avoid memory leaks)
1474
1475       if For_Read then
1476          Empty (R_Fd_Set);
1477       else
1478          Empty (W_Fd_Set);
1479       end if;
1480
1481       if Selector = null then
1482          Close_Selector (S.all);
1483       end if;
1484    end Wait_On_Socket;
1485
1486    -----------------
1487    -- Port_Number --
1488    -----------------
1489
1490    function Port_Number (S : Service_Entry_Type) return Port_Type is
1491    begin
1492       return S.Port;
1493    end Port_Number;
1494
1495    -------------------
1496    -- Protocol_Name --
1497    -------------------
1498
1499    function Protocol_Name (S : Service_Entry_Type) return String is
1500    begin
1501       return To_String (S.Protocol);
1502    end Protocol_Name;
1503
1504    ----------------------
1505    -- Raise_Host_Error --
1506    ----------------------
1507
1508    procedure Raise_Host_Error (H_Error : Integer) is
1509    begin
1510       raise Host_Error with
1511         Err_Code_Image (H_Error)
1512         & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error));
1513    end Raise_Host_Error;
1514
1515    ------------------------
1516    -- Raise_Socket_Error --
1517    ------------------------
1518
1519    procedure Raise_Socket_Error (Error : Integer) is
1520       use type C.Strings.chars_ptr;
1521    begin
1522       raise Socket_Error with
1523         Err_Code_Image (Error)
1524         & C.Strings.Value (Socket_Error_Message (Error));
1525    end Raise_Socket_Error;
1526
1527    ----------
1528    -- Read --
1529    ----------
1530
1531    procedure Read
1532      (Stream : in out Datagram_Socket_Stream_Type;
1533       Item   : out Ada.Streams.Stream_Element_Array;
1534       Last   : out Ada.Streams.Stream_Element_Offset)
1535    is
1536       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1537       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1538       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1539
1540    begin
1541       loop
1542          Receive_Socket
1543            (Stream.Socket,
1544             Item (First .. Max),
1545             Index,
1546             Stream.From);
1547
1548          Last := Index;
1549
1550          --  Exit when all or zero data received. Zero means that the socket
1551          --  peer is closed.
1552
1553          exit when Index < First or else Index = Max;
1554
1555          First := Index + 1;
1556       end loop;
1557    end Read;
1558
1559    ----------
1560    -- Read --
1561    ----------
1562
1563    procedure Read
1564      (Stream : in out Stream_Socket_Stream_Type;
1565       Item   : out Ada.Streams.Stream_Element_Array;
1566       Last   : out Ada.Streams.Stream_Element_Offset)
1567    is
1568       pragma Warnings (Off, Stream);
1569
1570       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1571       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1572       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1573
1574    begin
1575       loop
1576          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1577          Last  := Index;
1578
1579          --  Exit when all or zero data received. Zero means that the socket
1580          --  peer is closed.
1581
1582          exit when Index < First or else Index = Max;
1583
1584          First := Index + 1;
1585       end loop;
1586    end Read;
1587
1588    --------------------
1589    -- Receive_Socket --
1590    --------------------
1591
1592    procedure Receive_Socket
1593      (Socket : Socket_Type;
1594       Item   : out Ada.Streams.Stream_Element_Array;
1595       Last   : out Ada.Streams.Stream_Element_Offset;
1596       Flags  : Request_Flag_Type := No_Request_Flag)
1597    is
1598       Res : C.int;
1599
1600    begin
1601       Res :=
1602         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1603
1604       if Res = Failure then
1605          Raise_Socket_Error (Socket_Errno);
1606       end if;
1607
1608       Last := Last_Index (First => Item'First, Count => Res);
1609    end Receive_Socket;
1610
1611    --------------------
1612    -- Receive_Socket --
1613    --------------------
1614
1615    procedure Receive_Socket
1616      (Socket : Socket_Type;
1617       Item   : out Ada.Streams.Stream_Element_Array;
1618       Last   : out Ada.Streams.Stream_Element_Offset;
1619       From   : out Sock_Addr_Type;
1620       Flags  : Request_Flag_Type := No_Request_Flag)
1621    is
1622       Res : C.int;
1623       Sin : aliased Sockaddr_In;
1624       Len : aliased C.int := Sin'Size / 8;
1625
1626    begin
1627       Res :=
1628         C_Recvfrom
1629           (C.int (Socket),
1630            Item'Address,
1631            Item'Length,
1632            To_Int (Flags),
1633            Sin'Address,
1634            Len'Access);
1635
1636       if Res = Failure then
1637          Raise_Socket_Error (Socket_Errno);
1638       end if;
1639
1640       Last := Last_Index (First => Item'First, Count => Res);
1641
1642       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1643       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1644    end Receive_Socket;
1645
1646    --------------------
1647    -- Receive_Vector --
1648    --------------------
1649
1650    procedure Receive_Vector
1651      (Socket : Socket_Type;
1652       Vector : Vector_Type;
1653       Count  : out Ada.Streams.Stream_Element_Count;
1654       Flags  : Request_Flag_Type := No_Request_Flag)
1655    is
1656       Res : ssize_t;
1657
1658       Msg : Msghdr :=
1659               (Msg_Name       => System.Null_Address,
1660                Msg_Namelen    => 0,
1661                Msg_Iov        => Vector'Address,
1662                Msg_Iovlen     => SOSC.Msg_Iovlen_T (Vector'Length),
1663                Msg_Control    => System.Null_Address,
1664                Msg_Controllen => 0,
1665                Msg_Flags      => 0);
1666
1667    begin
1668       Res :=
1669         C_Recvmsg
1670           (C.int (Socket),
1671            Msg'Address,
1672            To_Int (Flags));
1673
1674       if Res = ssize_t (Failure) then
1675          Raise_Socket_Error (Socket_Errno);
1676       end if;
1677
1678       Count := Ada.Streams.Stream_Element_Count (Res);
1679    end Receive_Vector;
1680
1681    -------------------
1682    -- Resolve_Error --
1683    -------------------
1684
1685    function Resolve_Error
1686      (Error_Value : Integer;
1687       From_Errno  : Boolean := True) return Error_Type
1688    is
1689       use GNAT.Sockets.SOSC;
1690
1691    begin
1692       if not From_Errno then
1693          case Error_Value is
1694             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1695             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1696             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
1697             when SOSC.NO_DATA        => return Unknown_Server_Error;
1698             when others              => return Cannot_Resolve_Error;
1699          end case;
1700       end if;
1701
1702       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1703       --  can't include it in the case statement below.
1704
1705       pragma Warnings (Off);
1706       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1707
1708       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1709          return Resource_Temporarily_Unavailable;
1710       end if;
1711
1712       pragma Warnings (On);
1713
1714       case Error_Value is
1715          when ENOERROR        => return Success;
1716          when EACCES          => return Permission_Denied;
1717          when EADDRINUSE      => return Address_Already_In_Use;
1718          when EADDRNOTAVAIL   => return Cannot_Assign_Requested_Address;
1719          when EAFNOSUPPORT    => return
1720                                  Address_Family_Not_Supported_By_Protocol;
1721          when EALREADY        => return Operation_Already_In_Progress;
1722          when EBADF           => return Bad_File_Descriptor;
1723          when ECONNABORTED    => return Software_Caused_Connection_Abort;
1724          when ECONNREFUSED    => return Connection_Refused;
1725          when ECONNRESET      => return Connection_Reset_By_Peer;
1726          when EDESTADDRREQ    => return Destination_Address_Required;
1727          when EFAULT          => return Bad_Address;
1728          when EHOSTDOWN       => return Host_Is_Down;
1729          when EHOSTUNREACH    => return No_Route_To_Host;
1730          when EINPROGRESS     => return Operation_Now_In_Progress;
1731          when EINTR           => return Interrupted_System_Call;
1732          when EINVAL          => return Invalid_Argument;
1733          when EIO             => return Input_Output_Error;
1734          when EISCONN         => return Transport_Endpoint_Already_Connected;
1735          when ELOOP           => return Too_Many_Symbolic_Links;
1736          when EMFILE          => return Too_Many_Open_Files;
1737          when EMSGSIZE        => return Message_Too_Long;
1738          when ENAMETOOLONG    => return File_Name_Too_Long;
1739          when ENETDOWN        => return Network_Is_Down;
1740          when ENETRESET       => return
1741                                  Network_Dropped_Connection_Because_Of_Reset;
1742          when ENETUNREACH     => return Network_Is_Unreachable;
1743          when ENOBUFS         => return No_Buffer_Space_Available;
1744          when ENOPROTOOPT     => return Protocol_Not_Available;
1745          when ENOTCONN        => return Transport_Endpoint_Not_Connected;
1746          when ENOTSOCK        => return Socket_Operation_On_Non_Socket;
1747          when EOPNOTSUPP      => return Operation_Not_Supported;
1748          when EPFNOSUPPORT    => return Protocol_Family_Not_Supported;
1749          when EPIPE           => return Broken_Pipe;
1750          when EPROTONOSUPPORT => return Protocol_Not_Supported;
1751          when EPROTOTYPE      => return Protocol_Wrong_Type_For_Socket;
1752          when ESHUTDOWN       => return
1753                                  Cannot_Send_After_Transport_Endpoint_Shutdown;
1754          when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1755          when ETIMEDOUT       => return Connection_Timed_Out;
1756          when ETOOMANYREFS    => return Too_Many_References;
1757          when EWOULDBLOCK     => return Resource_Temporarily_Unavailable;
1758
1759          when others          => return Cannot_Resolve_Error;
1760       end case;
1761    end Resolve_Error;
1762
1763    -----------------------
1764    -- Resolve_Exception --
1765    -----------------------
1766
1767    function Resolve_Exception
1768      (Occurrence : Exception_Occurrence) return Error_Type
1769    is
1770       Id    : constant Exception_Id := Exception_Identity (Occurrence);
1771       Msg   : constant String       := Exception_Message (Occurrence);
1772       First : Natural;
1773       Last  : Natural;
1774       Val   : Integer;
1775
1776    begin
1777       First := Msg'First;
1778       while First <= Msg'Last
1779         and then Msg (First) not in '0' .. '9'
1780       loop
1781          First := First + 1;
1782       end loop;
1783
1784       if First > Msg'Last then
1785          return Cannot_Resolve_Error;
1786       end if;
1787
1788       Last := First;
1789       while Last < Msg'Last
1790         and then Msg (Last + 1) in '0' .. '9'
1791       loop
1792          Last := Last + 1;
1793       end loop;
1794
1795       Val := Integer'Value (Msg (First .. Last));
1796
1797       if Id = Socket_Error_Id then
1798          return Resolve_Error (Val);
1799       elsif Id = Host_Error_Id then
1800          return Resolve_Error (Val, False);
1801       else
1802          return Cannot_Resolve_Error;
1803       end if;
1804    end Resolve_Exception;
1805
1806    -----------------
1807    -- Send_Socket --
1808    -----------------
1809
1810    procedure Send_Socket
1811      (Socket : Socket_Type;
1812       Item   : Ada.Streams.Stream_Element_Array;
1813       Last   : out Ada.Streams.Stream_Element_Offset;
1814       Flags  : Request_Flag_Type := No_Request_Flag)
1815    is
1816    begin
1817       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
1818    end Send_Socket;
1819
1820    -----------------
1821    -- Send_Socket --
1822    -----------------
1823
1824    procedure Send_Socket
1825      (Socket : Socket_Type;
1826       Item   : Ada.Streams.Stream_Element_Array;
1827       Last   : out Ada.Streams.Stream_Element_Offset;
1828       To     : Sock_Addr_Type;
1829       Flags  : Request_Flag_Type := No_Request_Flag)
1830    is
1831    begin
1832       Send_Socket
1833         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
1834    end Send_Socket;
1835
1836    -----------------
1837    -- Send_Socket --
1838    -----------------
1839
1840    procedure Send_Socket
1841      (Socket : Socket_Type;
1842       Item   : Ada.Streams.Stream_Element_Array;
1843       Last   : out Ada.Streams.Stream_Element_Offset;
1844       To     : access Sock_Addr_Type;
1845       Flags  : Request_Flag_Type := No_Request_Flag)
1846    is
1847       Res  : C.int;
1848
1849       Sin  : aliased Sockaddr_In;
1850       C_To : System.Address;
1851       Len  : C.int;
1852
1853    begin
1854       if To /= null then
1855          Set_Family  (Sin.Sin_Family, To.Family);
1856          Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
1857          Set_Port
1858            (Sin'Unchecked_Access,
1859             Short_To_Network (C.unsigned_short (To.Port)));
1860          C_To := Sin'Address;
1861          Len := Sin'Size / 8;
1862
1863       else
1864          C_To := System.Null_Address;
1865          Len := 0;
1866       end if;
1867
1868       Res := C_Sendto
1869         (C.int (Socket),
1870          Item'Address,
1871          Item'Length,
1872          Set_Forced_Flags (To_Int (Flags)),
1873          C_To,
1874          Len);
1875
1876       if Res = Failure then
1877          Raise_Socket_Error (Socket_Errno);
1878       end if;
1879
1880       Last := Last_Index (First => Item'First, Count => Res);
1881    end Send_Socket;
1882
1883    -----------------
1884    -- Send_Vector --
1885    -----------------
1886
1887    procedure Send_Vector
1888      (Socket : Socket_Type;
1889       Vector : Vector_Type;
1890       Count  : out Ada.Streams.Stream_Element_Count;
1891       Flags  : Request_Flag_Type := No_Request_Flag)
1892    is
1893       use SOSC;
1894       use Interfaces.C;
1895
1896       Res            : ssize_t;
1897       Iov_Count      : SOSC.Msg_Iovlen_T;
1898       This_Iov_Count : SOSC.Msg_Iovlen_T;
1899       Msg            : Msghdr;
1900
1901    begin
1902       Count := 0;
1903       Iov_Count := 0;
1904       while Iov_Count < Vector'Length loop
1905
1906          pragma Warnings (Off);
1907          --  Following test may be compile time known on some targets
1908
1909          This_Iov_Count :=
1910            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
1911             then SOSC.IOV_MAX
1912             else Vector'Length - Iov_Count);
1913
1914          pragma Warnings (On);
1915
1916          Msg :=
1917            (Msg_Name       => System.Null_Address,
1918             Msg_Namelen    => 0,
1919             Msg_Iov        => Vector
1920                                 (Vector'First + Integer (Iov_Count))'Address,
1921             Msg_Iovlen     => This_Iov_Count,
1922             Msg_Control    => System.Null_Address,
1923             Msg_Controllen => 0,
1924             Msg_Flags      => 0);
1925
1926          Res :=
1927            C_Sendmsg
1928              (C.int (Socket),
1929               Msg'Address,
1930               Set_Forced_Flags (To_Int (Flags)));
1931
1932          if Res = ssize_t (Failure) then
1933             Raise_Socket_Error (Socket_Errno);
1934          end if;
1935
1936          Count := Count + Ada.Streams.Stream_Element_Count (Res);
1937          Iov_Count := Iov_Count + This_Iov_Count;
1938       end loop;
1939    end Send_Vector;
1940
1941    ---------
1942    -- Set --
1943    ---------
1944
1945    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1946    begin
1947       if Item.Last = No_Socket then
1948
1949          --  Uninitialized socket set, make sure it is properly zeroed out
1950
1951          Reset_Socket_Set (Item.Set'Access);
1952          Item.Last := Socket;
1953
1954       elsif Item.Last < Socket then
1955          Item.Last := Socket;
1956       end if;
1957
1958       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
1959    end Set;
1960
1961    ----------------------
1962    -- Set_Forced_Flags --
1963    ----------------------
1964
1965    function Set_Forced_Flags (F : C.int) return C.int is
1966       use type C.unsigned;
1967       function To_unsigned is
1968         new Ada.Unchecked_Conversion (C.int, C.unsigned);
1969       function To_int is
1970         new Ada.Unchecked_Conversion (C.unsigned, C.int);
1971    begin
1972       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
1973    end Set_Forced_Flags;
1974
1975    -----------------------
1976    -- Set_Socket_Option --
1977    -----------------------
1978
1979    procedure Set_Socket_Option
1980      (Socket : Socket_Type;
1981       Level  : Level_Type := Socket_Level;
1982       Option : Option_Type)
1983    is
1984       V8  : aliased Two_Ints;
1985       V4  : aliased C.int;
1986       V1  : aliased C.unsigned_char;
1987       VT  : aliased Timeval;
1988       Len : C.int;
1989       Add : System.Address := Null_Address;
1990       Res : C.int;
1991
1992    begin
1993       case Option.Name is
1994          when Keep_Alive      |
1995               Reuse_Address   |
1996               Broadcast       |
1997               No_Delay        =>
1998             V4  := C.int (Boolean'Pos (Option.Enabled));
1999             Len := V4'Size / 8;
2000             Add := V4'Address;
2001
2002          when Linger          =>
2003             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2004             V8 (V8'Last)  := C.int (Option.Seconds);
2005             Len := V8'Size / 8;
2006             Add := V8'Address;
2007
2008          when Send_Buffer     |
2009               Receive_Buffer  =>
2010             V4  := C.int (Option.Size);
2011             Len := V4'Size / 8;
2012             Add := V4'Address;
2013
2014          when Error           =>
2015             V4  := C.int (Boolean'Pos (True));
2016             Len := V4'Size / 8;
2017             Add := V4'Address;
2018
2019          when Add_Membership  |
2020               Drop_Membership =>
2021             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2022             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2023             Len := V8'Size / 8;
2024             Add := V8'Address;
2025
2026          when Multicast_If    =>
2027             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2028             Len := V4'Size / 8;
2029             Add := V4'Address;
2030
2031          when Multicast_TTL   =>
2032             V1  := C.unsigned_char (Option.Time_To_Live);
2033             Len := V1'Size / 8;
2034             Add := V1'Address;
2035
2036          when Multicast_Loop      |
2037               Receive_Packet_Info =>
2038             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2039             Len := V1'Size / 8;
2040             Add := V1'Address;
2041
2042          when Send_Timeout    |
2043               Receive_Timeout =>
2044             VT  := To_Timeval (Option.Timeout);
2045             Len := VT'Size / 8;
2046             Add := VT'Address;
2047
2048       end case;
2049
2050       Res := C_Setsockopt
2051         (C.int (Socket),
2052          Levels (Level),
2053          Options (Option.Name),
2054          Add, Len);
2055
2056       if Res = Failure then
2057          Raise_Socket_Error (Socket_Errno);
2058       end if;
2059    end Set_Socket_Option;
2060
2061    ----------------------
2062    -- Short_To_Network --
2063    ----------------------
2064
2065    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2066       use type C.unsigned_short;
2067
2068    begin
2069       --  Big-endian case. No conversion needed. On these platforms,
2070       --  htons() defaults to a null procedure.
2071
2072       pragma Warnings (Off);
2073       --  Since the test can generate "always True/False" warning
2074
2075       if Default_Bit_Order = High_Order_First then
2076          return S;
2077
2078          pragma Warnings (On);
2079
2080       --  Little-endian case. We must swap the high and low bytes of this
2081       --  short to make the port number network compliant.
2082
2083       else
2084          return (S / 256) + (S mod 256) * 256;
2085       end if;
2086    end Short_To_Network;
2087
2088    ---------------------
2089    -- Shutdown_Socket --
2090    ---------------------
2091
2092    procedure Shutdown_Socket
2093      (Socket : Socket_Type;
2094       How    : Shutmode_Type := Shut_Read_Write)
2095    is
2096       Res : C.int;
2097
2098    begin
2099       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2100
2101       if Res = Failure then
2102          Raise_Socket_Error (Socket_Errno);
2103       end if;
2104    end Shutdown_Socket;
2105
2106    ------------
2107    -- Stream --
2108    ------------
2109
2110    function Stream
2111      (Socket  : Socket_Type;
2112       Send_To : Sock_Addr_Type) return Stream_Access
2113    is
2114       S : Datagram_Socket_Stream_Access;
2115
2116    begin
2117       S        := new Datagram_Socket_Stream_Type;
2118       S.Socket := Socket;
2119       S.To     := Send_To;
2120       S.From   := Get_Socket_Name (Socket);
2121       return Stream_Access (S);
2122    end Stream;
2123
2124    ------------
2125    -- Stream --
2126    ------------
2127
2128    function Stream (Socket : Socket_Type) return Stream_Access is
2129       S : Stream_Socket_Stream_Access;
2130    begin
2131       S := new Stream_Socket_Stream_Type;
2132       S.Socket := Socket;
2133       return Stream_Access (S);
2134    end Stream;
2135
2136    ------------------
2137    -- Stream_Write --
2138    ------------------
2139
2140    procedure Stream_Write
2141      (Socket : Socket_Type;
2142       Item   : Ada.Streams.Stream_Element_Array;
2143       To     : access Sock_Addr_Type)
2144    is
2145       First : Ada.Streams.Stream_Element_Offset;
2146       Index : Ada.Streams.Stream_Element_Offset;
2147       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2148
2149    begin
2150       First := Item'First;
2151       Index := First - 1;
2152       while First <= Max loop
2153          Send_Socket (Socket, Item (First .. Max), Index, To);
2154
2155          --  Exit when all or zero data sent. Zero means that the socket has
2156          --  been closed by peer.
2157
2158          exit when Index < First or else Index = Max;
2159
2160          First := Index + 1;
2161       end loop;
2162
2163       --  For an empty array, we have First > Max, and hence Index >= Max (no
2164       --  error, the loop above is never executed). After a succesful send,
2165       --  Index = Max. The only remaining case, Index < Max, is therefore
2166       --  always an actual send failure.
2167
2168       if Index < Max then
2169          Raise_Socket_Error (Socket_Errno);
2170       end if;
2171    end Stream_Write;
2172
2173    ----------
2174    -- To_C --
2175    ----------
2176
2177    function To_C (Socket : Socket_Type) return Integer is
2178    begin
2179       return Integer (Socket);
2180    end To_C;
2181
2182    -----------------
2183    -- To_Duration --
2184    -----------------
2185
2186    function To_Duration (Val : Timeval) return Timeval_Duration is
2187    begin
2188       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2189    end To_Duration;
2190
2191    -------------------
2192    -- To_Host_Entry --
2193    -------------------
2194
2195    function To_Host_Entry (E : Hostent) return Host_Entry_Type is
2196       use type C.size_t;
2197
2198       Official : constant String :=
2199                   C.Strings.Value (E.H_Name);
2200
2201       Aliases : constant Chars_Ptr_Array :=
2202                   Chars_Ptr_Pointers.Value (E.H_Aliases);
2203       --  H_Aliases points to a list of name aliases. The list is terminated by
2204       --  a NULL pointer.
2205
2206       Addresses : constant In_Addr_Access_Array :=
2207                     In_Addr_Access_Pointers.Value (E.H_Addr_List);
2208       --  H_Addr_List points to a list of binary addresses (in network byte
2209       --  order). The list is terminated by a NULL pointer.
2210       --
2211       --  H_Length is not used because it is currently only set to 4.
2212       --  H_Addrtype is always AF_INET
2213
2214       Result : Host_Entry_Type
2215                  (Aliases_Length   => Aliases'Length - 1,
2216                   Addresses_Length => Addresses'Length - 1);
2217       --  The last element is a null pointer
2218
2219       Source : C.size_t;
2220       Target : Natural;
2221
2222    begin
2223       Result.Official := To_Name (Official);
2224
2225       Source := Aliases'First;
2226       Target := Result.Aliases'First;
2227       while Target <= Result.Aliases_Length loop
2228          Result.Aliases (Target) :=
2229            To_Name (C.Strings.Value (Aliases (Source)));
2230          Source := Source + 1;
2231          Target := Target + 1;
2232       end loop;
2233
2234       Source := Addresses'First;
2235       Target := Result.Addresses'First;
2236       while Target <= Result.Addresses_Length loop
2237          To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
2238          Source := Source + 1;
2239          Target := Target + 1;
2240       end loop;
2241
2242       return Result;
2243    end To_Host_Entry;
2244
2245    ----------------
2246    -- To_In_Addr --
2247    ----------------
2248
2249    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2250    begin
2251       if Addr.Family = Family_Inet then
2252          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2253                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2254                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2255                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2256       end if;
2257
2258       raise Socket_Error with "IPv6 not supported";
2259    end To_In_Addr;
2260
2261    ------------------
2262    -- To_Inet_Addr --
2263    ------------------
2264
2265    procedure To_Inet_Addr
2266      (Addr   : In_Addr;
2267       Result : out Inet_Addr_Type) is
2268    begin
2269       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2270       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2271       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2272       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2273    end To_Inet_Addr;
2274
2275    ------------
2276    -- To_Int --
2277    ------------
2278
2279    function To_Int (F : Request_Flag_Type) return C.int
2280    is
2281       Current : Request_Flag_Type := F;
2282       Result  : C.int := 0;
2283
2284    begin
2285       for J in Flags'Range loop
2286          exit when Current = 0;
2287
2288          if Current mod 2 /= 0 then
2289             if Flags (J) = -1 then
2290                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2291             end if;
2292
2293             Result := Result + Flags (J);
2294          end if;
2295
2296          Current := Current / 2;
2297       end loop;
2298
2299       return Result;
2300    end To_Int;
2301
2302    -------------
2303    -- To_Name --
2304    -------------
2305
2306    function To_Name (N : String) return Name_Type is
2307    begin
2308       return Name_Type'(N'Length, N);
2309    end To_Name;
2310
2311    ----------------------
2312    -- To_Service_Entry --
2313    ----------------------
2314
2315    function To_Service_Entry (E : Servent) return Service_Entry_Type is
2316       use type C.size_t;
2317
2318       Official : constant String := C.Strings.Value (E.S_Name);
2319
2320       Aliases : constant Chars_Ptr_Array :=
2321                   Chars_Ptr_Pointers.Value (E.S_Aliases);
2322       --  S_Aliases points to a list of name aliases. The list is
2323       --  terminated by a NULL pointer.
2324
2325       Protocol : constant String := C.Strings.Value (E.S_Proto);
2326
2327       Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
2328       --  The last element is a null pointer
2329
2330       Source : C.size_t;
2331       Target : Natural;
2332
2333    begin
2334       Result.Official := To_Name (Official);
2335
2336       Source := Aliases'First;
2337       Target := Result.Aliases'First;
2338       while Target <= Result.Aliases_Length loop
2339          Result.Aliases (Target) :=
2340            To_Name (C.Strings.Value (Aliases (Source)));
2341          Source := Source + 1;
2342          Target := Target + 1;
2343       end loop;
2344
2345       Result.Port :=
2346         Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2347
2348       Result.Protocol := To_Name (Protocol);
2349       return Result;
2350    end To_Service_Entry;
2351
2352    ---------------
2353    -- To_String --
2354    ---------------
2355
2356    function To_String (HN : Name_Type) return String is
2357    begin
2358       return HN.Name (1 .. HN.Length);
2359    end To_String;
2360
2361    ----------------
2362    -- To_Timeval --
2363    ----------------
2364
2365    function To_Timeval (Val : Timeval_Duration) return Timeval is
2366       S  : time_t;
2367       uS : suseconds_t;
2368
2369    begin
2370       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2371
2372       if Val = 0.0 then
2373          S  := 0;
2374          uS := 0;
2375
2376       --  Normal case where we do round down
2377
2378       else
2379          S  := time_t (Val - 0.5);
2380          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2381       end if;
2382
2383       return (S, uS);
2384    end To_Timeval;
2385
2386    -----------
2387    -- Write --
2388    -----------
2389
2390    procedure Write
2391      (Stream : in out Datagram_Socket_Stream_Type;
2392       Item   : Ada.Streams.Stream_Element_Array)
2393    is
2394    begin
2395       Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2396    end Write;
2397
2398    -----------
2399    -- Write --
2400    -----------
2401
2402    procedure Write
2403      (Stream : in out Stream_Socket_Stream_Type;
2404       Item   : Ada.Streams.Stream_Element_Array)
2405    is
2406    begin
2407       Stream_Write (Stream.Socket, Item, To => null);
2408    end Write;
2409
2410    Sockets_Library_Controller_Object : Sockets_Library_Controller;
2411    pragma Unreferenced (Sockets_Library_Controller_Object);
2412    --  The elaboration and finalization of this object perform the required
2413    --  initialization and cleanup actions for the sockets library.
2414
2415 end GNAT.Sockets;