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