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