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