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-2014, 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 IP address in standard dot 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 (on VMS,
 176    --  chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
 177
 178    function To_Timeval (Val : Timeval_Duration) return Timeval;
 179    --  Separate Val in seconds and microseconds
 180
 181    function To_Duration (Val : Timeval) return Timeval_Duration;
 182    --  Reconstruct a Duration value from a Timeval record (seconds and
 183    --  microseconds).
 184
 185    procedure Raise_Socket_Error (Error : Integer);
 186    --  Raise Socket_Error with an exception message describing the error code
 187    --  from errno.
 188
 189    procedure Raise_Host_Error (H_Error : Integer);
 190    --  Raise Host_Error exception with message describing error code (note
 191    --  hstrerror seems to be obsolete) from h_errno.
 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 behaviour 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));
 978       end if;
 979
 980       return H : constant Host_Entry_Type :=
 981                    To_Host_Entry (Res'Unchecked_Access)
 982       do
 983          Netdb_Unlock;
 984       end return;
 985    end Get_Host_By_Address;
 986
 987    ----------------------
 988    -- Get_Host_By_Name --
 989    ----------------------
 990
 991    function Get_Host_By_Name (Name : String) return Host_Entry_Type is
 992    begin
 993       --  Detect IP address name and redirect to Inet_Addr
 994
 995       if Is_IP_Address (Name) then
 996          return Get_Host_By_Address (Inet_Addr (Name));
 997       end if;
 998
 999       declare
1000          HN     : constant C.char_array := C.To_C (Name);
1001          Buflen : constant C.int := Netdb_Buffer_Size;
1002          Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1003          Res    : aliased Hostent;
1004          Err    : aliased C.int;
1005
1006       begin
1007          Netdb_Lock;
1008
1009          if C_Gethostbyname
1010            (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1011          then
1012             Netdb_Unlock;
1013             Raise_Host_Error (Integer (Err));
1014          end if;
1015
1016          return H : constant Host_Entry_Type :=
1017                       To_Host_Entry (Res'Unchecked_Access)
1018          do
1019             Netdb_Unlock;
1020          end return;
1021       end;
1022    end Get_Host_By_Name;
1023
1024    -------------------
1025    -- Get_Peer_Name --
1026    -------------------
1027
1028    function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
1029       Sin : aliased Sockaddr_In;
1030       Len : aliased C.int := Sin'Size / 8;
1031       Res : Sock_Addr_Type (Family_Inet);
1032
1033    begin
1034       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
1035          Raise_Socket_Error (Socket_Errno);
1036       end if;
1037
1038       To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
1039       Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1040
1041       return Res;
1042    end Get_Peer_Name;
1043
1044    -------------------------
1045    -- Get_Service_By_Name --
1046    -------------------------
1047
1048    function Get_Service_By_Name
1049      (Name     : String;
1050       Protocol : String) return Service_Entry_Type
1051    is
1052       SN     : constant C.char_array := C.To_C (Name);
1053       SP     : constant C.char_array := C.To_C (Protocol);
1054       Buflen : constant C.int := Netdb_Buffer_Size;
1055       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1056       Res    : aliased Servent;
1057
1058    begin
1059       Netdb_Lock;
1060
1061       if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1062          Netdb_Unlock;
1063          raise Service_Error with "Service not found";
1064       end if;
1065
1066       --  Translate from the C format to the API format
1067
1068       return S : constant Service_Entry_Type :=
1069                    To_Service_Entry (Res'Unchecked_Access)
1070       do
1071          Netdb_Unlock;
1072       end return;
1073    end Get_Service_By_Name;
1074
1075    -------------------------
1076    -- Get_Service_By_Port --
1077    -------------------------
1078
1079    function Get_Service_By_Port
1080      (Port     : Port_Type;
1081       Protocol : String) return Service_Entry_Type
1082    is
1083       SP     : constant C.char_array := C.To_C (Protocol);
1084       Buflen : constant C.int := Netdb_Buffer_Size;
1085       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1086       Res    : aliased Servent;
1087
1088    begin
1089       Netdb_Lock;
1090
1091       if C_Getservbyport
1092         (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1093          Res'Access, Buf'Address, Buflen) /= 0
1094       then
1095          Netdb_Unlock;
1096          raise Service_Error with "Service not found";
1097       end if;
1098
1099       --  Translate from the C format to the API format
1100
1101       return S : constant Service_Entry_Type :=
1102                    To_Service_Entry (Res'Unchecked_Access)
1103       do
1104          Netdb_Unlock;
1105       end return;
1106    end Get_Service_By_Port;
1107
1108    ---------------------
1109    -- Get_Socket_Name --
1110    ---------------------
1111
1112    function Get_Socket_Name
1113      (Socket : Socket_Type) return Sock_Addr_Type
1114    is
1115       Sin  : aliased Sockaddr_In;
1116       Len  : aliased C.int := Sin'Size / 8;
1117       Res  : C.int;
1118       Addr : Sock_Addr_Type := No_Sock_Addr;
1119
1120    begin
1121       Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1122
1123       if Res /= Failure then
1124          To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
1125          Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1126       end if;
1127
1128       return Addr;
1129    end Get_Socket_Name;
1130
1131    -----------------------
1132    -- Get_Socket_Option --
1133    -----------------------
1134
1135    function Get_Socket_Option
1136      (Socket : Socket_Type;
1137       Level  : Level_Type := Socket_Level;
1138       Name   : Option_Name) return Option_Type
1139    is
1140       use SOSC;
1141       use type C.unsigned_char;
1142
1143       V8  : aliased Two_Ints;
1144       V4  : aliased C.int;
1145       V1  : aliased C.unsigned_char;
1146       VT  : aliased Timeval;
1147       Len : aliased C.int;
1148       Add : System.Address;
1149       Res : C.int;
1150       Opt : Option_Type (Name);
1151
1152    begin
1153       case Name is
1154          when Multicast_Loop      |
1155               Multicast_TTL       |
1156               Receive_Packet_Info =>
1157             Len := V1'Size / 8;
1158             Add := V1'Address;
1159
1160          when Keep_Alive      |
1161               Reuse_Address   |
1162               Broadcast       |
1163               No_Delay        |
1164               Send_Buffer     |
1165               Receive_Buffer  |
1166               Multicast_If    |
1167               Error           =>
1168             Len := V4'Size / 8;
1169             Add := V4'Address;
1170
1171          when Send_Timeout    |
1172               Receive_Timeout =>
1173
1174             --  The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1175             --  struct timeval, but on Windows it is a milliseconds count in
1176             --  a DWORD.
1177
1178             if Target_OS = Windows then
1179                Len := V4'Size / 8;
1180                Add := V4'Address;
1181
1182             else
1183                Len := VT'Size / 8;
1184                Add := VT'Address;
1185             end if;
1186
1187          when Linger          |
1188               Add_Membership  |
1189               Drop_Membership =>
1190             Len := V8'Size / 8;
1191             Add := V8'Address;
1192
1193       end case;
1194
1195       Res :=
1196         C_Getsockopt
1197           (C.int (Socket),
1198            Levels (Level),
1199            Options (Name),
1200            Add, Len'Access);
1201
1202       if Res = Failure then
1203          Raise_Socket_Error (Socket_Errno);
1204       end if;
1205
1206       case Name is
1207          when Keep_Alive      |
1208               Reuse_Address   |
1209               Broadcast       |
1210               No_Delay        =>
1211             Opt.Enabled := (V4 /= 0);
1212
1213          when Linger          =>
1214             Opt.Enabled := (V8 (V8'First) /= 0);
1215             Opt.Seconds := Natural (V8 (V8'Last));
1216
1217          when Send_Buffer     |
1218               Receive_Buffer  =>
1219             Opt.Size := Natural (V4);
1220
1221          when Error           =>
1222             Opt.Error := Resolve_Error (Integer (V4));
1223
1224          when Add_Membership  |
1225               Drop_Membership =>
1226             To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1227             To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1228
1229          when Multicast_If    =>
1230             To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1231
1232          when Multicast_TTL   =>
1233             Opt.Time_To_Live := Integer (V1);
1234
1235          when Multicast_Loop      |
1236               Receive_Packet_Info =>
1237             Opt.Enabled := (V1 /= 0);
1238
1239          when Send_Timeout    |
1240               Receive_Timeout =>
1241
1242             if Target_OS = Windows then
1243
1244                --  Timeout is in milliseconds, actual value is 500 ms +
1245                --  returned value (unless it is 0).
1246
1247                if V4 = 0 then
1248                   Opt.Timeout := 0.0;
1249                else
1250                   Opt.Timeout := Natural (V4) * 0.001 + 0.500;
1251                end if;
1252
1253             else
1254                Opt.Timeout := To_Duration (VT);
1255             end if;
1256       end case;
1257
1258       return Opt;
1259    end Get_Socket_Option;
1260
1261    ---------------
1262    -- Host_Name --
1263    ---------------
1264
1265    function Host_Name return String is
1266       Name : aliased C.char_array (1 .. 64);
1267       Res  : C.int;
1268
1269    begin
1270       Res := C_Gethostname (Name'Address, Name'Length);
1271
1272       if Res = Failure then
1273          Raise_Socket_Error (Socket_Errno);
1274       end if;
1275
1276       return C.To_Ada (Name);
1277    end Host_Name;
1278
1279    -----------
1280    -- Image --
1281    -----------
1282
1283    function Image
1284      (Val : Inet_Addr_VN_Type;
1285       Hex : Boolean := False) return String
1286    is
1287       --  The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1288       --  has at most a length of 3 plus one '.' character.
1289
1290       Buffer    : String (1 .. 4 * Val'Length);
1291       Length    : Natural := 1;
1292       Separator : Character;
1293
1294       procedure Img10 (V : Inet_Addr_Comp_Type);
1295       --  Append to Buffer image of V in decimal format
1296
1297       procedure Img16 (V : Inet_Addr_Comp_Type);
1298       --  Append to Buffer image of V in hexadecimal format
1299
1300       -----------
1301       -- Img10 --
1302       -----------
1303
1304       procedure Img10 (V : Inet_Addr_Comp_Type) is
1305          Img : constant String := V'Img;
1306          Len : constant Natural := Img'Length - 1;
1307       begin
1308          Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1309          Length := Length + Len;
1310       end Img10;
1311
1312       -----------
1313       -- Img16 --
1314       -----------
1315
1316       procedure Img16 (V : Inet_Addr_Comp_Type) is
1317       begin
1318          Buffer (Length)     := Hex_To_Char (Natural (V / 16) + 1);
1319          Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1320          Length := Length + 2;
1321       end Img16;
1322
1323    --  Start of processing for Image
1324
1325    begin
1326       Separator := (if Hex then ':' else '.');
1327
1328       for J in Val'Range loop
1329          if Hex then
1330             Img16 (Val (J));
1331          else
1332             Img10 (Val (J));
1333          end if;
1334
1335          if J /= Val'Last then
1336             Buffer (Length) := Separator;
1337             Length := Length + 1;
1338          end if;
1339       end loop;
1340
1341       return Buffer (1 .. Length - 1);
1342    end Image;
1343
1344    -----------
1345    -- Image --
1346    -----------
1347
1348    function Image (Value : Inet_Addr_Type) return String is
1349    begin
1350       if Value.Family = Family_Inet then
1351          return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1352       else
1353          return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1354       end if;
1355    end Image;
1356
1357    -----------
1358    -- Image --
1359    -----------
1360
1361    function Image (Value : Sock_Addr_Type) return String is
1362       Port : constant String := Value.Port'Img;
1363    begin
1364       return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1365    end Image;
1366
1367    -----------
1368    -- Image --
1369    -----------
1370
1371    function Image (Socket : Socket_Type) return String is
1372    begin
1373       return Socket'Img;
1374    end Image;
1375
1376    -----------
1377    -- Image --
1378    -----------
1379
1380    function Image (Item : Socket_Set_Type) return String is
1381       Socket_Set : Socket_Set_Type := Item;
1382
1383    begin
1384       declare
1385          Last_Img : constant String := Socket_Set.Last'Img;
1386          Buffer   : String
1387                       (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1388          Index    : Positive := 1;
1389          Socket   : Socket_Type;
1390
1391       begin
1392          while not Is_Empty (Socket_Set) loop
1393             Get (Socket_Set, Socket);
1394
1395             declare
1396                Socket_Img : constant String := Socket'Img;
1397             begin
1398                Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1399                Index := Index + Socket_Img'Length;
1400             end;
1401          end loop;
1402
1403          return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1404       end;
1405    end Image;
1406
1407    ---------------
1408    -- Inet_Addr --
1409    ---------------
1410
1411    function Inet_Addr (Image : String) return Inet_Addr_Type is
1412       use Interfaces.C;
1413
1414       Img    : aliased char_array := To_C (Image);
1415       Addr   : aliased C.int;
1416       Res    : C.int;
1417       Result : Inet_Addr_Type;
1418
1419    begin
1420       --  Special case for an empty Image as on some platforms (e.g. Windows)
1421       --  calling Inet_Addr("") will not return an error.
1422
1423       if Image = "" then
1424          Raise_Socket_Error (SOSC.EINVAL);
1425       end if;
1426
1427       Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address);
1428
1429       if Res < 0 then
1430          Raise_Socket_Error (Socket_Errno);
1431
1432       elsif Res = 0 then
1433          Raise_Socket_Error (SOSC.EINVAL);
1434       end if;
1435
1436       To_Inet_Addr (To_In_Addr (Addr), Result);
1437       return Result;
1438    end Inet_Addr;
1439
1440    ----------------
1441    -- Initialize --
1442    ----------------
1443
1444    procedure Initialize (X : in out Sockets_Library_Controller) is
1445       pragma Unreferenced (X);
1446
1447    begin
1448       Thin.Initialize;
1449    end Initialize;
1450
1451    ----------------
1452    -- Initialize --
1453    ----------------
1454
1455    procedure Initialize (Process_Blocking_IO : Boolean) is
1456       Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1457
1458    begin
1459       if Process_Blocking_IO /= Expected then
1460          raise Socket_Error with
1461            "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1462       end if;
1463
1464       --  This is a dummy placeholder for an obsolete API
1465
1466       --  Real initialization actions are in Initialize primitive operation
1467       --  of Sockets_Library_Controller.
1468
1469       null;
1470    end Initialize;
1471
1472    ----------------
1473    -- Initialize --
1474    ----------------
1475
1476    procedure Initialize is
1477    begin
1478       --  This is a dummy placeholder for an obsolete API
1479
1480       --  Real initialization actions are in Initialize primitive operation
1481       --  of Sockets_Library_Controller.
1482
1483       null;
1484    end Initialize;
1485
1486    --------------
1487    -- Is_Empty --
1488    --------------
1489
1490    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1491    begin
1492       return Item.Last = No_Socket;
1493    end Is_Empty;
1494
1495    -------------------
1496    -- Is_IP_Address --
1497    -------------------
1498
1499    function Is_IP_Address (Name : String) return Boolean is
1500    begin
1501       for J in Name'Range loop
1502          if Name (J) /= '.'
1503            and then Name (J) not in '0' .. '9'
1504          then
1505             return False;
1506          end if;
1507       end loop;
1508
1509       return True;
1510    end Is_IP_Address;
1511
1512    -------------
1513    -- Is_Open --
1514    -------------
1515
1516    function Is_Open (S : Selector_Type) return Boolean is
1517    begin
1518       if S.Is_Null then
1519          return True;
1520
1521       else
1522          --  Either both controlling socket descriptors are valid (case of an
1523          --  open selector) or neither (case of a closed selector).
1524
1525          pragma Assert ((S.R_Sig_Socket /= No_Socket)
1526                           =
1527                         (S.W_Sig_Socket /= No_Socket));
1528
1529          return S.R_Sig_Socket /= No_Socket;
1530       end if;
1531    end Is_Open;
1532
1533    ------------
1534    -- Is_Set --
1535    ------------
1536
1537    function Is_Set
1538      (Item   : Socket_Set_Type;
1539       Socket : Socket_Type) return Boolean
1540    is
1541    begin
1542       Check_For_Fd_Set (Socket);
1543
1544       return Item.Last /= No_Socket
1545         and then Socket <= Item.Last
1546         and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1547    end Is_Set;
1548
1549    -------------------
1550    -- Listen_Socket --
1551    -------------------
1552
1553    procedure Listen_Socket
1554      (Socket : Socket_Type;
1555       Length : Natural := 15)
1556    is
1557       Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1558    begin
1559       if Res = Failure then
1560          Raise_Socket_Error (Socket_Errno);
1561       end if;
1562    end Listen_Socket;
1563
1564    ------------
1565    -- Narrow --
1566    ------------
1567
1568    procedure Narrow (Item : in out Socket_Set_Type) is
1569       Last : aliased C.int := C.int (Item.Last);
1570    begin
1571       if Item.Last /= No_Socket then
1572          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1573          Item.Last := Socket_Type (Last);
1574       end if;
1575    end Narrow;
1576
1577    ----------------
1578    -- Netdb_Lock --
1579    ----------------
1580
1581    procedure Netdb_Lock is
1582    begin
1583       if Need_Netdb_Lock then
1584          System.Task_Lock.Lock;
1585       end if;
1586    end Netdb_Lock;
1587
1588    ------------------
1589    -- Netdb_Unlock --
1590    ------------------
1591
1592    procedure Netdb_Unlock is
1593    begin
1594       if Need_Netdb_Lock then
1595          System.Task_Lock.Unlock;
1596       end if;
1597    end Netdb_Unlock;
1598
1599    --------------------------------
1600    -- Normalize_Empty_Socket_Set --
1601    --------------------------------
1602
1603    procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1604    begin
1605       if S.Last = No_Socket then
1606          Reset_Socket_Set (S.Set'Access);
1607       end if;
1608    end Normalize_Empty_Socket_Set;
1609
1610    -------------------
1611    -- Official_Name --
1612    -------------------
1613
1614    function Official_Name (E : Host_Entry_Type) return String is
1615    begin
1616       return To_String (E.Official);
1617    end Official_Name;
1618
1619    -------------------
1620    -- Official_Name --
1621    -------------------
1622
1623    function Official_Name (S : Service_Entry_Type) return String is
1624    begin
1625       return To_String (S.Official);
1626    end Official_Name;
1627
1628    --------------------
1629    -- Wait_On_Socket --
1630    --------------------
1631
1632    procedure Wait_On_Socket
1633      (Socket   : Socket_Type;
1634       For_Read : Boolean;
1635       Timeout  : Selector_Duration;
1636       Selector : access Selector_Type := null;
1637       Status   : out Selector_Status)
1638    is
1639       type Local_Selector_Access is access Selector_Type;
1640       for Local_Selector_Access'Storage_Size use Selector_Type'Size;
1641
1642       S : Selector_Access;
1643       --  Selector to use for waiting
1644
1645       R_Fd_Set : Socket_Set_Type;
1646       W_Fd_Set : Socket_Set_Type;
1647
1648    begin
1649       --  Create selector if not provided by the user
1650
1651       if Selector = null then
1652          declare
1653             Local_S : constant Local_Selector_Access := new Selector_Type;
1654          begin
1655             S := Local_S.all'Unchecked_Access;
1656             Create_Selector (S.all);
1657          end;
1658
1659       else
1660          S := Selector.all'Access;
1661       end if;
1662
1663       if For_Read then
1664          Set (R_Fd_Set, Socket);
1665       else
1666          Set (W_Fd_Set, Socket);
1667       end if;
1668
1669       Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
1670
1671       if Selector = null then
1672          Close_Selector (S.all);
1673       end if;
1674    end Wait_On_Socket;
1675
1676    -----------------
1677    -- Port_Number --
1678    -----------------
1679
1680    function Port_Number (S : Service_Entry_Type) return Port_Type is
1681    begin
1682       return S.Port;
1683    end Port_Number;
1684
1685    -------------------
1686    -- Protocol_Name --
1687    -------------------
1688
1689    function Protocol_Name (S : Service_Entry_Type) return String is
1690    begin
1691       return To_String (S.Protocol);
1692    end Protocol_Name;
1693
1694    ----------------------
1695    -- Raise_Host_Error --
1696    ----------------------
1697
1698    procedure Raise_Host_Error (H_Error : Integer) is
1699    begin
1700       raise Host_Error with
1701         Err_Code_Image (H_Error)
1702           & Host_Error_Messages.Host_Error_Message (H_Error);
1703    end Raise_Host_Error;
1704
1705    ------------------------
1706    -- Raise_Socket_Error --
1707    ------------------------
1708
1709    procedure Raise_Socket_Error (Error : Integer) is
1710    begin
1711       raise Socket_Error with
1712         Err_Code_Image (Error) & Socket_Error_Message (Error);
1713    end Raise_Socket_Error;
1714
1715    ----------
1716    -- Read --
1717    ----------
1718
1719    procedure Read
1720      (Stream : in out Datagram_Socket_Stream_Type;
1721       Item   : out Ada.Streams.Stream_Element_Array;
1722       Last   : out Ada.Streams.Stream_Element_Offset)
1723    is
1724    begin
1725       Receive_Socket
1726         (Stream.Socket,
1727          Item,
1728          Last,
1729          Stream.From);
1730    end Read;
1731
1732    ----------
1733    -- Read --
1734    ----------
1735
1736    procedure Read
1737      (Stream : in out Stream_Socket_Stream_Type;
1738       Item   : out Ada.Streams.Stream_Element_Array;
1739       Last   : out Ada.Streams.Stream_Element_Offset)
1740    is
1741       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1742       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1743       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1744
1745    begin
1746       loop
1747          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1748          Last  := Index;
1749
1750          --  Exit when all or zero data received. Zero means that the socket
1751          --  peer is closed.
1752
1753          exit when Index < First or else Index = Max;
1754
1755          First := Index + 1;
1756       end loop;
1757    end Read;
1758
1759    --------------------
1760    -- Receive_Socket --
1761    --------------------
1762
1763    procedure Receive_Socket
1764      (Socket : Socket_Type;
1765       Item   : out Ada.Streams.Stream_Element_Array;
1766       Last   : out Ada.Streams.Stream_Element_Offset;
1767       Flags  : Request_Flag_Type := No_Request_Flag)
1768    is
1769       Res : C.int;
1770
1771    begin
1772       Res :=
1773         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1774
1775       if Res = Failure then
1776          Raise_Socket_Error (Socket_Errno);
1777       end if;
1778
1779       Last := Last_Index (First => Item'First, Count => size_t (Res));
1780    end Receive_Socket;
1781
1782    --------------------
1783    -- Receive_Socket --
1784    --------------------
1785
1786    procedure Receive_Socket
1787      (Socket : Socket_Type;
1788       Item   : out Ada.Streams.Stream_Element_Array;
1789       Last   : out Ada.Streams.Stream_Element_Offset;
1790       From   : out Sock_Addr_Type;
1791       Flags  : Request_Flag_Type := No_Request_Flag)
1792    is
1793       Res : C.int;
1794       Sin : aliased Sockaddr_In;
1795       Len : aliased C.int := Sin'Size / 8;
1796
1797    begin
1798       Res :=
1799         C_Recvfrom
1800           (C.int (Socket),
1801            Item'Address,
1802            Item'Length,
1803            To_Int (Flags),
1804            Sin'Address,
1805            Len'Access);
1806
1807       if Res = Failure then
1808          Raise_Socket_Error (Socket_Errno);
1809       end if;
1810
1811       Last := Last_Index (First => Item'First, Count => size_t (Res));
1812
1813       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1814       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1815    end Receive_Socket;
1816
1817    --------------------
1818    -- Receive_Vector --
1819    --------------------
1820
1821    procedure Receive_Vector
1822      (Socket : Socket_Type;
1823       Vector : Vector_Type;
1824       Count  : out Ada.Streams.Stream_Element_Count;
1825       Flags  : Request_Flag_Type := No_Request_Flag)
1826    is
1827       Res : ssize_t;
1828
1829       Msg : Msghdr :=
1830               (Msg_Name       => System.Null_Address,
1831                Msg_Namelen    => 0,
1832                Msg_Iov        => Vector'Address,
1833
1834                --  recvmsg(2) returns EMSGSIZE on Linux (and probably on other
1835                --  platforms) when the supplied vector is longer than IOV_MAX,
1836                --  so use minimum of the two lengths.
1837
1838                Msg_Iovlen     => SOSC.Msg_Iovlen_T'Min
1839                                    (Vector'Length, SOSC.IOV_MAX),
1840
1841                Msg_Control    => System.Null_Address,
1842                Msg_Controllen => 0,
1843                Msg_Flags      => 0);
1844
1845    begin
1846       Res :=
1847         C_Recvmsg
1848           (C.int (Socket),
1849            Msg'Address,
1850            To_Int (Flags));
1851
1852       if Res = ssize_t (Failure) then
1853          Raise_Socket_Error (Socket_Errno);
1854       end if;
1855
1856       Count := Ada.Streams.Stream_Element_Count (Res);
1857    end Receive_Vector;
1858
1859    -------------------
1860    -- Resolve_Error --
1861    -------------------
1862
1863    function Resolve_Error
1864      (Error_Value : Integer;
1865       From_Errno  : Boolean := True) return Error_Type
1866    is
1867       use GNAT.Sockets.SOSC;
1868
1869    begin
1870       if not From_Errno then
1871          case Error_Value is
1872             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1873             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1874             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
1875             when SOSC.NO_DATA        => return Unknown_Server_Error;
1876             when others              => return Cannot_Resolve_Error;
1877          end case;
1878       end if;
1879
1880       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1881       --  can't include it in the case statement below.
1882
1883       pragma Warnings (Off);
1884       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1885
1886       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1887          return Resource_Temporarily_Unavailable;
1888       end if;
1889
1890       --  This is not a case statement because if a particular error
1891       --  number constant is not defined, s-oscons-tmplt.c defines
1892       --  it to -1.  If multiple constants are not defined, they
1893       --  would each be -1 and result in a "duplicate value in case" error.
1894       --
1895       --  But we have to leave warnings off because the compiler is also
1896       --  smart enough to note that when two errnos have the same value,
1897       --  the second if condition is useless.
1898       if Error_Value = ENOERROR then
1899          return Success;
1900       elsif Error_Value = EACCES then
1901          return Permission_Denied;
1902       elsif Error_Value = EADDRINUSE then
1903          return Address_Already_In_Use;
1904       elsif Error_Value = EADDRNOTAVAIL then
1905          return Cannot_Assign_Requested_Address;
1906       elsif Error_Value = EAFNOSUPPORT then
1907          return Address_Family_Not_Supported_By_Protocol;
1908       elsif Error_Value = EALREADY then
1909          return Operation_Already_In_Progress;
1910       elsif Error_Value = EBADF then
1911          return Bad_File_Descriptor;
1912       elsif Error_Value = ECONNABORTED then
1913          return Software_Caused_Connection_Abort;
1914       elsif Error_Value = ECONNREFUSED then
1915          return Connection_Refused;
1916       elsif Error_Value = ECONNRESET then
1917          return Connection_Reset_By_Peer;
1918       elsif Error_Value = EDESTADDRREQ then
1919          return Destination_Address_Required;
1920       elsif Error_Value = EFAULT then
1921          return Bad_Address;
1922       elsif Error_Value = EHOSTDOWN then
1923          return Host_Is_Down;
1924       elsif Error_Value = EHOSTUNREACH then
1925          return No_Route_To_Host;
1926       elsif Error_Value = EINPROGRESS then
1927          return Operation_Now_In_Progress;
1928       elsif Error_Value = EINTR then
1929          return Interrupted_System_Call;
1930       elsif Error_Value = EINVAL then
1931          return Invalid_Argument;
1932       elsif Error_Value = EIO then
1933          return Input_Output_Error;
1934       elsif Error_Value = EISCONN then
1935          return Transport_Endpoint_Already_Connected;
1936       elsif Error_Value = ELOOP then
1937          return Too_Many_Symbolic_Links;
1938       elsif Error_Value = EMFILE then
1939          return Too_Many_Open_Files;
1940       elsif Error_Value = EMSGSIZE then
1941          return Message_Too_Long;
1942       elsif Error_Value = ENAMETOOLONG then
1943          return File_Name_Too_Long;
1944       elsif Error_Value = ENETDOWN then
1945          return Network_Is_Down;
1946       elsif Error_Value = ENETRESET then
1947          return Network_Dropped_Connection_Because_Of_Reset;
1948       elsif Error_Value = ENETUNREACH then
1949          return Network_Is_Unreachable;
1950       elsif Error_Value = ENOBUFS then
1951          return No_Buffer_Space_Available;
1952       elsif Error_Value = ENOPROTOOPT then
1953          return Protocol_Not_Available;
1954       elsif Error_Value = ENOTCONN then
1955          return Transport_Endpoint_Not_Connected;
1956       elsif Error_Value = ENOTSOCK then
1957          return Socket_Operation_On_Non_Socket;
1958       elsif Error_Value = EOPNOTSUPP then
1959          return Operation_Not_Supported;
1960       elsif Error_Value = EPFNOSUPPORT then
1961          return Protocol_Family_Not_Supported;
1962       elsif Error_Value = EPIPE then
1963          return Broken_Pipe;
1964       elsif Error_Value = EPROTONOSUPPORT then
1965          return Protocol_Not_Supported;
1966       elsif Error_Value = EPROTOTYPE then
1967          return Protocol_Wrong_Type_For_Socket;
1968       elsif Error_Value = ESHUTDOWN then
1969          return Cannot_Send_After_Transport_Endpoint_Shutdown;
1970       elsif Error_Value = ESOCKTNOSUPPORT then
1971          return Socket_Type_Not_Supported;
1972       elsif Error_Value = ETIMEDOUT then
1973          return Connection_Timed_Out;
1974       elsif Error_Value = ETOOMANYREFS then
1975          return Too_Many_References;
1976       elsif Error_Value = EWOULDBLOCK then
1977          return Resource_Temporarily_Unavailable;
1978       else
1979          return Cannot_Resolve_Error;
1980       end if;
1981       pragma Warnings (On);
1982
1983    end Resolve_Error;
1984
1985    -----------------------
1986    -- Resolve_Exception --
1987    -----------------------
1988
1989    function Resolve_Exception
1990      (Occurrence : Exception_Occurrence) return Error_Type
1991    is
1992       Id    : constant Exception_Id := Exception_Identity (Occurrence);
1993       Msg   : constant String       := Exception_Message (Occurrence);
1994       First : Natural;
1995       Last  : Natural;
1996       Val   : Integer;
1997
1998    begin
1999       First := Msg'First;
2000       while First <= Msg'Last
2001         and then Msg (First) not in '0' .. '9'
2002       loop
2003          First := First + 1;
2004       end loop;
2005
2006       if First > Msg'Last then
2007          return Cannot_Resolve_Error;
2008       end if;
2009
2010       Last := First;
2011       while Last < Msg'Last
2012         and then Msg (Last + 1) in '0' .. '9'
2013       loop
2014          Last := Last + 1;
2015       end loop;
2016
2017       Val := Integer'Value (Msg (First .. Last));
2018
2019       if Id = Socket_Error_Id then
2020          return Resolve_Error (Val);
2021
2022       elsif Id = Host_Error_Id then
2023          return Resolve_Error (Val, False);
2024
2025       else
2026          return Cannot_Resolve_Error;
2027       end if;
2028    end Resolve_Exception;
2029
2030    -----------------
2031    -- Send_Socket --
2032    -----------------
2033
2034    procedure Send_Socket
2035      (Socket : Socket_Type;
2036       Item   : Ada.Streams.Stream_Element_Array;
2037       Last   : out Ada.Streams.Stream_Element_Offset;
2038       Flags  : Request_Flag_Type := No_Request_Flag)
2039    is
2040    begin
2041       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2042    end Send_Socket;
2043
2044    -----------------
2045    -- Send_Socket --
2046    -----------------
2047
2048    procedure Send_Socket
2049      (Socket : Socket_Type;
2050       Item   : Ada.Streams.Stream_Element_Array;
2051       Last   : out Ada.Streams.Stream_Element_Offset;
2052       To     : Sock_Addr_Type;
2053       Flags  : Request_Flag_Type := No_Request_Flag)
2054    is
2055    begin
2056       Send_Socket
2057         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2058    end Send_Socket;
2059
2060    -----------------
2061    -- Send_Socket --
2062    -----------------
2063
2064    procedure Send_Socket
2065      (Socket : Socket_Type;
2066       Item   : Ada.Streams.Stream_Element_Array;
2067       Last   : out Ada.Streams.Stream_Element_Offset;
2068       To     : access Sock_Addr_Type;
2069       Flags  : Request_Flag_Type := No_Request_Flag)
2070    is
2071       Res  : C.int;
2072
2073       Sin  : aliased Sockaddr_In;
2074       C_To : System.Address;
2075       Len  : C.int;
2076
2077    begin
2078       if To /= null then
2079          Set_Family  (Sin.Sin_Family, To.Family);
2080          Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
2081          Set_Port
2082            (Sin'Unchecked_Access,
2083             Short_To_Network (C.unsigned_short (To.Port)));
2084          C_To := Sin'Address;
2085          Len := Sin'Size / 8;
2086
2087       else
2088          C_To := System.Null_Address;
2089          Len := 0;
2090       end if;
2091
2092       Res := C_Sendto
2093         (C.int (Socket),
2094          Item'Address,
2095          Item'Length,
2096          Set_Forced_Flags (To_Int (Flags)),
2097          C_To,
2098          Len);
2099
2100       if Res = Failure then
2101          Raise_Socket_Error (Socket_Errno);
2102       end if;
2103
2104       Last := Last_Index (First => Item'First, Count => size_t (Res));
2105    end Send_Socket;
2106
2107    -----------------
2108    -- Send_Vector --
2109    -----------------
2110
2111    procedure Send_Vector
2112      (Socket : Socket_Type;
2113       Vector : Vector_Type;
2114       Count  : out Ada.Streams.Stream_Element_Count;
2115       Flags  : Request_Flag_Type := No_Request_Flag)
2116    is
2117       use SOSC;
2118       use Interfaces.C;
2119
2120       Res            : ssize_t;
2121       Iov_Count      : SOSC.Msg_Iovlen_T;
2122       This_Iov_Count : SOSC.Msg_Iovlen_T;
2123       Msg            : Msghdr;
2124
2125    begin
2126       Count := 0;
2127       Iov_Count := 0;
2128       while Iov_Count < Vector'Length loop
2129
2130          pragma Warnings (Off);
2131          --  Following test may be compile time known on some targets
2132
2133          This_Iov_Count :=
2134            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2135             then SOSC.IOV_MAX
2136             else Vector'Length - Iov_Count);
2137
2138          pragma Warnings (On);
2139
2140          Msg :=
2141            (Msg_Name       => System.Null_Address,
2142             Msg_Namelen    => 0,
2143             Msg_Iov        => Vector
2144                                 (Vector'First + Integer (Iov_Count))'Address,
2145             Msg_Iovlen     => This_Iov_Count,
2146             Msg_Control    => System.Null_Address,
2147             Msg_Controllen => 0,
2148             Msg_Flags      => 0);
2149
2150          Res :=
2151            C_Sendmsg
2152              (C.int (Socket),
2153               Msg'Address,
2154               Set_Forced_Flags (To_Int (Flags)));
2155
2156          if Res = ssize_t (Failure) then
2157             Raise_Socket_Error (Socket_Errno);
2158          end if;
2159
2160          Count := Count + Ada.Streams.Stream_Element_Count (Res);
2161          Iov_Count := Iov_Count + This_Iov_Count;
2162       end loop;
2163    end Send_Vector;
2164
2165    ---------
2166    -- Set --
2167    ---------
2168
2169    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2170    begin
2171       Check_For_Fd_Set (Socket);
2172
2173       if Item.Last = No_Socket then
2174
2175          --  Uninitialized socket set, make sure it is properly zeroed out
2176
2177          Reset_Socket_Set (Item.Set'Access);
2178          Item.Last := Socket;
2179
2180       elsif Item.Last < Socket then
2181          Item.Last := Socket;
2182       end if;
2183
2184       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2185    end Set;
2186
2187    -----------------------
2188    -- Set_Close_On_Exec --
2189    -----------------------
2190
2191    procedure Set_Close_On_Exec
2192      (Socket        : Socket_Type;
2193       Close_On_Exec : Boolean;
2194       Status        : out Boolean)
2195    is
2196       function C_Set_Close_On_Exec
2197         (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
2198       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2199    begin
2200       Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
2201    end Set_Close_On_Exec;
2202
2203    ----------------------
2204    -- Set_Forced_Flags --
2205    ----------------------
2206
2207    function Set_Forced_Flags (F : C.int) return C.int is
2208       use type C.unsigned;
2209       function To_unsigned is
2210         new Ada.Unchecked_Conversion (C.int, C.unsigned);
2211       function To_int is
2212         new Ada.Unchecked_Conversion (C.unsigned, C.int);
2213    begin
2214       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2215    end Set_Forced_Flags;
2216
2217    -----------------------
2218    -- Set_Socket_Option --
2219    -----------------------
2220
2221    procedure Set_Socket_Option
2222      (Socket : Socket_Type;
2223       Level  : Level_Type := Socket_Level;
2224       Option : Option_Type)
2225    is
2226       use SOSC;
2227
2228       V8  : aliased Two_Ints;
2229       V4  : aliased C.int;
2230       V1  : aliased C.unsigned_char;
2231       VT  : aliased Timeval;
2232       Len : C.int;
2233       Add : System.Address := Null_Address;
2234       Res : C.int;
2235
2236    begin
2237       case Option.Name is
2238          when Keep_Alive      |
2239               Reuse_Address   |
2240               Broadcast       |
2241               No_Delay        =>
2242             V4  := C.int (Boolean'Pos (Option.Enabled));
2243             Len := V4'Size / 8;
2244             Add := V4'Address;
2245
2246          when Linger          =>
2247             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2248             V8 (V8'Last)  := C.int (Option.Seconds);
2249             Len := V8'Size / 8;
2250             Add := V8'Address;
2251
2252          when Send_Buffer     |
2253               Receive_Buffer  =>
2254             V4  := C.int (Option.Size);
2255             Len := V4'Size / 8;
2256             Add := V4'Address;
2257
2258          when Error           =>
2259             V4  := C.int (Boolean'Pos (True));
2260             Len := V4'Size / 8;
2261             Add := V4'Address;
2262
2263          when Add_Membership  |
2264               Drop_Membership =>
2265             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2266             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2267             Len := V8'Size / 8;
2268             Add := V8'Address;
2269
2270          when Multicast_If    =>
2271             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2272             Len := V4'Size / 8;
2273             Add := V4'Address;
2274
2275          when Multicast_TTL   =>
2276             V1  := C.unsigned_char (Option.Time_To_Live);
2277             Len := V1'Size / 8;
2278             Add := V1'Address;
2279
2280          when Multicast_Loop      |
2281               Receive_Packet_Info =>
2282             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2283             Len := V1'Size / 8;
2284             Add := V1'Address;
2285
2286          when Send_Timeout    |
2287               Receive_Timeout =>
2288
2289             if Target_OS = Windows then
2290
2291                --  On Windows, the timeout is a DWORD in milliseconds, and
2292                --  the actual timeout is 500 ms + the given value (unless it
2293                --  is 0).
2294
2295                V4 := C.int (Option.Timeout / 0.001);
2296
2297                if V4 > 500 then
2298                   V4 := V4 - 500;
2299
2300                elsif V4 > 0 then
2301                   V4 := 1;
2302                end if;
2303
2304                Len := V4'Size / 8;
2305                Add := V4'Address;
2306
2307             else
2308                VT  := To_Timeval (Option.Timeout);
2309                Len := VT'Size / 8;
2310                Add := VT'Address;
2311             end if;
2312
2313       end case;
2314
2315       Res := C_Setsockopt
2316         (C.int (Socket),
2317          Levels (Level),
2318          Options (Option.Name),
2319          Add, Len);
2320
2321       if Res = Failure then
2322          Raise_Socket_Error (Socket_Errno);
2323       end if;
2324    end Set_Socket_Option;
2325
2326    ----------------------
2327    -- Short_To_Network --
2328    ----------------------
2329
2330    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2331       use type C.unsigned_short;
2332
2333    begin
2334       --  Big-endian case. No conversion needed. On these platforms, htons()
2335       --  defaults to a null procedure.
2336
2337       if Default_Bit_Order = High_Order_First then
2338          return S;
2339
2340       --  Little-endian case. We must swap the high and low bytes of this
2341       --  short to make the port number network compliant.
2342
2343       else
2344          return (S / 256) + (S mod 256) * 256;
2345       end if;
2346    end Short_To_Network;
2347
2348    ---------------------
2349    -- Shutdown_Socket --
2350    ---------------------
2351
2352    procedure Shutdown_Socket
2353      (Socket : Socket_Type;
2354       How    : Shutmode_Type := Shut_Read_Write)
2355    is
2356       Res : C.int;
2357
2358    begin
2359       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2360
2361       if Res = Failure then
2362          Raise_Socket_Error (Socket_Errno);
2363       end if;
2364    end Shutdown_Socket;
2365
2366    ------------
2367    -- Stream --
2368    ------------
2369
2370    function Stream
2371      (Socket  : Socket_Type;
2372       Send_To : Sock_Addr_Type) return Stream_Access
2373    is
2374       S : Datagram_Socket_Stream_Access;
2375
2376    begin
2377       S        := new Datagram_Socket_Stream_Type;
2378       S.Socket := Socket;
2379       S.To     := Send_To;
2380       S.From   := Get_Socket_Name (Socket);
2381       return Stream_Access (S);
2382    end Stream;
2383
2384    ------------
2385    -- Stream --
2386    ------------
2387
2388    function Stream (Socket : Socket_Type) return Stream_Access is
2389       S : Stream_Socket_Stream_Access;
2390    begin
2391       S := new Stream_Socket_Stream_Type;
2392       S.Socket := Socket;
2393       return Stream_Access (S);
2394    end Stream;
2395
2396    ----------
2397    -- To_C --
2398    ----------
2399
2400    function To_C (Socket : Socket_Type) return Integer is
2401    begin
2402       return Integer (Socket);
2403    end To_C;
2404
2405    -----------------
2406    -- To_Duration --
2407    -----------------
2408
2409    function To_Duration (Val : Timeval) return Timeval_Duration is
2410    begin
2411       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2412    end To_Duration;
2413
2414    -------------------
2415    -- To_Host_Entry --
2416    -------------------
2417
2418    function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2419       use type C.size_t;
2420
2421       Aliases_Count, Addresses_Count : Natural;
2422
2423       --  H_Length is not used because it is currently only ever set to 4, as
2424       --  H_Addrtype is always AF_INET.
2425
2426    begin
2427       Aliases_Count := 0;
2428       while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2429          Aliases_Count := Aliases_Count + 1;
2430       end loop;
2431
2432       Addresses_Count := 0;
2433       while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2434          Addresses_Count := Addresses_Count + 1;
2435       end loop;
2436
2437       return Result : Host_Entry_Type
2438                         (Aliases_Length   => Aliases_Count,
2439                          Addresses_Length => Addresses_Count)
2440       do
2441          Result.Official := To_Name (Value (Hostent_H_Name (E)));
2442
2443          for J in Result.Aliases'Range loop
2444             Result.Aliases (J) :=
2445               To_Name (Value (Hostent_H_Alias
2446                                 (E, C.int (J - Result.Aliases'First))));
2447          end loop;
2448
2449          for J in Result.Addresses'Range loop
2450             declare
2451                Addr : In_Addr;
2452
2453                --  Hostent_H_Addr (E, <index>) may return an address that is
2454                --  not correctly aligned for In_Addr, so we need to use
2455                --  an intermediate copy operation on a type with an alignemnt
2456                --  of 1 to recover the value.
2457
2458                subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8);
2459                Unaligned_Addr : Addr_Buf_T;
2460                for Unaligned_Addr'Address
2461                  use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2462                pragma Import (Ada, Unaligned_Addr);
2463
2464                Aligned_Addr : Addr_Buf_T;
2465                for Aligned_Addr'Address use Addr'Address;
2466                pragma Import (Ada, Aligned_Addr);
2467
2468             begin
2469                Aligned_Addr := Unaligned_Addr;
2470                To_Inet_Addr (Addr, Result.Addresses (J));
2471             end;
2472          end loop;
2473       end return;
2474    end To_Host_Entry;
2475
2476    ----------------
2477    -- To_In_Addr --
2478    ----------------
2479
2480    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2481    begin
2482       if Addr.Family = Family_Inet then
2483          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2484                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2485                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2486                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2487       end if;
2488
2489       raise Socket_Error with "IPv6 not supported";
2490    end To_In_Addr;
2491
2492    ------------------
2493    -- To_Inet_Addr --
2494    ------------------
2495
2496    procedure To_Inet_Addr
2497      (Addr   : In_Addr;
2498       Result : out Inet_Addr_Type) is
2499    begin
2500       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2501       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2502       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2503       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2504    end To_Inet_Addr;
2505
2506    ------------
2507    -- To_Int --
2508    ------------
2509
2510    function To_Int (F : Request_Flag_Type) return C.int
2511    is
2512       Current : Request_Flag_Type := F;
2513       Result  : C.int := 0;
2514
2515    begin
2516       for J in Flags'Range loop
2517          exit when Current = 0;
2518
2519          if Current mod 2 /= 0 then
2520             if Flags (J) = -1 then
2521                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2522             end if;
2523
2524             Result := Result + Flags (J);
2525          end if;
2526
2527          Current := Current / 2;
2528       end loop;
2529
2530       return Result;
2531    end To_Int;
2532
2533    -------------
2534    -- To_Name --
2535    -------------
2536
2537    function To_Name (N : String) return Name_Type is
2538    begin
2539       return Name_Type'(N'Length, N);
2540    end To_Name;
2541
2542    ----------------------
2543    -- To_Service_Entry --
2544    ----------------------
2545
2546    function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2547       use type C.size_t;
2548
2549       Aliases_Count : Natural;
2550
2551    begin
2552       Aliases_Count := 0;
2553       while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2554          Aliases_Count := Aliases_Count + 1;
2555       end loop;
2556
2557       return Result : Service_Entry_Type (Aliases_Length   => Aliases_Count) do
2558          Result.Official := To_Name (Value (Servent_S_Name (E)));
2559
2560          for J in Result.Aliases'Range loop
2561             Result.Aliases (J) :=
2562               To_Name (Value (Servent_S_Alias
2563                                 (E, C.int (J - Result.Aliases'First))));
2564          end loop;
2565
2566          Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2567          Result.Port :=
2568            Port_Type (Network_To_Short (Servent_S_Port (E)));
2569       end return;
2570    end To_Service_Entry;
2571
2572    ---------------
2573    -- To_String --
2574    ---------------
2575
2576    function To_String (HN : Name_Type) return String is
2577    begin
2578       return HN.Name (1 .. HN.Length);
2579    end To_String;
2580
2581    ----------------
2582    -- To_Timeval --
2583    ----------------
2584
2585    function To_Timeval (Val : Timeval_Duration) return Timeval is
2586       S  : time_t;
2587       uS : suseconds_t;
2588
2589    begin
2590       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2591
2592       if Val = 0.0 then
2593          S  := 0;
2594          uS := 0;
2595
2596       --  Normal case where we do round down
2597
2598       else
2599          S  := time_t (Val - 0.5);
2600          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2601       end if;
2602
2603       return (S, uS);
2604    end To_Timeval;
2605
2606    -----------
2607    -- Value --
2608    -----------
2609
2610    function Value (S : System.Address) return String is
2611       Str : String (1 .. Positive'Last);
2612       for Str'Address use S;
2613       pragma Import (Ada, Str);
2614
2615       Terminator : Positive := Str'First;
2616
2617    begin
2618       while Str (Terminator) /= ASCII.NUL loop
2619          Terminator := Terminator + 1;
2620       end loop;
2621
2622       return Str (1 .. Terminator - 1);
2623    end Value;
2624
2625    -----------
2626    -- Write --
2627    -----------
2628
2629    procedure Write
2630      (Stream : in out Datagram_Socket_Stream_Type;
2631       Item   : Ada.Streams.Stream_Element_Array)
2632    is
2633       Last : Stream_Element_Offset;
2634
2635    begin
2636       Send_Socket
2637         (Stream.Socket,
2638          Item,
2639          Last,
2640          Stream.To);
2641
2642       --  It is an error if not all of the data has been sent
2643
2644       if Last /= Item'Last then
2645          Raise_Socket_Error (Socket_Errno);
2646       end if;
2647    end Write;
2648
2649    -----------
2650    -- Write --
2651    -----------
2652
2653    procedure Write
2654      (Stream : in out Stream_Socket_Stream_Type;
2655       Item   : Ada.Streams.Stream_Element_Array)
2656    is
2657       First : Ada.Streams.Stream_Element_Offset;
2658       Index : Ada.Streams.Stream_Element_Offset;
2659       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2660
2661    begin
2662       First := Item'First;
2663       Index := First - 1;
2664       while First <= Max loop
2665          Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
2666
2667          --  Exit when all or zero data sent. Zero means that the socket has
2668          --  been closed by peer.
2669
2670          exit when Index < First or else Index = Max;
2671
2672          First := Index + 1;
2673       end loop;
2674
2675       --  For an empty array, we have First > Max, and hence Index >= Max (no
2676       --  error, the loop above is never executed). After a successful send,
2677       --  Index = Max. The only remaining case, Index < Max, is therefore
2678       --  always an actual send failure.
2679
2680       if Index < Max then
2681          Raise_Socket_Error (Socket_Errno);
2682       end if;
2683    end Write;
2684
2685    Sockets_Library_Controller_Object : Sockets_Library_Controller;
2686    pragma Unreferenced (Sockets_Library_Controller_Object);
2687    --  The elaboration and finalization of this object perform the required
2688    --  initialization and cleanup actions for the sockets library.
2689
2690 end GNAT.Sockets;