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