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