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