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           & 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) & Socket_Error_Message (Error);
1724    end Raise_Socket_Error;
1725
1726    ----------
1727    -- Read --
1728    ----------
1729
1730    procedure Read
1731      (Stream : in out Datagram_Socket_Stream_Type;
1732       Item   : out Ada.Streams.Stream_Element_Array;
1733       Last   : out Ada.Streams.Stream_Element_Offset)
1734    is
1735       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1736       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1737       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1738
1739    begin
1740       loop
1741          Receive_Socket
1742            (Stream.Socket,
1743             Item (First .. Max),
1744             Index,
1745             Stream.From);
1746
1747          Last := Index;
1748
1749          --  Exit when all or zero data received. Zero means that the socket
1750          --  peer is closed.
1751
1752          exit when Index < First or else Index = Max;
1753
1754          First := Index + 1;
1755       end loop;
1756    end Read;
1757
1758    ----------
1759    -- Read --
1760    ----------
1761
1762    procedure Read
1763      (Stream : in out Stream_Socket_Stream_Type;
1764       Item   : out Ada.Streams.Stream_Element_Array;
1765       Last   : out Ada.Streams.Stream_Element_Offset)
1766    is
1767       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1768       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1769       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1770
1771    begin
1772       loop
1773          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1774          Last  := Index;
1775
1776          --  Exit when all or zero data received. Zero means that the socket
1777          --  peer is closed.
1778
1779          exit when Index < First or else Index = Max;
1780
1781          First := Index + 1;
1782       end loop;
1783    end Read;
1784
1785    --------------------
1786    -- Receive_Socket --
1787    --------------------
1788
1789    procedure Receive_Socket
1790      (Socket : Socket_Type;
1791       Item   : out Ada.Streams.Stream_Element_Array;
1792       Last   : out Ada.Streams.Stream_Element_Offset;
1793       Flags  : Request_Flag_Type := No_Request_Flag)
1794    is
1795       Res : C.int;
1796
1797    begin
1798       Res :=
1799         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1800
1801       if Res = Failure then
1802          Raise_Socket_Error (Socket_Errno);
1803       end if;
1804
1805       Last := Last_Index (First => Item'First, Count => size_t (Res));
1806    end Receive_Socket;
1807
1808    --------------------
1809    -- Receive_Socket --
1810    --------------------
1811
1812    procedure Receive_Socket
1813      (Socket : Socket_Type;
1814       Item   : out Ada.Streams.Stream_Element_Array;
1815       Last   : out Ada.Streams.Stream_Element_Offset;
1816       From   : out Sock_Addr_Type;
1817       Flags  : Request_Flag_Type := No_Request_Flag)
1818    is
1819       Res : C.int;
1820       Sin : aliased Sockaddr_In;
1821       Len : aliased C.int := Sin'Size / 8;
1822
1823    begin
1824       Res :=
1825         C_Recvfrom
1826           (C.int (Socket),
1827            Item'Address,
1828            Item'Length,
1829            To_Int (Flags),
1830            Sin'Address,
1831            Len'Access);
1832
1833       if Res = Failure then
1834          Raise_Socket_Error (Socket_Errno);
1835       end if;
1836
1837       Last := Last_Index (First => Item'First, Count => size_t (Res));
1838
1839       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1840       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1841    end Receive_Socket;
1842
1843    --------------------
1844    -- Receive_Vector --
1845    --------------------
1846
1847    procedure Receive_Vector
1848      (Socket : Socket_Type;
1849       Vector : Vector_Type;
1850       Count  : out Ada.Streams.Stream_Element_Count;
1851       Flags  : Request_Flag_Type := No_Request_Flag)
1852    is
1853       Res : ssize_t;
1854
1855       Msg : Msghdr :=
1856               (Msg_Name       => System.Null_Address,
1857                Msg_Namelen    => 0,
1858                Msg_Iov        => Vector'Address,
1859
1860                --  recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1861                --  platforms) when the supplied vector is longer than IOV_MAX,
1862                --  so use minimum of the two lengths.
1863
1864                Msg_Iovlen     => SOSC.Msg_Iovlen_T'Min
1865                                    (Vector'Length, SOSC.IOV_MAX),
1866
1867                Msg_Control    => System.Null_Address,
1868                Msg_Controllen => 0,
1869                Msg_Flags      => 0);
1870
1871    begin
1872       Res :=
1873         C_Recvmsg
1874           (C.int (Socket),
1875            Msg'Address,
1876            To_Int (Flags));
1877
1878       if Res = ssize_t (Failure) then
1879          Raise_Socket_Error (Socket_Errno);
1880       end if;
1881
1882       Count := Ada.Streams.Stream_Element_Count (Res);
1883    end Receive_Vector;
1884
1885    -------------------
1886    -- Resolve_Error --
1887    -------------------
1888
1889    function Resolve_Error
1890      (Error_Value : Integer;
1891       From_Errno  : Boolean := True) return Error_Type
1892    is
1893       use GNAT.Sockets.SOSC;
1894
1895    begin
1896       if not From_Errno then
1897          case Error_Value is
1898             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1899             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1900             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
1901             when SOSC.NO_DATA        => return Unknown_Server_Error;
1902             when others              => return Cannot_Resolve_Error;
1903          end case;
1904       end if;
1905
1906       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1907       --  can't include it in the case statement below.
1908
1909       pragma Warnings (Off);
1910       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1911
1912       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1913          return Resource_Temporarily_Unavailable;
1914       end if;
1915
1916       --  This is not a case statement because if a particular error
1917       --  number constant is not defined, s-oscons-tmplt.c defines
1918       --  it to -1.  If multiple constants are not defined, they
1919       --  would each be -1 and result in a "duplicate value in case" error.
1920       --
1921       --  But we have to leave warnings off because the compiler is also
1922       --  smart enough to note that when two errnos have the same value,
1923       --  the second if condition is useless.
1924       if Error_Value = ENOERROR then
1925          return Success;
1926       elsif Error_Value = EACCES then
1927          return Permission_Denied;
1928       elsif Error_Value = EADDRINUSE then
1929          return Address_Already_In_Use;
1930       elsif Error_Value = EADDRNOTAVAIL then
1931          return Cannot_Assign_Requested_Address;
1932       elsif Error_Value = EAFNOSUPPORT then
1933          return Address_Family_Not_Supported_By_Protocol;
1934       elsif Error_Value = EALREADY then
1935          return Operation_Already_In_Progress;
1936       elsif Error_Value = EBADF then
1937          return Bad_File_Descriptor;
1938       elsif Error_Value = ECONNABORTED then
1939          return Software_Caused_Connection_Abort;
1940       elsif Error_Value = ECONNREFUSED then
1941          return Connection_Refused;
1942       elsif Error_Value = ECONNRESET then
1943          return Connection_Reset_By_Peer;
1944       elsif Error_Value = EDESTADDRREQ then
1945          return Destination_Address_Required;
1946       elsif Error_Value = EFAULT then
1947          return Bad_Address;
1948       elsif Error_Value = EHOSTDOWN then
1949          return Host_Is_Down;
1950       elsif Error_Value = EHOSTUNREACH then
1951          return No_Route_To_Host;
1952       elsif Error_Value = EINPROGRESS then
1953          return Operation_Now_In_Progress;
1954       elsif Error_Value = EINTR then
1955          return Interrupted_System_Call;
1956       elsif Error_Value = EINVAL then
1957          return Invalid_Argument;
1958       elsif Error_Value = EIO then
1959          return Input_Output_Error;
1960       elsif Error_Value = EISCONN then
1961          return Transport_Endpoint_Already_Connected;
1962       elsif Error_Value = ELOOP then
1963          return Too_Many_Symbolic_Links;
1964       elsif Error_Value = EMFILE then
1965          return Too_Many_Open_Files;
1966       elsif Error_Value = EMSGSIZE then
1967          return Message_Too_Long;
1968       elsif Error_Value = ENAMETOOLONG then
1969          return File_Name_Too_Long;
1970       elsif Error_Value = ENETDOWN then
1971          return Network_Is_Down;
1972       elsif Error_Value = ENETRESET then
1973          return Network_Dropped_Connection_Because_Of_Reset;
1974       elsif Error_Value = ENETUNREACH then
1975          return Network_Is_Unreachable;
1976       elsif Error_Value = ENOBUFS then
1977          return No_Buffer_Space_Available;
1978       elsif Error_Value = ENOPROTOOPT then
1979          return Protocol_Not_Available;
1980       elsif Error_Value = ENOTCONN then
1981          return Transport_Endpoint_Not_Connected;
1982       elsif Error_Value = ENOTSOCK then
1983          return Socket_Operation_On_Non_Socket;
1984       elsif Error_Value = EOPNOTSUPP then
1985          return Operation_Not_Supported;
1986       elsif Error_Value = EPFNOSUPPORT then
1987          return Protocol_Family_Not_Supported;
1988       elsif Error_Value = EPIPE then
1989          return Broken_Pipe;
1990       elsif Error_Value = EPROTONOSUPPORT then
1991          return Protocol_Not_Supported;
1992       elsif Error_Value = EPROTOTYPE then
1993          return Protocol_Wrong_Type_For_Socket;
1994       elsif Error_Value = ESHUTDOWN then
1995          return Cannot_Send_After_Transport_Endpoint_Shutdown;
1996       elsif Error_Value = ESOCKTNOSUPPORT then
1997          return Socket_Type_Not_Supported;
1998       elsif Error_Value = ETIMEDOUT then
1999          return Connection_Timed_Out;
2000       elsif Error_Value = ETOOMANYREFS then
2001          return Too_Many_References;
2002       elsif Error_Value = EWOULDBLOCK then
2003          return Resource_Temporarily_Unavailable;
2004       else
2005          return Cannot_Resolve_Error;
2006       end if;
2007       pragma Warnings (On);
2008
2009    end Resolve_Error;
2010
2011    -----------------------
2012    -- Resolve_Exception --
2013    -----------------------
2014
2015    function Resolve_Exception
2016      (Occurrence : Exception_Occurrence) return Error_Type
2017    is
2018       Id    : constant Exception_Id := Exception_Identity (Occurrence);
2019       Msg   : constant String       := Exception_Message (Occurrence);
2020       First : Natural;
2021       Last  : Natural;
2022       Val   : Integer;
2023
2024    begin
2025       First := Msg'First;
2026       while First <= Msg'Last
2027         and then Msg (First) not in '0' .. '9'
2028       loop
2029          First := First + 1;
2030       end loop;
2031
2032       if First > Msg'Last then
2033          return Cannot_Resolve_Error;
2034       end if;
2035
2036       Last := First;
2037       while Last < Msg'Last
2038         and then Msg (Last + 1) in '0' .. '9'
2039       loop
2040          Last := Last + 1;
2041       end loop;
2042
2043       Val := Integer'Value (Msg (First .. Last));
2044
2045       if Id = Socket_Error_Id then
2046          return Resolve_Error (Val);
2047
2048       elsif Id = Host_Error_Id then
2049          return Resolve_Error (Val, False);
2050
2051       else
2052          return Cannot_Resolve_Error;
2053       end if;
2054    end Resolve_Exception;
2055
2056    -----------------
2057    -- Send_Socket --
2058    -----------------
2059
2060    procedure Send_Socket
2061      (Socket : Socket_Type;
2062       Item   : Ada.Streams.Stream_Element_Array;
2063       Last   : out Ada.Streams.Stream_Element_Offset;
2064       Flags  : Request_Flag_Type := No_Request_Flag)
2065    is
2066    begin
2067       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2068    end Send_Socket;
2069
2070    -----------------
2071    -- Send_Socket --
2072    -----------------
2073
2074    procedure Send_Socket
2075      (Socket : Socket_Type;
2076       Item   : Ada.Streams.Stream_Element_Array;
2077       Last   : out Ada.Streams.Stream_Element_Offset;
2078       To     : Sock_Addr_Type;
2079       Flags  : Request_Flag_Type := No_Request_Flag)
2080    is
2081    begin
2082       Send_Socket
2083         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2084    end Send_Socket;
2085
2086    -----------------
2087    -- Send_Socket --
2088    -----------------
2089
2090    procedure Send_Socket
2091      (Socket : Socket_Type;
2092       Item   : Ada.Streams.Stream_Element_Array;
2093       Last   : out Ada.Streams.Stream_Element_Offset;
2094       To     : access Sock_Addr_Type;
2095       Flags  : Request_Flag_Type := No_Request_Flag)
2096    is
2097       Res  : C.int;
2098
2099       Sin  : aliased Sockaddr_In;
2100       C_To : System.Address;
2101       Len  : C.int;
2102
2103    begin
2104       if To /= null then
2105          Set_Family  (Sin.Sin_Family, To.Family);
2106          Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
2107          Set_Port
2108            (Sin'Unchecked_Access,
2109             Short_To_Network (C.unsigned_short (To.Port)));
2110          C_To := Sin'Address;
2111          Len := Sin'Size / 8;
2112
2113       else
2114          C_To := System.Null_Address;
2115          Len := 0;
2116       end if;
2117
2118       Res := C_Sendto
2119         (C.int (Socket),
2120          Item'Address,
2121          Item'Length,
2122          Set_Forced_Flags (To_Int (Flags)),
2123          C_To,
2124          Len);
2125
2126       if Res = Failure then
2127          Raise_Socket_Error (Socket_Errno);
2128       end if;
2129
2130       Last := Last_Index (First => Item'First, Count => size_t (Res));
2131    end Send_Socket;
2132
2133    -----------------
2134    -- Send_Vector --
2135    -----------------
2136
2137    procedure Send_Vector
2138      (Socket : Socket_Type;
2139       Vector : Vector_Type;
2140       Count  : out Ada.Streams.Stream_Element_Count;
2141       Flags  : Request_Flag_Type := No_Request_Flag)
2142    is
2143       use SOSC;
2144       use Interfaces.C;
2145
2146       Res            : ssize_t;
2147       Iov_Count      : SOSC.Msg_Iovlen_T;
2148       This_Iov_Count : SOSC.Msg_Iovlen_T;
2149       Msg            : Msghdr;
2150
2151    begin
2152       Count := 0;
2153       Iov_Count := 0;
2154       while Iov_Count < Vector'Length loop
2155
2156          pragma Warnings (Off);
2157          --  Following test may be compile time known on some targets
2158
2159          This_Iov_Count :=
2160            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2161             then SOSC.IOV_MAX
2162             else Vector'Length - Iov_Count);
2163
2164          pragma Warnings (On);
2165
2166          Msg :=
2167            (Msg_Name       => System.Null_Address,
2168             Msg_Namelen    => 0,
2169             Msg_Iov        => Vector
2170                                 (Vector'First + Integer (Iov_Count))'Address,
2171             Msg_Iovlen     => This_Iov_Count,
2172             Msg_Control    => System.Null_Address,
2173             Msg_Controllen => 0,
2174             Msg_Flags      => 0);
2175
2176          Res :=
2177            C_Sendmsg
2178              (C.int (Socket),
2179               Msg'Address,
2180               Set_Forced_Flags (To_Int (Flags)));
2181
2182          if Res = ssize_t (Failure) then
2183             Raise_Socket_Error (Socket_Errno);
2184          end if;
2185
2186          Count := Count + Ada.Streams.Stream_Element_Count (Res);
2187          Iov_Count := Iov_Count + This_Iov_Count;
2188       end loop;
2189    end Send_Vector;
2190
2191    ---------
2192    -- Set --
2193    ---------
2194
2195    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2196    begin
2197       Check_For_Fd_Set (Socket);
2198
2199       if Item.Last = No_Socket then
2200
2201          --  Uninitialized socket set, make sure it is properly zeroed out
2202
2203          Reset_Socket_Set (Item.Set'Access);
2204          Item.Last := Socket;
2205
2206       elsif Item.Last < Socket then
2207          Item.Last := Socket;
2208       end if;
2209
2210       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2211    end Set;
2212
2213    -----------------------
2214    -- Set_Close_On_Exec --
2215    -----------------------
2216
2217    procedure Set_Close_On_Exec
2218      (Socket        : Socket_Type;
2219       Close_On_Exec : Boolean;
2220       Status        : out Boolean)
2221    is
2222       function C_Set_Close_On_Exec
2223         (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
2224       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2225    begin
2226       Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
2227    end Set_Close_On_Exec;
2228
2229    ----------------------
2230    -- Set_Forced_Flags --
2231    ----------------------
2232
2233    function Set_Forced_Flags (F : C.int) return C.int is
2234       use type C.unsigned;
2235       function To_unsigned is
2236         new Ada.Unchecked_Conversion (C.int, C.unsigned);
2237       function To_int is
2238         new Ada.Unchecked_Conversion (C.unsigned, C.int);
2239    begin
2240       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2241    end Set_Forced_Flags;
2242
2243    -----------------------
2244    -- Set_Socket_Option --
2245    -----------------------
2246
2247    procedure Set_Socket_Option
2248      (Socket : Socket_Type;
2249       Level  : Level_Type := Socket_Level;
2250       Option : Option_Type)
2251    is
2252       use SOSC;
2253
2254       V8  : aliased Two_Ints;
2255       V4  : aliased C.int;
2256       V1  : aliased C.unsigned_char;
2257       VT  : aliased Timeval;
2258       Len : C.int;
2259       Add : System.Address := Null_Address;
2260       Res : C.int;
2261
2262    begin
2263       case Option.Name is
2264          when Keep_Alive      |
2265               Reuse_Address   |
2266               Broadcast       |
2267               No_Delay        =>
2268             V4  := C.int (Boolean'Pos (Option.Enabled));
2269             Len := V4'Size / 8;
2270             Add := V4'Address;
2271
2272          when Linger          =>
2273             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2274             V8 (V8'Last)  := C.int (Option.Seconds);
2275             Len := V8'Size / 8;
2276             Add := V8'Address;
2277
2278          when Send_Buffer     |
2279               Receive_Buffer  =>
2280             V4  := C.int (Option.Size);
2281             Len := V4'Size / 8;
2282             Add := V4'Address;
2283
2284          when Error           =>
2285             V4  := C.int (Boolean'Pos (True));
2286             Len := V4'Size / 8;
2287             Add := V4'Address;
2288
2289          when Add_Membership  |
2290               Drop_Membership =>
2291             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2292             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2293             Len := V8'Size / 8;
2294             Add := V8'Address;
2295
2296          when Multicast_If    =>
2297             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2298             Len := V4'Size / 8;
2299             Add := V4'Address;
2300
2301          when Multicast_TTL   =>
2302             V1  := C.unsigned_char (Option.Time_To_Live);
2303             Len := V1'Size / 8;
2304             Add := V1'Address;
2305
2306          when Multicast_Loop      |
2307               Receive_Packet_Info =>
2308             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2309             Len := V1'Size / 8;
2310             Add := V1'Address;
2311
2312          when Send_Timeout    |
2313               Receive_Timeout =>
2314
2315             if Target_OS = Windows then
2316
2317                --  On Windows, the timeout is a DWORD in milliseconds, and
2318                --  the actual timeout is 500 ms + the given value (unless it
2319                --  is 0).
2320
2321                V4 := C.int (Option.Timeout / 0.001);
2322
2323                if V4 > 500 then
2324                   V4 := V4 - 500;
2325
2326                elsif V4 > 0 then
2327                   V4 := 1;
2328                end if;
2329
2330                Len := V4'Size / 8;
2331                Add := V4'Address;
2332
2333             else
2334                VT  := To_Timeval (Option.Timeout);
2335                Len := VT'Size / 8;
2336                Add := VT'Address;
2337             end if;
2338
2339       end case;
2340
2341       Res := C_Setsockopt
2342         (C.int (Socket),
2343          Levels (Level),
2344          Options (Option.Name),
2345          Add, Len);
2346
2347       if Res = Failure then
2348          Raise_Socket_Error (Socket_Errno);
2349       end if;
2350    end Set_Socket_Option;
2351
2352    ----------------------
2353    -- Short_To_Network --
2354    ----------------------
2355
2356    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2357       use type C.unsigned_short;
2358
2359    begin
2360       --  Big-endian case. No conversion needed. On these platforms, htons()
2361       --  defaults to a null procedure.
2362
2363       if Default_Bit_Order = High_Order_First then
2364          return S;
2365
2366       --  Little-endian case. We must swap the high and low bytes of this
2367       --  short to make the port number network compliant.
2368
2369       else
2370          return (S / 256) + (S mod 256) * 256;
2371       end if;
2372    end Short_To_Network;
2373
2374    ---------------------
2375    -- Shutdown_Socket --
2376    ---------------------
2377
2378    procedure Shutdown_Socket
2379      (Socket : Socket_Type;
2380       How    : Shutmode_Type := Shut_Read_Write)
2381    is
2382       Res : C.int;
2383
2384    begin
2385       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2386
2387       if Res = Failure then
2388          Raise_Socket_Error (Socket_Errno);
2389       end if;
2390    end Shutdown_Socket;
2391
2392    ------------
2393    -- Stream --
2394    ------------
2395
2396    function Stream
2397      (Socket  : Socket_Type;
2398       Send_To : Sock_Addr_Type) return Stream_Access
2399    is
2400       S : Datagram_Socket_Stream_Access;
2401
2402    begin
2403       S        := new Datagram_Socket_Stream_Type;
2404       S.Socket := Socket;
2405       S.To     := Send_To;
2406       S.From   := Get_Socket_Name (Socket);
2407       return Stream_Access (S);
2408    end Stream;
2409
2410    ------------
2411    -- Stream --
2412    ------------
2413
2414    function Stream (Socket : Socket_Type) return Stream_Access is
2415       S : Stream_Socket_Stream_Access;
2416    begin
2417       S := new Stream_Socket_Stream_Type;
2418       S.Socket := Socket;
2419       return Stream_Access (S);
2420    end Stream;
2421
2422    ------------------
2423    -- Stream_Write --
2424    ------------------
2425
2426    procedure Stream_Write
2427      (Socket : Socket_Type;
2428       Item   : Ada.Streams.Stream_Element_Array;
2429       To     : access Sock_Addr_Type)
2430    is
2431       First : Ada.Streams.Stream_Element_Offset;
2432       Index : Ada.Streams.Stream_Element_Offset;
2433       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2434
2435    begin
2436       First := Item'First;
2437       Index := First - 1;
2438       while First <= Max loop
2439          Send_Socket (Socket, Item (First .. Max), Index, To);
2440
2441          --  Exit when all or zero data sent. Zero means that the socket has
2442          --  been closed by peer.
2443
2444          exit when Index < First or else Index = Max;
2445
2446          First := Index + 1;
2447       end loop;
2448
2449       --  For an empty array, we have First > Max, and hence Index >= Max (no
2450       --  error, the loop above is never executed). After a successful send,
2451       --  Index = Max. The only remaining case, Index < Max, is therefore
2452       --  always an actual send failure.
2453
2454       if Index < Max then
2455          Raise_Socket_Error (Socket_Errno);
2456       end if;
2457    end Stream_Write;
2458
2459    ----------
2460    -- To_C --
2461    ----------
2462
2463    function To_C (Socket : Socket_Type) return Integer is
2464    begin
2465       return Integer (Socket);
2466    end To_C;
2467
2468    -----------------
2469    -- To_Duration --
2470    -----------------
2471
2472    function To_Duration (Val : Timeval) return Timeval_Duration is
2473    begin
2474       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2475    end To_Duration;
2476
2477    -------------------
2478    -- To_Host_Entry --
2479    -------------------
2480
2481    function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2482       use type C.size_t;
2483       use C.Strings;
2484
2485       Aliases_Count, Addresses_Count : Natural;
2486
2487       --  H_Length is not used because it is currently only ever set to 4, as
2488       --  H_Addrtype is always AF_INET.
2489
2490    begin
2491       Aliases_Count := 0;
2492       while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2493          Aliases_Count := Aliases_Count + 1;
2494       end loop;
2495
2496       Addresses_Count := 0;
2497       while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2498          Addresses_Count := Addresses_Count + 1;
2499       end loop;
2500
2501       return Result : Host_Entry_Type
2502                         (Aliases_Length   => Aliases_Count,
2503                          Addresses_Length => Addresses_Count)
2504       do
2505          Result.Official := To_Name (Value (Hostent_H_Name (E)));
2506
2507          for J in Result.Aliases'Range loop
2508             Result.Aliases (J) :=
2509               To_Name (Value (Hostent_H_Alias
2510                                 (E, C.int (J - Result.Aliases'First))));
2511          end loop;
2512
2513          for J in Result.Addresses'Range loop
2514             declare
2515                Addr : In_Addr;
2516
2517                --  Hostent_H_Addr (E, <index>) may return an address that is
2518                --  not correctly aligned for In_Addr, so we need to use
2519                --  an intermediate copy operation on a type with an alignemnt
2520                --  of 1 to recover the value.
2521
2522                subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8);
2523                Unaligned_Addr : Addr_Buf_T;
2524                for Unaligned_Addr'Address
2525                  use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2526                pragma Import (Ada, Unaligned_Addr);
2527
2528                Aligned_Addr : Addr_Buf_T;
2529                for Aligned_Addr'Address use Addr'Address;
2530                pragma Import (Ada, Aligned_Addr);
2531
2532             begin
2533                Aligned_Addr := Unaligned_Addr;
2534                To_Inet_Addr (Addr, Result.Addresses (J));
2535             end;
2536          end loop;
2537       end return;
2538    end To_Host_Entry;
2539
2540    ----------------
2541    -- To_In_Addr --
2542    ----------------
2543
2544    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2545    begin
2546       if Addr.Family = Family_Inet then
2547          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2548                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2549                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2550                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2551       end if;
2552
2553       raise Socket_Error with "IPv6 not supported";
2554    end To_In_Addr;
2555
2556    ------------------
2557    -- To_Inet_Addr --
2558    ------------------
2559
2560    procedure To_Inet_Addr
2561      (Addr   : In_Addr;
2562       Result : out Inet_Addr_Type) is
2563    begin
2564       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2565       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2566       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2567       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2568    end To_Inet_Addr;
2569
2570    ------------
2571    -- To_Int --
2572    ------------
2573
2574    function To_Int (F : Request_Flag_Type) return C.int
2575    is
2576       Current : Request_Flag_Type := F;
2577       Result  : C.int := 0;
2578
2579    begin
2580       for J in Flags'Range loop
2581          exit when Current = 0;
2582
2583          if Current mod 2 /= 0 then
2584             if Flags (J) = -1 then
2585                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2586             end if;
2587
2588             Result := Result + Flags (J);
2589          end if;
2590
2591          Current := Current / 2;
2592       end loop;
2593
2594       return Result;
2595    end To_Int;
2596
2597    -------------
2598    -- To_Name --
2599    -------------
2600
2601    function To_Name (N : String) return Name_Type is
2602    begin
2603       return Name_Type'(N'Length, N);
2604    end To_Name;
2605
2606    ----------------------
2607    -- To_Service_Entry --
2608    ----------------------
2609
2610    function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2611       use C.Strings;
2612       use type C.size_t;
2613
2614       Aliases_Count : Natural;
2615
2616    begin
2617       Aliases_Count := 0;
2618       while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2619          Aliases_Count := Aliases_Count + 1;
2620       end loop;
2621
2622       return Result : Service_Entry_Type (Aliases_Length   => Aliases_Count) do
2623          Result.Official := To_Name (Value (Servent_S_Name (E)));
2624
2625          for J in Result.Aliases'Range loop
2626             Result.Aliases (J) :=
2627               To_Name (Value (Servent_S_Alias
2628                                 (E, C.int (J - Result.Aliases'First))));
2629          end loop;
2630
2631          Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2632          Result.Port :=
2633            Port_Type (Network_To_Short (Servent_S_Port (E)));
2634       end return;
2635    end To_Service_Entry;
2636
2637    ---------------
2638    -- To_String --
2639    ---------------
2640
2641    function To_String (HN : Name_Type) return String is
2642    begin
2643       return HN.Name (1 .. HN.Length);
2644    end To_String;
2645
2646    ----------------
2647    -- To_Timeval --
2648    ----------------
2649
2650    function To_Timeval (Val : Timeval_Duration) return Timeval is
2651       S  : time_t;
2652       uS : suseconds_t;
2653
2654    begin
2655       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2656
2657       if Val = 0.0 then
2658          S  := 0;
2659          uS := 0;
2660
2661       --  Normal case where we do round down
2662
2663       else
2664          S  := time_t (Val - 0.5);
2665          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2666       end if;
2667
2668       return (S, uS);
2669    end To_Timeval;
2670
2671    -----------
2672    -- Value --
2673    -----------
2674
2675    function Value (S : System.Address) return String is
2676       Str : String (1 .. Positive'Last);
2677       for Str'Address use S;
2678       pragma Import (Ada, Str);
2679
2680       Terminator : Positive := Str'First;
2681
2682    begin
2683       while Str (Terminator) /= ASCII.NUL loop
2684          Terminator := Terminator + 1;
2685       end loop;
2686
2687       return Str (1 .. Terminator - 1);
2688    end Value;
2689
2690    -----------
2691    -- Write --
2692    -----------
2693
2694    procedure Write
2695      (Stream : in out Datagram_Socket_Stream_Type;
2696       Item   : Ada.Streams.Stream_Element_Array)
2697    is
2698    begin
2699       Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2700    end Write;
2701
2702    -----------
2703    -- Write --
2704    -----------
2705
2706    procedure Write
2707      (Stream : in out Stream_Socket_Stream_Type;
2708       Item   : Ada.Streams.Stream_Element_Array)
2709    is
2710    begin
2711       Stream_Write (Stream.Socket, Item, To => null);
2712    end Write;
2713
2714    Sockets_Library_Controller_Object : Sockets_Library_Controller;
2715    pragma Unreferenced (Sockets_Library_Controller_Object);
2716    --  The elaboration and finalization of this object perform the required
2717    --  initialization and cleanup actions for the sockets library.
2718
2719 end GNAT.Sockets;