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