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-2020, 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.Containers.Generic_Array_Sort;
  35 with Ada.Finalization;
  36 with Ada.Unchecked_Conversion;
  37
  38 with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common;
  39 with GNAT.Sockets.Thin;        use GNAT.Sockets.Thin;
  40
  41 with GNAT.Sockets.Linker_Options;
  42 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
  43 --  Need to include pragma Linker_Options which is platform dependent
  44
  45 with System;               use System;
  46 with System.Communication; use System.Communication;
  47 with System.CRTL;          use System.CRTL;
  48 with System.Task_Lock;
  49
  50 package body GNAT.Sockets is
  51
  52    package C renames Interfaces.C;
  53
  54    type IPV6_Mreq is record
  55       ipv6mr_multiaddr : In6_Addr;
  56       ipv6mr_interface : C.unsigned;
  57    end record with Convention => C;
  58    --  Record to Add/Drop_Membership for multicast in IPv6
  59
  60    ENOERROR : constant := 0;
  61
  62    Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
  63    Need_Netdb_Lock   : constant Boolean := SOSC.Need_Netdb_Lock /= 0;
  64    --  The network database functions gethostbyname, gethostbyaddr,
  65    --  getservbyname and getservbyport can either be guaranteed task safe by
  66    --  the operating system, or else return data through a user-provided buffer
  67    --  to ensure concurrent uses do not interfere.
  68
  69    --  Correspondence tables
  70
  71    Levels : constant array (Level_Type) of C.int :=
  72               (Socket_Level               => SOSC.SOL_SOCKET,
  73                IP_Protocol_For_IP_Level   => SOSC.IPPROTO_IP,
  74                IP_Protocol_For_IPv6_Level => SOSC.IPPROTO_IPV6,
  75                IP_Protocol_For_UDP_Level  => SOSC.IPPROTO_UDP,
  76                IP_Protocol_For_TCP_Level  => SOSC.IPPROTO_TCP,
  77                IP_Protocol_For_ICMP_Level => SOSC.IPPROTO_ICMP,
  78                IP_Protocol_For_IGMP_Level => SOSC.IPPROTO_IGMP,
  79                IP_Protocol_For_RAW_Level  => SOSC.IPPROTO_RAW);
  80
  81    Modes : constant array (Mode_Type) of C.int :=
  82              (Socket_Stream   => SOSC.SOCK_STREAM,
  83               Socket_Datagram => SOSC.SOCK_DGRAM,
  84               Socket_Raw      => SOSC.SOCK_RAW);
  85
  86    Shutmodes : constant array (Shutmode_Type) of C.int :=
  87                  (Shut_Read       => SOSC.SHUT_RD,
  88                   Shut_Write      => SOSC.SHUT_WR,
  89                   Shut_Read_Write => SOSC.SHUT_RDWR);
  90
  91    Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T :=
  92                 (Non_Blocking_IO => SOSC.FIONBIO,
  93                  N_Bytes_To_Read => SOSC.FIONREAD);
  94
  95    Options : constant array (Specific_Option_Name) of C.int :=
  96                (Keep_Alive          => SOSC.SO_KEEPALIVE,
  97                 Reuse_Address       => SOSC.SO_REUSEADDR,
  98                 Broadcast           => SOSC.SO_BROADCAST,
  99                 Send_Buffer         => SOSC.SO_SNDBUF,
 100                 Receive_Buffer      => SOSC.SO_RCVBUF,
 101                 Linger              => SOSC.SO_LINGER,
 102                 Error               => SOSC.SO_ERROR,
 103                 No_Delay            => SOSC.TCP_NODELAY,
 104                 Add_Membership_V4   => SOSC.IP_ADD_MEMBERSHIP,
 105                 Drop_Membership_V4  => SOSC.IP_DROP_MEMBERSHIP,
 106                 Multicast_If_V4     => SOSC.IP_MULTICAST_IF,
 107                 Multicast_Loop_V4   => SOSC.IP_MULTICAST_LOOP,
 108                 Receive_Packet_Info => SOSC.IP_PKTINFO,
 109                 Multicast_TTL       => SOSC.IP_MULTICAST_TTL,
 110                 Add_Membership_V6   => SOSC.IPV6_ADD_MEMBERSHIP,
 111                 Drop_Membership_V6  => SOSC.IPV6_DROP_MEMBERSHIP,
 112                 Multicast_If_V6     => SOSC.IPV6_MULTICAST_IF,
 113                 Multicast_Loop_V6   => SOSC.IPV6_MULTICAST_LOOP,
 114                 Multicast_Hops      => SOSC.IPV6_MULTICAST_HOPS,
 115                 IPv6_Only           => SOSC.IPV6_V6ONLY,
 116                 Send_Timeout        => SOSC.SO_SNDTIMEO,
 117                 Receive_Timeout     => SOSC.SO_RCVTIMEO,
 118                 Busy_Polling        => SOSC.SO_BUSY_POLL);
 119    --  ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
 120    --  but for Linux compatibility this constant is the same as IP_PKTINFO.
 121
 122    Flags : constant array (0 .. 3) of C.int :=
 123              (0 => SOSC.MSG_OOB,     --  Process_Out_Of_Band_Data
 124               1 => SOSC.MSG_PEEK,    --  Peek_At_Incoming_Data
 125               2 => SOSC.MSG_WAITALL, --  Wait_For_A_Full_Reception
 126               3 => SOSC.MSG_EOR);    --  Send_End_Of_Record
 127
 128    Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
 129    Host_Error_Id   : constant Exception_Id := Host_Error'Identity;
 130
 131    type In_Addr_Union (Family : Family_Inet_4_6) is record
 132       case Family is
 133          when Family_Inet =>
 134             In4 : In_Addr;
 135          when Family_Inet6 =>
 136             In6 : In6_Addr;
 137       end case;
 138    end record with Unchecked_Union;
 139
 140    -----------------------
 141    -- Local subprograms --
 142    -----------------------
 143
 144    function Resolve_Error
 145      (Error_Value : Integer;
 146       From_Errno  : Boolean := True) return Error_Type;
 147    --  Associate an enumeration value (error_type) to an error value (errno).
 148    --  From_Errno prevents from mixing h_errno with errno.
 149
 150    function To_Name   (N  : String) return Name_Type;
 151    function To_String (HN : Name_Type) return String;
 152    --  Conversion functions
 153
 154    function To_Int (F : Request_Flag_Type) return C.int;
 155    --  Return the int value corresponding to the specified flags combination
 156
 157    function Set_Forced_Flags (F : C.int) return C.int;
 158    --  Return F with the bits from SOSC.MSG_Forced_Flags forced set
 159
 160    procedure Netdb_Lock;
 161    pragma Inline (Netdb_Lock);
 162    procedure Netdb_Unlock;
 163    pragma Inline (Netdb_Unlock);
 164    --  Lock/unlock operation used to protect netdb access for platforms that
 165    --  require such protection.
 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    function Dedot (Value : String) return String
 184    is (if Value /= "" and then Value (Value'Last) = '.'
 185        then Value (Value'First .. Value'Last - 1)
 186        else Value);
 187    --  Removes dot at the end of error message
 188
 189    procedure Raise_Socket_Error (Error : Integer);
 190    --  Raise Socket_Error with an exception message describing the error code
 191    --  from errno.
 192
 193    procedure Raise_Host_Error (H_Error : Integer; Name : String);
 194    --  Raise Host_Error exception with message describing error code (note
 195    --  hstrerror seems to be obsolete) from h_errno. Name is the name
 196    --  or address that was being looked up.
 197
 198    procedure Raise_GAI_Error (RC : C.int; Name : String);
 199    --  Raise Host_Error with exception message in case of errors in
 200    --  getaddrinfo and getnameinfo.
 201
 202    function Is_Windows return Boolean with Inline;
 203    --  Returns True on Windows platform
 204
 205    procedure Narrow (Item : in out Socket_Set_Type);
 206    --  Update Last as it may be greater than the real last socket
 207
 208    procedure Check_For_Fd_Set (Fd : Socket_Type);
 209    pragma Inline (Check_For_Fd_Set);
 210    --  Raise Constraint_Error if Fd is less than 0 or greater than or equal to
 211    --  FD_SETSIZE, on platforms where fd_set is a bitmap.
 212
 213    function Connect_Socket
 214      (Socket : Socket_Type;
 215       Server : Sock_Addr_Type) return C.int;
 216    pragma Inline (Connect_Socket);
 217    --  Underlying implementation for the Connect_Socket procedures
 218
 219    --  Types needed for Datagram_Socket_Stream_Type
 220
 221    type Datagram_Socket_Stream_Type is new Root_Stream_Type with record
 222       Socket : Socket_Type;
 223       To     : Sock_Addr_Type;
 224       From   : Sock_Addr_Type;
 225    end record;
 226
 227    type Datagram_Socket_Stream_Access is
 228      access all Datagram_Socket_Stream_Type;
 229
 230    procedure Read
 231      (Stream : in out Datagram_Socket_Stream_Type;
 232       Item   : out Ada.Streams.Stream_Element_Array;
 233       Last   : out Ada.Streams.Stream_Element_Offset);
 234
 235    procedure Write
 236      (Stream : in out Datagram_Socket_Stream_Type;
 237       Item   : Ada.Streams.Stream_Element_Array);
 238
 239    --  Types needed for Stream_Socket_Stream_Type
 240
 241    type Stream_Socket_Stream_Type is new Root_Stream_Type with record
 242       Socket : Socket_Type;
 243    end record;
 244
 245    type Stream_Socket_Stream_Access is
 246      access all Stream_Socket_Stream_Type;
 247
 248    procedure Read
 249      (Stream : in out Stream_Socket_Stream_Type;
 250       Item   : out Ada.Streams.Stream_Element_Array;
 251       Last   : out Ada.Streams.Stream_Element_Offset);
 252
 253    procedure Write
 254      (Stream : in out Stream_Socket_Stream_Type;
 255       Item   : Ada.Streams.Stream_Element_Array);
 256
 257    procedure Wait_On_Socket
 258      (Socket   : Socket_Type;
 259       For_Read : Boolean;
 260       Timeout  : Selector_Duration;
 261       Selector : access Selector_Type := null;
 262       Status   : out Selector_Status);
 263    --  Common code for variants of socket operations supporting a timeout:
 264    --  block in Check_Selector on Socket for at most the indicated timeout.
 265    --  If For_Read is True, Socket is added to the read set for this call, else
 266    --  it is added to the write set. If no selector is provided, a local one is
 267    --  created for this call and destroyed prior to returning.
 268
 269    type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
 270      with null record;
 271    --  This type is used to generate automatic calls to Initialize and Finalize
 272    --  during the elaboration and finalization of this package. A single object
 273    --  of this type must exist at library level.
 274
 275    function Err_Code_Image (E : Integer) return String;
 276    --  Return the value of E surrounded with brackets
 277
 278    procedure Initialize (X : in out Sockets_Library_Controller);
 279    procedure Finalize   (X : in out Sockets_Library_Controller);
 280
 281    procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type);
 282    --  If S is the empty set (detected by Last = No_Socket), make sure its
 283    --  fd_set component is actually cleared. Note that the case where it is
 284    --  not can occur for an uninitialized Socket_Set_Type object.
 285
 286    function Is_Open (S : Selector_Type) return Boolean;
 287    --  Return True for an "open" Selector_Type object, i.e. one for which
 288    --  Create_Selector has been called and Close_Selector has not been called,
 289    --  or the null selector.
 290
 291    function Create_Address
 292      (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
 293      with Inline;
 294    --  Creates address from family and Inet_Addr_Bytes array.
 295
 296    function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes
 297      with Inline;
 298    --  Extract bytes from address
 299
 300    ---------
 301    -- "+" --
 302    ---------
 303
 304    function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
 305    begin
 306       return L or R;
 307    end "+";
 308
 309    --------------------
 310    -- Abort_Selector --
 311    --------------------
 312
 313    procedure Abort_Selector (Selector : Selector_Type) is
 314       Res : C.int;
 315
 316    begin
 317       if not Is_Open (Selector) then
 318          raise Program_Error with "closed selector";
 319
 320       elsif Selector.Is_Null then
 321          raise Program_Error with "null selector";
 322
 323       end if;
 324
 325       --  Send one byte to unblock select system call
 326
 327       Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
 328
 329       if Res = Failure then
 330          Raise_Socket_Error (Socket_Errno);
 331       end if;
 332    end Abort_Selector;
 333
 334    -------------------
 335    -- Accept_Socket --
 336    -------------------
 337
 338    procedure Accept_Socket
 339      (Server  : Socket_Type;
 340       Socket  : out Socket_Type;
 341       Address : out Sock_Addr_Type)
 342    is
 343       Res : C.int;
 344       Sin : aliased Sockaddr;
 345       Len : aliased C.int := Sin'Size / 8;
 346
 347    begin
 348       Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
 349
 350       if Res = Failure then
 351          Raise_Socket_Error (Socket_Errno);
 352       end if;
 353
 354       Socket := Socket_Type (Res);
 355       Address := Get_Address (Sin, Len);
 356    end Accept_Socket;
 357
 358    -------------------
 359    -- Accept_Socket --
 360    -------------------
 361
 362    procedure Accept_Socket
 363      (Server   : Socket_Type;
 364       Socket   : out Socket_Type;
 365       Address  : out Sock_Addr_Type;
 366       Timeout  : Selector_Duration;
 367       Selector : access Selector_Type := null;
 368       Status   : out Selector_Status)
 369    is
 370    begin
 371       if Selector /= null and then not Is_Open (Selector.all) then
 372          raise Program_Error with "closed selector";
 373       end if;
 374
 375       --  Wait for socket to become available for reading
 376
 377       Wait_On_Socket
 378         (Socket    => Server,
 379          For_Read  => True,
 380          Timeout   => Timeout,
 381          Selector  => Selector,
 382          Status    => Status);
 383
 384       --  Accept connection if available
 385
 386       if Status = Completed then
 387          Accept_Socket (Server, Socket, Address);
 388       else
 389          Socket := No_Socket;
 390       end if;
 391    end Accept_Socket;
 392
 393    ---------------
 394    -- Addresses --
 395    ---------------
 396
 397    function Addresses
 398      (E : Host_Entry_Type;
 399       N : Positive := 1) return Inet_Addr_Type
 400    is
 401    begin
 402       return E.Addresses (N);
 403    end Addresses;
 404
 405    ----------------------
 406    -- Addresses_Length --
 407    ----------------------
 408
 409    function Addresses_Length (E : Host_Entry_Type) return Natural is
 410    begin
 411       return E.Addresses_Length;
 412    end Addresses_Length;
 413
 414    -------------
 415    -- Aliases --
 416    -------------
 417
 418    function Aliases
 419      (E : Host_Entry_Type;
 420       N : Positive := 1) return String
 421    is
 422    begin
 423       return To_String (E.Aliases (N));
 424    end Aliases;
 425
 426    -------------
 427    -- Aliases --
 428    -------------
 429
 430    function Aliases
 431      (S : Service_Entry_Type;
 432       N : Positive := 1) return String
 433    is
 434    begin
 435       return To_String (S.Aliases (N));
 436    end Aliases;
 437
 438    --------------------
 439    -- Aliases_Length --
 440    --------------------
 441
 442    function Aliases_Length (E : Host_Entry_Type) return Natural is
 443    begin
 444       return E.Aliases_Length;
 445    end Aliases_Length;
 446
 447    --------------------
 448    -- Aliases_Length --
 449    --------------------
 450
 451    function Aliases_Length (S : Service_Entry_Type) return Natural is
 452    begin
 453       return S.Aliases_Length;
 454    end Aliases_Length;
 455
 456    -----------------
 457    -- Bind_Socket --
 458    -----------------
 459
 460    procedure Bind_Socket
 461      (Socket  : Socket_Type;
 462       Address : Sock_Addr_Type)
 463    is
 464       Res : C.int;
 465       Sin : aliased Sockaddr;
 466       Len : C.int;
 467
 468    begin
 469       Set_Address (Sin'Unchecked_Access, Address, Len);
 470
 471       Res := C_Bind (C.int (Socket), Sin'Address, Len);
 472
 473       if Res = Failure then
 474          Raise_Socket_Error (Socket_Errno);
 475       end if;
 476    end Bind_Socket;
 477
 478    ----------------------
 479    -- Check_For_Fd_Set --
 480    ----------------------
 481
 482    procedure Check_For_Fd_Set (Fd : Socket_Type) is
 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 Is_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;
 671       Len : C.int;
 672    begin
 673       Set_Address (Sin'Unchecked_Access, Server, Len);
 674
 675       return C_Connect (C.int (Socket), Sin'Address, Len);
 676    end Connect_Socket;
 677
 678    procedure Connect_Socket
 679      (Socket : Socket_Type;
 680       Server : Sock_Addr_Type)
 681    is
 682    begin
 683       if Connect_Socket (Socket, Server) = Failure then
 684          Raise_Socket_Error (Socket_Errno);
 685       end if;
 686    end Connect_Socket;
 687
 688    procedure Connect_Socket
 689      (Socket   : Socket_Type;
 690       Server   : Sock_Addr_Type;
 691       Timeout  : Selector_Duration;
 692       Selector : access Selector_Type := null;
 693       Status   : out Selector_Status)
 694    is
 695       Req : Request_Type;
 696       --  Used to set Socket to non-blocking I/O
 697
 698       Conn_Err : aliased Integer;
 699       --  Error status of the socket after completion of select(2)
 700
 701       Res           : C.int;
 702       Conn_Err_Size : aliased C.int := Conn_Err'Size / 8;
 703       --  For getsockopt(2) call
 704
 705    begin
 706       if Selector /= null and then not Is_Open (Selector.all) then
 707          raise Program_Error with "closed selector";
 708       end if;
 709
 710       --  Set the socket to non-blocking I/O
 711
 712       Req := (Name => Non_Blocking_IO, Enabled => True);
 713       Control_Socket (Socket, Request => Req);
 714
 715       --  Start operation (non-blocking), will return Failure with errno set
 716       --  to EINPROGRESS.
 717
 718       Res := Connect_Socket (Socket, Server);
 719       if Res = Failure then
 720          Conn_Err := Socket_Errno;
 721          if Conn_Err /= SOSC.EINPROGRESS then
 722             Raise_Socket_Error (Conn_Err);
 723          end if;
 724       end if;
 725
 726       --  Wait for socket to become available for writing (unless the Timeout
 727       --  is zero, in which case we consider that it has already expired, and
 728       --  we do not need to wait at all).
 729
 730       if Timeout = 0.0 then
 731          Status := Expired;
 732
 733       else
 734          Wait_On_Socket
 735            (Socket   => Socket,
 736             For_Read => False,
 737             Timeout  => Timeout,
 738             Selector => Selector,
 739             Status   => Status);
 740       end if;
 741
 742       --  Check error condition (the asynchronous connect may have terminated
 743       --  with an error, e.g. ECONNREFUSED) if select(2) completed.
 744
 745       if Status = Completed then
 746          Res := C_Getsockopt
 747            (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR,
 748             Conn_Err'Address, Conn_Err_Size'Access);
 749
 750          if Res /= 0 then
 751             Conn_Err := Socket_Errno;
 752          end if;
 753
 754       else
 755          Conn_Err := 0;
 756       end if;
 757
 758       --  Reset the socket to blocking I/O
 759
 760       Req := (Name => Non_Blocking_IO, Enabled => False);
 761       Control_Socket (Socket, Request => Req);
 762
 763       --  Report error condition if any
 764
 765       if Conn_Err /= 0 then
 766          Raise_Socket_Error (Conn_Err);
 767       end if;
 768    end Connect_Socket;
 769
 770    --------------------
 771    -- Control_Socket --
 772    --------------------
 773
 774    procedure Control_Socket
 775      (Socket  : Socket_Type;
 776       Request : in out Request_Type)
 777    is
 778       Arg : aliased C.int;
 779       Res : C.int;
 780
 781    begin
 782       case Request.Name is
 783          when Non_Blocking_IO =>
 784             Arg := C.int (Boolean'Pos (Request.Enabled));
 785
 786          when N_Bytes_To_Read =>
 787             null;
 788       end case;
 789
 790       Res := Socket_Ioctl
 791                (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access);
 792
 793       if Res = Failure then
 794          Raise_Socket_Error (Socket_Errno);
 795       end if;
 796
 797       case Request.Name is
 798          when Non_Blocking_IO =>
 799             null;
 800
 801          when N_Bytes_To_Read =>
 802             Request.Size := Natural (Arg);
 803       end case;
 804    end Control_Socket;
 805
 806    ----------
 807    -- Copy --
 808    ----------
 809
 810    procedure Copy
 811      (Source : Socket_Set_Type;
 812       Target : out Socket_Set_Type)
 813    is
 814    begin
 815       Target := Source;
 816    end Copy;
 817
 818    ---------------------
 819    -- Create_Selector --
 820    ---------------------
 821
 822    procedure Create_Selector (Selector : out Selector_Type) is
 823       Two_Fds : aliased Fd_Pair;
 824       Res     : C.int;
 825
 826    begin
 827       if Is_Open (Selector) then
 828          --  Raise exception to prevent socket descriptor leak
 829
 830          raise Program_Error with "selector already open";
 831       end if;
 832
 833       --  We open two signalling file descriptors. One of them is used to send
 834       --  data to the other, which is included in a C_Select socket set. The
 835       --  communication is used to force a call to C_Select to complete, and
 836       --  the waiting task to resume its execution.
 837
 838       Res := Signalling_Fds.Create (Two_Fds'Access);
 839       pragma Annotate (CodePeer, Modified, Two_Fds);
 840
 841       if Res = Failure then
 842          Raise_Socket_Error (Socket_Errno);
 843       end if;
 844
 845       Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
 846       Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
 847    end Create_Selector;
 848
 849    -------------------
 850    -- Create_Socket --
 851    -------------------
 852
 853    procedure Create_Socket
 854      (Socket : out Socket_Type;
 855       Family : Family_Type := Family_Inet;
 856       Mode   : Mode_Type   := Socket_Stream;
 857       Level  : Level_Type  := IP_Protocol_For_IP_Level)
 858    is
 859       Res : C.int;
 860
 861    begin
 862       Res := C_Socket (Families (Family), Modes (Mode), Levels (Level));
 863
 864       if Res = Failure then
 865          Raise_Socket_Error (Socket_Errno);
 866       end if;
 867
 868       Socket := Socket_Type (Res);
 869    end Create_Socket;
 870
 871    ------------------------
 872    -- Create_Socket_Pair --
 873    ------------------------
 874
 875    procedure Create_Socket_Pair
 876      (Left   : out Socket_Type;
 877       Right  : out Socket_Type;
 878       Family : Family_Type := Family_Unspec;
 879       Mode   : Mode_Type   := Socket_Stream;
 880       Level  : Level_Type  := IP_Protocol_For_IP_Level)
 881    is
 882       Res  : C.int;
 883       Pair : aliased Thin_Common.Fd_Pair;
 884
 885    begin
 886       Res := C_Socketpair
 887         ((if Family = Family_Unspec then Default_Socket_Pair_Family
 888           else Families (Family)),
 889          Modes (Mode), Levels (Level), Pair'Access);
 890       pragma Annotate (CodePeer, Modified, Pair);
 891
 892       if Res = Failure then
 893          Raise_Socket_Error (Socket_Errno);
 894       end if;
 895
 896       Left  := Socket_Type (Pair (Pair'First));
 897       Right := Socket_Type (Pair (Pair'Last));
 898    end Create_Socket_Pair;
 899
 900    -----------
 901    -- Empty --
 902    -----------
 903
 904    procedure Empty (Item : out Socket_Set_Type) is
 905    begin
 906       Reset_Socket_Set (Item.Set'Access);
 907       Item.Last := No_Socket;
 908    end Empty;
 909
 910    --------------------
 911    -- Err_Code_Image --
 912    --------------------
 913
 914    function Err_Code_Image (E : Integer) return String is
 915       Msg : String := E'Img & "] ";
 916    begin
 917       Msg (Msg'First) := '[';
 918       return Msg;
 919    end Err_Code_Image;
 920
 921    --------------
 922    -- Finalize --
 923    --------------
 924
 925    procedure Finalize (X : in out Sockets_Library_Controller) is
 926       pragma Unreferenced (X);
 927
 928    begin
 929       --  Finalization operation for the GNAT.Sockets package
 930
 931       Thin.Finalize;
 932    end Finalize;
 933
 934    --------------
 935    -- Finalize --
 936    --------------
 937
 938    procedure Finalize is
 939    begin
 940       --  This is a dummy placeholder for an obsolete API.
 941       --  The real finalization actions are in Initialize primitive operation
 942       --  of Sockets_Library_Controller.
 943
 944       null;
 945    end Finalize;
 946
 947    ---------
 948    -- Get --
 949    ---------
 950
 951    procedure Get
 952      (Item   : in out Socket_Set_Type;
 953       Socket : out Socket_Type)
 954    is
 955       S : aliased C.int;
 956       L : aliased C.int := C.int (Item.Last);
 957
 958    begin
 959       if Item.Last /= No_Socket then
 960          Get_Socket_From_Set
 961            (Item.Set'Access, Last => L'Access, Socket => S'Access);
 962          pragma Annotate (CodePeer, Modified, L);
 963          pragma Annotate (CodePeer, Modified, S);
 964
 965          Item.Last := Socket_Type (L);
 966          Socket    := Socket_Type (S);
 967
 968       else
 969          Socket := No_Socket;
 970       end if;
 971    end Get;
 972
 973    -----------------
 974    -- Get_Address --
 975    -----------------
 976
 977    function Get_Address
 978      (Stream : not null Stream_Access) return Sock_Addr_Type
 979    is
 980    begin
 981       if Stream.all in Datagram_Socket_Stream_Type then
 982          return Datagram_Socket_Stream_Type (Stream.all).From;
 983       else
 984          return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
 985       end if;
 986    end Get_Address;
 987
 988    ---------------------
 989    -- Raise_GAI_Error --
 990    ---------------------
 991
 992    procedure Raise_GAI_Error (RC : C.int; Name : String) is
 993    begin
 994       if RC = SOSC.EAI_SYSTEM then
 995          declare
 996             Errcode : constant Integer := Socket_Errno;
 997          begin
 998             raise Host_Error with Err_Code_Image (Errcode)
 999               & Dedot (Socket_Error_Message (Errcode)) & ": " & Name;
1000          end;
1001       else
1002          raise Host_Error with Err_Code_Image (Integer (RC))
1003            & Dedot (CS.Value (C_GAI_Strerror (RC))) & ": " & Name;
1004       end if;
1005    end Raise_GAI_Error;
1006
1007    ----------------------
1008    -- Get_Address_Info --
1009    ----------------------
1010
1011    function Get_Address_Info
1012      (Host         : String;
1013       Service      : String;
1014       Family       : Family_Type := Family_Unspec;
1015       Mode         : Mode_Type   := Socket_Stream;
1016       Level        : Level_Type  := IP_Protocol_For_IP_Level;
1017       Numeric_Host : Boolean     := False;
1018       Passive      : Boolean     := False;
1019       Unknown      : access procedure
1020         (Family, Mode, Level, Length : Integer) := null)
1021       return Address_Info_Array
1022    is
1023       A : aliased Addrinfo_Access;
1024       N : aliased C.char_array := C.To_C (Host);
1025       S : aliased C.char_array := C.To_C (if Service = "" then "0"
1026                                           else Service);
1027       Hints : aliased constant Addrinfo :=
1028         (ai_family   => Families (Family),
1029          ai_socktype => Modes (Mode),
1030          ai_protocol => Levels (Level),
1031          ai_flags    => (if Numeric_Host then SOSC.AI_NUMERICHOST else 0) +
1032                         (if Passive then SOSC.AI_PASSIVE else 0),
1033          ai_addrlen  => 0,
1034          others      => <>);
1035
1036       R     : C.int;
1037       Iter  : Addrinfo_Access;
1038       Found : Boolean;
1039
1040       function To_Array return Address_Info_Array;
1041       --  Convert taken from OS addrinfo list A into Address_Info_Array
1042
1043       --------------
1044       -- To_Array --
1045       --------------
1046
1047       function To_Array return Address_Info_Array is
1048          Result : Address_Info_Array (1 .. 8);
1049
1050          procedure Unsupported;
1051          --  Calls Unknown callback if defiend
1052
1053          -----------------
1054          -- Unsupported --
1055          -----------------
1056
1057          procedure Unsupported is
1058          begin
1059             if Unknown /= null then
1060                Unknown
1061                  (Integer (Iter.ai_family),
1062                   Integer (Iter.ai_socktype),
1063                   Integer (Iter.ai_protocol),
1064                   Integer (Iter.ai_addrlen));
1065             end if;
1066          end Unsupported;
1067
1068       --  Start of processing for To_Array
1069
1070       begin
1071          for J in Result'Range loop
1072             Look_For_Supported : loop
1073                if Iter = null then
1074                   pragma Warnings
1075                     (Off, "may be referenced before it has a value");
1076
1077                   return Result (1 .. J - 1);
1078
1079                   pragma Warnings
1080                     (On, "may be referenced before it has a value");
1081                end if;
1082
1083                Result (J).Addr :=
1084                  Get_Address (Iter.ai_addr.all, C.int (Iter.ai_addrlen));
1085
1086                if Result (J).Addr.Family = Family_Unspec then
1087                   Unsupported;
1088                else
1089                   for M in Modes'Range loop
1090                      Found := False;
1091                      if Modes (M) = Iter.ai_socktype then
1092                         Result (J).Mode := M;
1093                         Found := True;
1094                         exit;
1095                      end if;
1096                   end loop;
1097
1098                   if Found then
1099                      for L in Levels'Range loop
1100                         if Levels (L) = Iter.ai_protocol then
1101                            Result (J).Level := L;
1102                            exit;
1103                         end if;
1104                      end loop;
1105
1106                      exit Look_For_Supported;
1107                   else
1108                      Unsupported;
1109                   end if;
1110                end if;
1111
1112                Iter := Iter.ai_next;
1113             end loop Look_For_Supported;
1114
1115             Iter := Iter.ai_next;
1116          end loop;
1117
1118          return Result & To_Array;
1119       end To_Array;
1120
1121    --  Start of processing for Get_Address_Info
1122
1123    begin
1124       R := C_Getaddrinfo
1125         (Node    => (if Host = "" then null else N'Unchecked_Access),
1126          Service => S'Unchecked_Access,
1127          Hints   => Hints'Unchecked_Access,
1128          Res     => A'Access);
1129
1130       if R /= 0 then
1131          Raise_GAI_Error
1132            (R, Host & (if Service = "" then "" else ':' & Service));
1133       end if;
1134
1135       Iter := A;
1136
1137       return Result : constant Address_Info_Array := To_Array do
1138          C_Freeaddrinfo (A);
1139       end return;
1140    end Get_Address_Info;
1141
1142    ----------
1143    -- Sort --
1144    ----------
1145
1146    procedure Sort
1147      (Addr_Info : in out Address_Info_Array;
1148       Compare   : access function (Left, Right : Address_Info) return Boolean)
1149    is
1150       function Comp (Left, Right : Address_Info) return Boolean is
1151          (Compare (Left, Right));
1152       procedure Sorter is new Ada.Containers.Generic_Array_Sort
1153         (Positive, Address_Info, Address_Info_Array, Comp);
1154    begin
1155       Sorter (Addr_Info);
1156    end Sort;
1157
1158    ------------------------
1159    -- IPv6_TCP_Preferred --
1160    ------------------------
1161
1162    function IPv6_TCP_Preferred (Left, Right : Address_Info) return Boolean is
1163    begin
1164       pragma Assert (Family_Inet < Family_Inet6);
1165       --  To be sure that Family_Type enumeration has appropriate elements
1166       --  order
1167
1168       if Left.Addr.Family /= Right.Addr.Family then
1169          return Left.Addr.Family > Right.Addr.Family;
1170       end if;
1171
1172       pragma Assert (Socket_Stream < Socket_Datagram);
1173       --  To be sure that Mode_Type enumeration has appropriate elements order
1174
1175       return Left.Mode < Right.Mode;
1176    end IPv6_TCP_Preferred;
1177
1178    -------------------
1179    -- Get_Name_Info --
1180    -------------------
1181
1182    function Get_Name_Info
1183      (Addr         : Sock_Addr_Type;
1184       Numeric_Host : Boolean := False;
1185       Numeric_Serv : Boolean := False) return Host_Service
1186    is
1187       SA  : aliased Sockaddr;
1188       H   : aliased C.char_array := (1 .. SOSC.NI_MAXHOST => C.nul);
1189       S   : aliased C.char_array := (1 .. SOSC.NI_MAXSERV => C.nul);
1190       RC  : C.int;
1191       Len : C.int;
1192    begin
1193       Set_Address (SA'Unchecked_Access, Addr, Len);
1194
1195       RC := C_Getnameinfo
1196         (SA'Unchecked_Access, socklen_t (Len),
1197          H'Unchecked_Access, H'Length,
1198          S'Unchecked_Access, S'Length,
1199          (if Numeric_Host then SOSC.NI_NUMERICHOST else 0) +
1200              (if Numeric_Serv then SOSC.NI_NUMERICSERV else 0));
1201
1202       if RC /= 0 then
1203          Raise_GAI_Error (RC, Image (Addr));
1204       end if;
1205
1206       declare
1207          HR : constant String := C.To_Ada (H);
1208          SR : constant String := C.To_Ada (S);
1209       begin
1210          return (HR'Length, SR'Length, HR, SR);
1211       end;
1212    end Get_Name_Info;
1213
1214    -------------------------
1215    -- Get_Host_By_Address --
1216    -------------------------
1217
1218    function Get_Host_By_Address
1219      (Address : Inet_Addr_Type;
1220       Family  : Family_Type := Family_Inet) return Host_Entry_Type
1221    is
1222       pragma Unreferenced (Family);
1223
1224       HA     : aliased In_Addr_Union (Address.Family);
1225       Buflen : constant C.int := Netdb_Buffer_Size;
1226       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1227       Res    : aliased Hostent;
1228       Err    : aliased C.int;
1229
1230    begin
1231       case Address.Family is
1232          when Family_Inet =>
1233             HA.In4 := To_In_Addr (Address);
1234          when Family_Inet6 =>
1235             HA.In6 := To_In6_Addr (Address);
1236       end case;
1237
1238       Netdb_Lock;
1239
1240       if C_Gethostbyaddr
1241         (HA'Address,
1242          (case Address.Family is
1243              when Family_Inet => HA.In4'Size,
1244              when Family_Inet6 => HA.In6'Size) / 8,
1245          Families (Address.Family),
1246          Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1247       then
1248          Netdb_Unlock;
1249          Raise_Host_Error (Integer (Err), Image (Address));
1250       end if;
1251
1252       begin
1253          return H : constant Host_Entry_Type :=
1254                       To_Host_Entry (Res'Unchecked_Access)
1255          do
1256             Netdb_Unlock;
1257          end return;
1258       exception
1259          when others =>
1260             Netdb_Unlock;
1261             raise;
1262       end;
1263    end Get_Host_By_Address;
1264
1265    ----------------------
1266    -- Get_Host_By_Name --
1267    ----------------------
1268
1269    function Get_Host_By_Name (Name : String) return Host_Entry_Type is
1270    begin
1271       --  If the given name actually is the string representation of
1272       --  an IP address, use Get_Host_By_Address instead.
1273
1274       if Is_IPv4_Address (Name) or else Is_IPv6_Address (Name) then
1275          return Get_Host_By_Address (Inet_Addr (Name));
1276       end if;
1277
1278       declare
1279          HN     : constant C.char_array := C.To_C (Name);
1280          Buflen : constant C.int := Netdb_Buffer_Size;
1281          Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1282          Res    : aliased Hostent;
1283          Err    : aliased C.int;
1284
1285       begin
1286          Netdb_Lock;
1287
1288          if C_Gethostbyname
1289            (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
1290          then
1291             Netdb_Unlock;
1292             Raise_Host_Error (Integer (Err), Name);
1293          end if;
1294
1295          return H : constant Host_Entry_Type :=
1296                       To_Host_Entry (Res'Unchecked_Access)
1297          do
1298             Netdb_Unlock;
1299          end return;
1300       end;
1301    end Get_Host_By_Name;
1302
1303    -------------------
1304    -- Get_Peer_Name --
1305    -------------------
1306
1307    function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
1308       Sin : aliased Sockaddr;
1309       Len : aliased C.int := Sin'Size / 8;
1310    begin
1311       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
1312          Raise_Socket_Error (Socket_Errno);
1313       end if;
1314
1315       return Get_Address (Sin, Len);
1316    end Get_Peer_Name;
1317
1318    -------------------------
1319    -- Get_Service_By_Name --
1320    -------------------------
1321
1322    function Get_Service_By_Name
1323      (Name     : String;
1324       Protocol : String) return Service_Entry_Type
1325    is
1326       SN     : constant C.char_array := C.To_C (Name);
1327       SP     : constant C.char_array := C.To_C (Protocol);
1328       Buflen : constant C.int := Netdb_Buffer_Size;
1329       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1330       Res    : aliased Servent;
1331
1332    begin
1333       Netdb_Lock;
1334
1335       if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
1336          Netdb_Unlock;
1337          raise Service_Error with "Service not found";
1338       end if;
1339
1340       --  Translate from the C format to the API format
1341
1342       return S : constant Service_Entry_Type :=
1343                    To_Service_Entry (Res'Unchecked_Access)
1344       do
1345          Netdb_Unlock;
1346       end return;
1347    end Get_Service_By_Name;
1348
1349    -------------------------
1350    -- Get_Service_By_Port --
1351    -------------------------
1352
1353    function Get_Service_By_Port
1354      (Port     : Port_Type;
1355       Protocol : String) return Service_Entry_Type
1356    is
1357       SP     : constant C.char_array := C.To_C (Protocol);
1358       Buflen : constant C.int := Netdb_Buffer_Size;
1359       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
1360       Res    : aliased Servent;
1361
1362    begin
1363       Netdb_Lock;
1364
1365       if C_Getservbyport
1366         (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
1367          Res'Access, Buf'Address, Buflen) /= 0
1368       then
1369          Netdb_Unlock;
1370          raise Service_Error with "Service not found";
1371       end if;
1372
1373       --  Translate from the C format to the API format
1374
1375       return S : constant Service_Entry_Type :=
1376                    To_Service_Entry (Res'Unchecked_Access)
1377       do
1378          Netdb_Unlock;
1379       end return;
1380    end Get_Service_By_Port;
1381
1382    ---------------------
1383    -- Get_Socket_Name --
1384    ---------------------
1385
1386    function Get_Socket_Name
1387      (Socket : Socket_Type) return Sock_Addr_Type
1388    is
1389       Sin : aliased Sockaddr;
1390       Len : aliased C.int := Sin'Size / 8;
1391       Res : C.int;
1392    begin
1393       Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
1394
1395       if Res = Failure then
1396          return No_Sock_Addr;
1397       end if;
1398
1399       return Get_Address (Sin, Len);
1400    end Get_Socket_Name;
1401
1402    -----------------------
1403    -- Get_Socket_Option --
1404    -----------------------
1405
1406    function Get_Socket_Option
1407      (Socket  : Socket_Type;
1408       Level   : Level_Type;
1409       Name    : Option_Name;
1410       Optname : Interfaces.C.int := -1) return Option_Type
1411    is
1412       use type C.unsigned;
1413       use type C.unsigned_char;
1414
1415       V8  : aliased Two_Ints;
1416       V4  : aliased C.int;
1417       U4  : aliased C.unsigned;
1418       V1  : aliased C.unsigned_char;
1419       VT  : aliased Timeval;
1420       Len : aliased C.int;
1421       Add : System.Address;
1422       Res : C.int;
1423       Opt : Option_Type (Name);
1424       Onm : Interfaces.C.int;
1425
1426    begin
1427       if Name in Specific_Option_Name then
1428          Onm := Options (Name);
1429
1430       elsif Optname = -1 then
1431          raise Socket_Error with "optname must be specified";
1432
1433       else
1434          Onm := Optname;
1435       end if;
1436
1437       case Name is
1438          when Multicast_TTL
1439             | Receive_Packet_Info
1440          =>
1441             Len := V1'Size / 8;
1442             Add := V1'Address;
1443
1444          when Broadcast
1445             | Busy_Polling
1446             | Error
1447             | Generic_Option
1448             | Keep_Alive
1449             | Multicast_If_V4
1450             | Multicast_If_V6
1451             | Multicast_Loop_V4
1452             | Multicast_Loop_V6
1453             | Multicast_Hops
1454             | No_Delay
1455             | Receive_Buffer
1456             | Reuse_Address
1457             | Send_Buffer
1458             | IPv6_Only
1459          =>
1460             Len := V4'Size / 8;
1461             Add := V4'Address;
1462
1463          when Receive_Timeout
1464             | Send_Timeout
1465          =>
1466             --  The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
1467             --  struct timeval, but on Windows it is a milliseconds count in
1468             --  a DWORD.
1469
1470             if Is_Windows then
1471                Len := U4'Size / 8;
1472                Add := U4'Address;
1473             else
1474                Len := VT'Size / 8;
1475                Add := VT'Address;
1476             end if;
1477
1478          when Add_Membership_V4
1479             | Add_Membership_V6
1480             | Drop_Membership_V4
1481             | Drop_Membership_V6
1482          =>
1483             raise Socket_Error with
1484               "Add/Drop membership valid only for Set_Socket_Option";
1485
1486          when Linger
1487          =>
1488             Len := V8'Size / 8;
1489             Add := V8'Address;
1490       end case;
1491
1492       Res :=
1493         C_Getsockopt
1494           (C.int (Socket),
1495            Levels (Level),
1496            Onm,
1497            Add, Len'Access);
1498
1499       if Res = Failure then
1500          Raise_Socket_Error (Socket_Errno);
1501       end if;
1502
1503       case Name is
1504          when Generic_Option =>
1505             Opt.Optname := Onm;
1506             Opt.Optval  := V4;
1507
1508          when Broadcast
1509             | Keep_Alive
1510             | No_Delay
1511             | Reuse_Address
1512             | Multicast_Loop_V4
1513             | Multicast_Loop_V6
1514             | IPv6_Only
1515          =>
1516             Opt.Enabled := (V4 /= 0);
1517
1518          when Busy_Polling =>
1519             Opt.Microseconds := Natural (V4);
1520
1521          when Linger =>
1522             Opt.Enabled := (V8 (V8'First) /= 0);
1523             Opt.Seconds := Natural (V8 (V8'Last));
1524
1525          when Receive_Buffer
1526             | Send_Buffer
1527          =>
1528             Opt.Size := Natural (V4);
1529
1530          when Error =>
1531             Opt.Error := Resolve_Error (Integer (V4));
1532
1533          when Add_Membership_V4
1534             | Add_Membership_V6
1535             | Drop_Membership_V4
1536             | Drop_Membership_V6
1537          =>
1538             --  No way to be here. Exception raised in the first case Name
1539             --  expression.
1540             null;
1541
1542          when Multicast_If_V4 =>
1543             To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1544
1545          when Multicast_If_V6 =>
1546             Opt.Outgoing_If_Index := Natural (V4);
1547
1548          when Multicast_TTL =>
1549             Opt.Time_To_Live := Integer (V1);
1550
1551          when Multicast_Hops =>
1552             Opt.Hop_Limit := Integer (V4);
1553
1554          when Receive_Packet_Info
1555          =>
1556             Opt.Enabled := (V1 /= 0);
1557
1558          when Receive_Timeout
1559             | Send_Timeout
1560          =>
1561             if Is_Windows then
1562
1563                --  Timeout is in milliseconds, actual value is 500 ms +
1564                --  returned value (unless it is 0).
1565
1566                if U4 = 0 then
1567                   Opt.Timeout := 0.0;
1568                else
1569                   Opt.Timeout :=  Duration (U4) / 1000 + 0.500;
1570                end if;
1571
1572             else
1573                Opt.Timeout := To_Duration (VT);
1574             end if;
1575       end case;
1576
1577       return Opt;
1578    end Get_Socket_Option;
1579
1580    ---------------
1581    -- Host_Name --
1582    ---------------
1583
1584    function Host_Name return String is
1585       Name : aliased C.char_array (1 .. 64);
1586       Res  : C.int;
1587
1588    begin
1589       Res := C_Gethostname (Name'Address, Name'Length);
1590
1591       if Res = Failure then
1592          Raise_Socket_Error (Socket_Errno);
1593       end if;
1594
1595       return C.To_Ada (Name);
1596    end Host_Name;
1597
1598    -----------
1599    -- Image --
1600    -----------
1601
1602    function Image (Value : Inet_Addr_Type) return String is
1603       use type CS.char_array_access;
1604       Size : constant socklen_t :=
1605         (case Value.Family is
1606             when Family_Inet   => 4 * Value.Sin_V4'Length,
1607             when Family_Inet6  => 6 * 5 + 4 * 4);
1608             --  1234:1234:1234:1234:1234:1234:123.123.123.123
1609       Dst : aliased C.char_array := (1 .. C.size_t (Size) => C.nul);
1610       Ia  : aliased In_Addr_Union (Value.Family);
1611    begin
1612       case Value.Family is
1613          when Family_Inet6 =>
1614             Ia.In6 := To_In6_Addr (Value);
1615          when Family_Inet =>
1616             Ia.In4 := To_In_Addr (Value);
1617       end case;
1618
1619       if Inet_Ntop
1620         (Families (Value.Family), Ia'Address,
1621          Dst'Unchecked_Access, Size) = null
1622       then
1623          Raise_Socket_Error (Socket_Errno);
1624       end if;
1625
1626       return C.To_Ada (Dst);
1627    end Image;
1628
1629    -----------
1630    -- Image --
1631    -----------
1632
1633    function Image (Value : Sock_Addr_Type) return String is
1634       function Ipv6_Brackets (S : String) return String is
1635         (if Value.Family = Family_Inet6 then "[" & S & "]" else S);
1636    begin
1637       case Value.Family is
1638          when Family_Unix =>
1639             if ASU.Length (Value.Name) > 0
1640               and then ASU.Element (Value.Name, 1) = ASCII.NUL
1641             then
1642                return '@' & ASU.Slice (Value.Name, 2, ASU.Length (Value.Name));
1643             else
1644                return ASU.To_String (Value.Name);
1645             end if;
1646
1647          when Family_Inet_4_6 =>
1648             declare
1649                Port : constant String := Value.Port'Img;
1650             begin
1651                return Ipv6_Brackets (Image (Value.Addr)) & ':'
1652                  & Port (2 .. Port'Last);
1653             end;
1654
1655          when Family_Unspec =>
1656             return "";
1657       end case;
1658    end Image;
1659
1660    -----------
1661    -- Image --
1662    -----------
1663
1664    function Image (Socket : Socket_Type) return String is
1665    begin
1666       return Socket'Img;
1667    end Image;
1668
1669    -----------
1670    -- Image --
1671    -----------
1672
1673    function Image (Item : Socket_Set_Type) return String is
1674       Socket_Set : Socket_Set_Type := Item;
1675
1676    begin
1677       declare
1678          Last_Img : constant String := Socket_Set.Last'Img;
1679          Buffer   : String
1680                       (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
1681          Index    : Positive := 1;
1682          Socket   : Socket_Type;
1683
1684       begin
1685          while not Is_Empty (Socket_Set) loop
1686             Get (Socket_Set, Socket);
1687
1688             declare
1689                Socket_Img : constant String := Socket'Img;
1690             begin
1691                Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
1692                Index := Index + Socket_Img'Length;
1693             end;
1694          end loop;
1695
1696          return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
1697       end;
1698    end Image;
1699
1700    ---------------
1701    -- Inet_Addr --
1702    ---------------
1703
1704    function Inet_Addr (Image : String) return Inet_Addr_Type is
1705       use Interfaces.C;
1706
1707       Img    : aliased char_array := To_C (Image);
1708       Res    : C.int;
1709       Result : Inet_Addr_Type;
1710       IPv6   : constant Boolean := Is_IPv6_Address (Image);
1711       Ia     : aliased In_Addr_Union
1712                  (if IPv6 then Family_Inet6 else Family_Inet);
1713    begin
1714       --  Special case for an empty Image as on some platforms (e.g. Windows)
1715       --  calling Inet_Addr("") will not return an error.
1716
1717       if Image = "" then
1718          Raise_Socket_Error (SOSC.EINVAL);
1719       end if;
1720
1721       Res := Inet_Pton
1722         ((if IPv6 then SOSC.AF_INET6 else SOSC.AF_INET), Img'Address,
1723          Ia'Address);
1724
1725       if Res < 0 then
1726          Raise_Socket_Error (Socket_Errno);
1727
1728       elsif Res = 0 then
1729          Raise_Socket_Error (SOSC.EINVAL);
1730       end if;
1731
1732       if IPv6 then
1733          To_Inet_Addr (Ia.In6, Result);
1734       else
1735          To_Inet_Addr (Ia.In4, Result);
1736       end if;
1737
1738       return Result;
1739    end Inet_Addr;
1740
1741    ----------------
1742    -- Initialize --
1743    ----------------
1744
1745    procedure Initialize (X : in out Sockets_Library_Controller) is
1746       pragma Unreferenced (X);
1747
1748    begin
1749       Thin.Initialize;
1750    end Initialize;
1751
1752    ----------------
1753    -- Initialize --
1754    ----------------
1755
1756    procedure Initialize (Process_Blocking_IO : Boolean) is
1757       Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
1758
1759    begin
1760       if Process_Blocking_IO /= Expected then
1761          raise Socket_Error with
1762            "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1763       end if;
1764
1765       --  This is a dummy placeholder for an obsolete API
1766
1767       --  Real initialization actions are in Initialize primitive operation
1768       --  of Sockets_Library_Controller.
1769
1770       null;
1771    end Initialize;
1772
1773    ----------------
1774    -- Initialize --
1775    ----------------
1776
1777    procedure Initialize is
1778    begin
1779       --  This is a dummy placeholder for an obsolete API
1780
1781       --  Real initialization actions are in Initialize primitive operation
1782       --  of Sockets_Library_Controller.
1783
1784       null;
1785    end Initialize;
1786
1787    ----------------
1788    -- Is_Windows --
1789    ----------------
1790
1791    function Is_Windows return Boolean is
1792       use SOSC;
1793    begin
1794       return Target_OS = Windows;
1795    end Is_Windows;
1796
1797    --------------
1798    -- Is_Empty --
1799    --------------
1800
1801    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1802    begin
1803       return Item.Last = No_Socket;
1804    end Is_Empty;
1805
1806    ---------------------
1807    -- Is_IPv6_Address --
1808    ---------------------
1809
1810    function Is_IPv6_Address (Name : String) return Boolean is
1811       Prev_Colon   : Natural := 0;
1812       Double_Colon : Boolean := False;
1813       Colons       : Natural := 0;
1814    begin
1815       for J in Name'Range loop
1816          if Name (J) = ':' then
1817             Colons := Colons + 1;
1818
1819             if Prev_Colon > 0 and then J = Prev_Colon + 1 then
1820                if Double_Colon then
1821                   --  Only one double colon allowed
1822                   return False;
1823                end if;
1824
1825                Double_Colon := True;
1826
1827             elsif J = Name'Last then
1828                --  Single colon at the end is not allowed
1829                return False;
1830             end if;
1831
1832             Prev_Colon := J;
1833
1834          elsif Prev_Colon = Name'First then
1835             --  Single colon at start is not allowed
1836             return False;
1837
1838          elsif Name (J) = '.' then
1839             return Prev_Colon > 0
1840               and then Is_IPv4_Address (Name (Prev_Colon + 1 .. Name'Last));
1841
1842          elsif Name (J) not in '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' then
1843             return False;
1844
1845          end if;
1846       end loop;
1847
1848       return Colons in 2 .. 8;
1849    end Is_IPv6_Address;
1850
1851    ---------------------
1852    -- Is_IPv4_Address --
1853    ---------------------
1854
1855    function Is_IPv4_Address (Name : String) return Boolean is
1856       Dots : Natural := 0;
1857
1858    begin
1859       --  Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
1860       --  and there must be at least one digit around each.
1861
1862       for J in Name'Range loop
1863          if Name (J) = '.' then
1864
1865             --  Check that the dot is not in first or last position, and that
1866             --  it is followed by a digit. Note that we already know that it is
1867             --  preceded by a digit, or we would have returned earlier on.
1868
1869             if J in Name'First + 1 .. Name'Last - 1
1870               and then Name (J + 1) in '0' .. '9'
1871             then
1872                Dots := Dots + 1;
1873
1874             --  Definitely not a proper dotted quad
1875
1876             else
1877                return False;
1878             end if;
1879
1880          elsif Name (J) not in '0' .. '9' then
1881             return False;
1882          end if;
1883       end loop;
1884
1885       return Dots in 1 .. 3;
1886    end Is_IPv4_Address;
1887
1888    -------------
1889    -- Is_Open --
1890    -------------
1891
1892    function Is_Open (S : Selector_Type) return Boolean is
1893    begin
1894       if S.Is_Null then
1895          return True;
1896
1897       else
1898          --  Either both controlling socket descriptors are valid (case of an
1899          --  open selector) or neither (case of a closed selector).
1900
1901          pragma Assert ((S.R_Sig_Socket /= No_Socket)
1902                           =
1903                         (S.W_Sig_Socket /= No_Socket));
1904
1905          return S.R_Sig_Socket /= No_Socket;
1906       end if;
1907    end Is_Open;
1908
1909    ------------
1910    -- Is_Set --
1911    ------------
1912
1913    function Is_Set
1914      (Item   : Socket_Set_Type;
1915       Socket : Socket_Type) return Boolean
1916    is
1917    begin
1918       Check_For_Fd_Set (Socket);
1919
1920       return Item.Last /= No_Socket
1921         and then Socket <= Item.Last
1922         and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
1923    end Is_Set;
1924
1925    -------------------
1926    -- Listen_Socket --
1927    -------------------
1928
1929    procedure Listen_Socket
1930      (Socket : Socket_Type;
1931       Length : Natural := 15)
1932    is
1933       Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1934    begin
1935       if Res = Failure then
1936          Raise_Socket_Error (Socket_Errno);
1937       end if;
1938    end Listen_Socket;
1939
1940    ------------
1941    -- Narrow --
1942    ------------
1943
1944    procedure Narrow (Item : in out Socket_Set_Type) is
1945       Last : aliased C.int := C.int (Item.Last);
1946    begin
1947       if Item.Last /= No_Socket then
1948          Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access);
1949          Item.Last := Socket_Type (Last);
1950       end if;
1951    end Narrow;
1952
1953    ----------------
1954    -- Netdb_Lock --
1955    ----------------
1956
1957    procedure Netdb_Lock is
1958    begin
1959       if Need_Netdb_Lock then
1960          System.Task_Lock.Lock;
1961       end if;
1962    end Netdb_Lock;
1963
1964    ------------------
1965    -- Netdb_Unlock --
1966    ------------------
1967
1968    procedure Netdb_Unlock is
1969    begin
1970       if Need_Netdb_Lock then
1971          System.Task_Lock.Unlock;
1972       end if;
1973    end Netdb_Unlock;
1974
1975    ----------------------------
1976    -- Network_Socket_Address --
1977    ----------------------------
1978
1979    function Network_Socket_Address
1980      (Addr : Inet_Addr_Type; Port : Port_Type) return Sock_Addr_Type is
1981    begin
1982       return Result : Sock_Addr_Type (Addr.Family) do
1983          Result.Addr := Addr;
1984          Result.Port := Port;
1985       end return;
1986    end Network_Socket_Address;
1987
1988    --------------------------------
1989    -- Normalize_Empty_Socket_Set --
1990    --------------------------------
1991
1992    procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is
1993    begin
1994       if S.Last = No_Socket then
1995          Reset_Socket_Set (S.Set'Access);
1996       end if;
1997    end Normalize_Empty_Socket_Set;
1998
1999    -------------------
2000    -- Official_Name --
2001    -------------------
2002
2003    function Official_Name (E : Host_Entry_Type) return String is
2004    begin
2005       return To_String (E.Official);
2006    end Official_Name;
2007
2008    -------------------
2009    -- Official_Name --
2010    -------------------
2011
2012    function Official_Name (S : Service_Entry_Type) return String is
2013    begin
2014       return To_String (S.Official);
2015    end Official_Name;
2016
2017    --------------------
2018    -- Wait_On_Socket --
2019    --------------------
2020
2021    procedure Wait_On_Socket
2022      (Socket   : Socket_Type;
2023       For_Read : Boolean;
2024       Timeout  : Selector_Duration;
2025       Selector : access Selector_Type := null;
2026       Status   : out Selector_Status)
2027    is
2028       type Local_Selector_Access is access Selector_Type;
2029       for Local_Selector_Access'Storage_Size use Selector_Type'Size;
2030
2031       S : Selector_Access;
2032       --  Selector to use for waiting
2033
2034       R_Fd_Set : Socket_Set_Type;
2035       W_Fd_Set : Socket_Set_Type;
2036
2037    begin
2038       --  Create selector if not provided by the user
2039
2040       if Selector = null then
2041          declare
2042             Local_S : constant Local_Selector_Access := new Selector_Type;
2043          begin
2044             S := Local_S.all'Unchecked_Access;
2045             Create_Selector (S.all);
2046          end;
2047
2048       else
2049          S := Selector.all'Access;
2050       end if;
2051
2052       if For_Read then
2053          Set (R_Fd_Set, Socket);
2054       else
2055          Set (W_Fd_Set, Socket);
2056       end if;
2057
2058       Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout);
2059
2060       if Selector = null then
2061          Close_Selector (S.all);
2062       end if;
2063    end Wait_On_Socket;
2064
2065    -----------------
2066    -- Port_Number --
2067    -----------------
2068
2069    function Port_Number (S : Service_Entry_Type) return Port_Type is
2070    begin
2071       return S.Port;
2072    end Port_Number;
2073
2074    -------------------
2075    -- Protocol_Name --
2076    -------------------
2077
2078    function Protocol_Name (S : Service_Entry_Type) return String is
2079    begin
2080       return To_String (S.Protocol);
2081    end Protocol_Name;
2082
2083    ----------------------
2084    -- Raise_Host_Error --
2085    ----------------------
2086
2087    procedure Raise_Host_Error (H_Error : Integer; Name : String) is
2088    begin
2089       raise Host_Error with
2090         Err_Code_Image (H_Error)
2091           & Dedot (Host_Error_Messages.Host_Error_Message (H_Error))
2092           & ": " & Name;
2093    end Raise_Host_Error;
2094
2095    ------------------------
2096    -- Raise_Socket_Error --
2097    ------------------------
2098
2099    procedure Raise_Socket_Error (Error : Integer) is
2100    begin
2101       raise Socket_Error with
2102         Err_Code_Image (Error) & Socket_Error_Message (Error);
2103    end Raise_Socket_Error;
2104
2105    ----------
2106    -- Read --
2107    ----------
2108
2109    procedure Read
2110      (Stream : in out Datagram_Socket_Stream_Type;
2111       Item   : out Ada.Streams.Stream_Element_Array;
2112       Last   : out Ada.Streams.Stream_Element_Offset)
2113    is
2114    begin
2115       Receive_Socket
2116         (Stream.Socket,
2117          Item,
2118          Last,
2119          Stream.From);
2120    end Read;
2121
2122    ----------
2123    -- Read --
2124    ----------
2125
2126    procedure Read
2127      (Stream : in out Stream_Socket_Stream_Type;
2128       Item   : out Ada.Streams.Stream_Element_Array;
2129       Last   : out Ada.Streams.Stream_Element_Offset)
2130    is
2131       First : Ada.Streams.Stream_Element_Offset          := Item'First;
2132       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
2133       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2134
2135    begin
2136       loop
2137          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
2138          Last  := Index;
2139
2140          --  Exit when all or zero data received. Zero means that the socket
2141          --  peer is closed.
2142
2143          exit when Index < First or else Index = Max;
2144
2145          First := Index + 1;
2146       end loop;
2147    end Read;
2148
2149    --------------------
2150    -- Receive_Socket --
2151    --------------------
2152
2153    procedure Receive_Socket
2154      (Socket : Socket_Type;
2155       Item   : out Ada.Streams.Stream_Element_Array;
2156       Last   : out Ada.Streams.Stream_Element_Offset;
2157       Flags  : Request_Flag_Type := No_Request_Flag)
2158    is
2159       Res : C.int;
2160
2161    begin
2162       Res :=
2163         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
2164
2165       if Res = Failure then
2166          Raise_Socket_Error (Socket_Errno);
2167       end if;
2168
2169       Last := Last_Index (First => Item'First, Count => size_t (Res));
2170    end Receive_Socket;
2171
2172    --------------------
2173    -- Receive_Socket --
2174    --------------------
2175
2176    procedure Receive_Socket
2177      (Socket : Socket_Type;
2178       Item   : out Ada.Streams.Stream_Element_Array;
2179       Last   : out Ada.Streams.Stream_Element_Offset;
2180       From   : out Sock_Addr_Type;
2181       Flags  : Request_Flag_Type := No_Request_Flag)
2182    is
2183       Res : C.int;
2184       Sin : aliased Sockaddr;
2185       Len : aliased C.int := Sin'Size / 8;
2186
2187    begin
2188       Res :=
2189         C_Recvfrom
2190           (C.int (Socket),
2191            Item'Address,
2192            Item'Length,
2193            To_Int (Flags),
2194            Sin'Address,
2195            Len'Access);
2196
2197       if Res = Failure then
2198          Raise_Socket_Error (Socket_Errno);
2199       end if;
2200
2201       Last := Last_Index (First => Item'First, Count => size_t (Res));
2202
2203       From := Get_Address (Sin, Len);
2204    end Receive_Socket;
2205
2206    --------------------
2207    -- Receive_Vector --
2208    --------------------
2209
2210    procedure Receive_Vector
2211      (Socket : Socket_Type;
2212       Vector : Vector_Type;
2213       Count  : out Ada.Streams.Stream_Element_Count;
2214       Flags  : Request_Flag_Type := No_Request_Flag)
2215    is
2216       Res : ssize_t;
2217
2218       Msg : Msghdr :=
2219               (Msg_Name       => System.Null_Address,
2220                Msg_Namelen    => 0,
2221                Msg_Iov        => Vector'Address,
2222
2223                --  recvmsg(2) returns EMSGSIZE on Linux (and probably on other
2224                --  platforms) when the supplied vector is longer than IOV_MAX,
2225                --  so use minimum of the two lengths.
2226
2227                Msg_Iovlen     => SOSC.Msg_Iovlen_T'Min
2228                                    (Vector'Length, SOSC.IOV_MAX),
2229
2230                Msg_Control    => System.Null_Address,
2231                Msg_Controllen => 0,
2232                Msg_Flags      => 0);
2233
2234    begin
2235       Res :=
2236         C_Recvmsg
2237           (C.int (Socket),
2238            Msg'Address,
2239            To_Int (Flags));
2240
2241       if Res = ssize_t (Failure) then
2242          Raise_Socket_Error (Socket_Errno);
2243       end if;
2244
2245       Count := Ada.Streams.Stream_Element_Count (Res);
2246    end Receive_Vector;
2247
2248    -------------------
2249    -- Resolve_Error --
2250    -------------------
2251
2252    function Resolve_Error
2253      (Error_Value : Integer;
2254       From_Errno  : Boolean := True) return Error_Type
2255    is
2256       use GNAT.Sockets.SOSC;
2257
2258    begin
2259       if not From_Errno then
2260          case Error_Value is
2261             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
2262             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
2263             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
2264             when SOSC.NO_DATA        => return Unknown_Server_Error;
2265             when others              => return Cannot_Resolve_Error;
2266          end case;
2267       end if;
2268
2269       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
2270       --  can't include it in the case statement below.
2271
2272       pragma Warnings (Off);
2273       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
2274
2275       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
2276          return Resource_Temporarily_Unavailable;
2277       end if;
2278
2279       --  This is not a case statement because if a particular error
2280       --  number constant is not defined, s-oscons-tmplt.c defines
2281       --  it to -1.  If multiple constants are not defined, they
2282       --  would each be -1 and result in a "duplicate value in case" error.
2283       --
2284       --  But we have to leave warnings off because the compiler is also
2285       --  smart enough to note that when two errnos have the same value,
2286       --  the second if condition is useless.
2287       if Error_Value = ENOERROR then
2288          return Success;
2289       elsif Error_Value = EACCES then
2290          return Permission_Denied;
2291       elsif Error_Value = EADDRINUSE then
2292          return Address_Already_In_Use;
2293       elsif Error_Value = EADDRNOTAVAIL then
2294          return Cannot_Assign_Requested_Address;
2295       elsif Error_Value = EAFNOSUPPORT then
2296          return Address_Family_Not_Supported_By_Protocol;
2297       elsif Error_Value = EALREADY then
2298          return Operation_Already_In_Progress;
2299       elsif Error_Value = EBADF then
2300          return Bad_File_Descriptor;
2301       elsif Error_Value = ECONNABORTED then
2302          return Software_Caused_Connection_Abort;
2303       elsif Error_Value = ECONNREFUSED then
2304          return Connection_Refused;
2305       elsif Error_Value = ECONNRESET then
2306          return Connection_Reset_By_Peer;
2307       elsif Error_Value = EDESTADDRREQ then
2308          return Destination_Address_Required;
2309       elsif Error_Value = EFAULT then
2310          return Bad_Address;
2311       elsif Error_Value = EHOSTDOWN then
2312          return Host_Is_Down;
2313       elsif Error_Value = EHOSTUNREACH then
2314          return No_Route_To_Host;
2315       elsif Error_Value = EINPROGRESS then
2316          return Operation_Now_In_Progress;
2317       elsif Error_Value = EINTR then
2318          return Interrupted_System_Call;
2319       elsif Error_Value = EINVAL then
2320          return Invalid_Argument;
2321       elsif Error_Value = EIO then
2322          return Input_Output_Error;
2323       elsif Error_Value = EISCONN then
2324          return Transport_Endpoint_Already_Connected;
2325       elsif Error_Value = ELOOP then
2326          return Too_Many_Symbolic_Links;
2327       elsif Error_Value = EMFILE then
2328          return Too_Many_Open_Files;
2329       elsif Error_Value = EMSGSIZE then
2330          return Message_Too_Long;
2331       elsif Error_Value = ENAMETOOLONG then
2332          return File_Name_Too_Long;
2333       elsif Error_Value = ENETDOWN then
2334          return Network_Is_Down;
2335       elsif Error_Value = ENETRESET then
2336          return Network_Dropped_Connection_Because_Of_Reset;
2337       elsif Error_Value = ENETUNREACH then
2338          return Network_Is_Unreachable;
2339       elsif Error_Value = ENOBUFS then
2340          return No_Buffer_Space_Available;
2341       elsif Error_Value = ENOPROTOOPT then
2342          return Protocol_Not_Available;
2343       elsif Error_Value = ENOTCONN then
2344          return Transport_Endpoint_Not_Connected;
2345       elsif Error_Value = ENOTSOCK then
2346          return Socket_Operation_On_Non_Socket;
2347       elsif Error_Value = EOPNOTSUPP then
2348          return Operation_Not_Supported;
2349       elsif Error_Value = EPFNOSUPPORT then
2350          return Protocol_Family_Not_Supported;
2351       elsif Error_Value = EPIPE then
2352          return Broken_Pipe;
2353       elsif Error_Value = EPROTONOSUPPORT then
2354          return Protocol_Not_Supported;
2355       elsif Error_Value = EPROTOTYPE then
2356          return Protocol_Wrong_Type_For_Socket;
2357       elsif Error_Value = ESHUTDOWN then
2358          return Cannot_Send_After_Transport_Endpoint_Shutdown;
2359       elsif Error_Value = ESOCKTNOSUPPORT then
2360          return Socket_Type_Not_Supported;
2361       elsif Error_Value = ETIMEDOUT then
2362          return Connection_Timed_Out;
2363       elsif Error_Value = ETOOMANYREFS then
2364          return Too_Many_References;
2365       elsif Error_Value = EWOULDBLOCK then
2366          return Resource_Temporarily_Unavailable;
2367       else
2368          return Cannot_Resolve_Error;
2369       end if;
2370       pragma Warnings (On);
2371
2372    end Resolve_Error;
2373
2374    -----------------------
2375    -- Resolve_Exception --
2376    -----------------------
2377
2378    function Resolve_Exception
2379      (Occurrence : Exception_Occurrence) return Error_Type
2380    is
2381       Id    : constant Exception_Id := Exception_Identity (Occurrence);
2382       Msg   : constant String       := Exception_Message (Occurrence);
2383       First : Natural;
2384       Last  : Natural;
2385       Val   : Integer;
2386
2387    begin
2388       First := Msg'First;
2389       while First <= Msg'Last
2390         and then Msg (First) not in '0' .. '9'
2391       loop
2392          First := First + 1;
2393       end loop;
2394
2395       if First > Msg'Last then
2396          return Cannot_Resolve_Error;
2397       end if;
2398
2399       Last := First;
2400       while Last < Msg'Last
2401         and then Msg (Last + 1) in '0' .. '9'
2402       loop
2403          Last := Last + 1;
2404       end loop;
2405
2406       Val := Integer'Value (Msg (First .. Last));
2407
2408       if Id = Socket_Error_Id then
2409          return Resolve_Error (Val);
2410
2411       elsif Id = Host_Error_Id then
2412          return Resolve_Error (Val, False);
2413
2414       else
2415          return Cannot_Resolve_Error;
2416       end if;
2417    end Resolve_Exception;
2418
2419    -----------------
2420    -- Send_Socket --
2421    -----------------
2422
2423    procedure Send_Socket
2424      (Socket : Socket_Type;
2425       Item   : Ada.Streams.Stream_Element_Array;
2426       Last   : out Ada.Streams.Stream_Element_Offset;
2427       Flags  : Request_Flag_Type := No_Request_Flag)
2428    is
2429    begin
2430       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
2431    end Send_Socket;
2432
2433    -----------------
2434    -- Send_Socket --
2435    -----------------
2436
2437    procedure Send_Socket
2438      (Socket : Socket_Type;
2439       Item   : Ada.Streams.Stream_Element_Array;
2440       Last   : out Ada.Streams.Stream_Element_Offset;
2441       To     : Sock_Addr_Type;
2442       Flags  : Request_Flag_Type := No_Request_Flag)
2443    is
2444    begin
2445       Send_Socket
2446         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
2447    end Send_Socket;
2448
2449    -----------------
2450    -- Send_Socket --
2451    -----------------
2452
2453    procedure Send_Socket
2454      (Socket : Socket_Type;
2455       Item   : Ada.Streams.Stream_Element_Array;
2456       Last   : out Ada.Streams.Stream_Element_Offset;
2457       To     : access Sock_Addr_Type;
2458       Flags  : Request_Flag_Type := No_Request_Flag)
2459    is
2460       Res  : C.int;
2461
2462       Sin  : aliased Sockaddr;
2463       C_To : System.Address;
2464       Len  : C.int;
2465
2466    begin
2467       if To /= null then
2468          Set_Address (Sin'Unchecked_Access, To.all, Len);
2469          C_To := Sin'Address;
2470
2471       else
2472          C_To := System.Null_Address;
2473          Len := 0;
2474       end if;
2475
2476       Res := C_Sendto
2477         (C.int (Socket),
2478          Item'Address,
2479          Item'Length,
2480          Set_Forced_Flags (To_Int (Flags)),
2481          C_To,
2482          Len);
2483
2484       if Res = Failure then
2485          Raise_Socket_Error (Socket_Errno);
2486       end if;
2487
2488       Last := Last_Index (First => Item'First, Count => size_t (Res));
2489    end Send_Socket;
2490
2491    -----------------
2492    -- Send_Vector --
2493    -----------------
2494
2495    procedure Send_Vector
2496      (Socket : Socket_Type;
2497       Vector : Vector_Type;
2498       Count  : out Ada.Streams.Stream_Element_Count;
2499       Flags  : Request_Flag_Type := No_Request_Flag)
2500    is
2501       use Interfaces.C;
2502
2503       Res            : ssize_t;
2504       Iov_Count      : SOSC.Msg_Iovlen_T;
2505       This_Iov_Count : SOSC.Msg_Iovlen_T;
2506       Msg            : Msghdr;
2507
2508    begin
2509       Count := 0;
2510       Iov_Count := 0;
2511       while Iov_Count < Vector'Length loop
2512
2513          pragma Warnings (Off);
2514          --  Following test may be compile time known on some targets
2515
2516          This_Iov_Count :=
2517            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
2518             then SOSC.IOV_MAX
2519             else Vector'Length - Iov_Count);
2520
2521          pragma Warnings (On);
2522
2523          Msg :=
2524            (Msg_Name       => System.Null_Address,
2525             Msg_Namelen    => 0,
2526             Msg_Iov        => Vector
2527                                 (Vector'First + Integer (Iov_Count))'Address,
2528             Msg_Iovlen     => This_Iov_Count,
2529             Msg_Control    => System.Null_Address,
2530             Msg_Controllen => 0,
2531             Msg_Flags      => 0);
2532
2533          Res :=
2534            C_Sendmsg
2535              (C.int (Socket),
2536               Msg'Address,
2537               Set_Forced_Flags (To_Int (Flags)));
2538
2539          if Res = ssize_t (Failure) then
2540             Raise_Socket_Error (Socket_Errno);
2541          end if;
2542
2543          Count := Count + Ada.Streams.Stream_Element_Count (Res);
2544          Iov_Count := Iov_Count + This_Iov_Count;
2545       end loop;
2546    end Send_Vector;
2547
2548    ---------
2549    -- Set --
2550    ---------
2551
2552    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
2553    begin
2554       Check_For_Fd_Set (Socket);
2555
2556       if Item.Last = No_Socket then
2557
2558          --  Uninitialized socket set, make sure it is properly zeroed out
2559
2560          Reset_Socket_Set (Item.Set'Access);
2561          Item.Last := Socket;
2562
2563       elsif Item.Last < Socket then
2564          Item.Last := Socket;
2565       end if;
2566
2567       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
2568    end Set;
2569
2570    -----------------------
2571    -- Set_Close_On_Exec --
2572    -----------------------
2573
2574    procedure Set_Close_On_Exec
2575      (Socket        : Socket_Type;
2576       Close_On_Exec : Boolean;
2577       Status        : out Boolean)
2578    is
2579       function C_Set_Close_On_Exec
2580         (Socket : Socket_Type; Close_On_Exec : C.int) return C.int;
2581       pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2582    begin
2583       Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0;
2584    end Set_Close_On_Exec;
2585
2586    ----------------------
2587    -- Set_Forced_Flags --
2588    ----------------------
2589
2590    function Set_Forced_Flags (F : C.int) return C.int is
2591       use type C.unsigned;
2592       function To_unsigned is
2593         new Ada.Unchecked_Conversion (C.int, C.unsigned);
2594       function To_int is
2595         new Ada.Unchecked_Conversion (C.unsigned, C.int);
2596    begin
2597       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
2598    end Set_Forced_Flags;
2599
2600    -----------------------
2601    -- Set_Socket_Option --
2602    -----------------------
2603
2604    procedure Set_Socket_Option
2605      (Socket : Socket_Type;
2606       Level  : Level_Type;
2607       Option : Option_Type)
2608    is
2609       use type C.unsigned;
2610
2611       MR  : aliased IPV6_Mreq;
2612       V8  : aliased Two_Ints;
2613       V4  : aliased C.int;
2614       U4  : aliased C.unsigned;
2615       V1  : aliased C.unsigned_char;
2616       VT  : aliased Timeval;
2617       Len : C.int;
2618       Add : System.Address := Null_Address;
2619       Res : C.int;
2620       Onm : C.int;
2621
2622    begin
2623       case Option.Name is
2624          when Generic_Option =>
2625             V4  := Option.Optval;
2626             Len := V4'Size / 8;
2627             Add := V4'Address;
2628
2629          when Broadcast
2630             | Keep_Alive
2631             | No_Delay
2632             | Reuse_Address
2633             | Multicast_Loop_V4
2634             | Multicast_Loop_V6
2635             | IPv6_Only
2636          =>
2637             V4  := C.int (Boolean'Pos (Option.Enabled));
2638             Len := V4'Size / 8;
2639             Add := V4'Address;
2640
2641          when Busy_Polling =>
2642             V4  := C.int (Option.Microseconds);
2643             Len := V4'Size / 8;
2644             Add := V4'Address;
2645
2646          when Linger =>
2647             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2648             V8 (V8'Last)  := C.int (Option.Seconds);
2649             Len := V8'Size / 8;
2650             Add := V8'Address;
2651
2652          when Receive_Buffer
2653             | Send_Buffer
2654          =>
2655             V4  := C.int (Option.Size);
2656             Len := V4'Size / 8;
2657             Add := V4'Address;
2658
2659          when Error =>
2660             V4  := C.int (Boolean'Pos (True));
2661             Len := V4'Size / 8;
2662             Add := V4'Address;
2663
2664          when Add_Membership_V4
2665             | Drop_Membership_V4
2666          =>
2667             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2668             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2669             Len := V8'Size / 8;
2670             Add := V8'Address;
2671
2672          when Add_Membership_V6
2673             | Drop_Membership_V6 =>
2674             MR.ipv6mr_multiaddr := To_In6_Addr (Option.Multicast_Address);
2675             MR.ipv6mr_interface := C.unsigned (Option.Interface_Index);
2676             Len := MR'Size / 8;
2677             Add := MR'Address;
2678
2679          when Multicast_If_V4 =>
2680             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2681             Len := V4'Size / 8;
2682             Add := V4'Address;
2683
2684          when Multicast_If_V6 =>
2685             V4  := C.int (Option.Outgoing_If_Index);
2686             Len := V4'Size / 8;
2687             Add := V4'Address;
2688
2689          when Multicast_TTL =>
2690             V1  := C.unsigned_char (Option.Time_To_Live);
2691             Len := V1'Size / 8;
2692             Add := V1'Address;
2693
2694          when Multicast_Hops =>
2695             V4  := C.int (Option.Hop_Limit);
2696             Len := V4'Size / 8;
2697             Add := V4'Address;
2698
2699          when Receive_Packet_Info
2700          =>
2701             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2702             Len := V1'Size / 8;
2703             Add := V1'Address;
2704
2705          when Receive_Timeout
2706             | Send_Timeout
2707          =>
2708             if Is_Windows then
2709
2710                --  On Windows, the timeout is a DWORD in milliseconds
2711
2712                Len := U4'Size / 8;
2713                Add := U4'Address;
2714
2715                U4 := C.unsigned (Option.Timeout / 0.001);
2716
2717                if Option.Timeout > 0.0 and then U4 = 0 then
2718                   --  Avoid round to zero. Zero timeout mean unlimited.
2719                   U4 := 1;
2720                end if;
2721
2722                --  Old windows versions actual timeout is 500 ms + the given
2723                --  value (unless it is 0).
2724
2725                if Minus_500ms_Windows_Timeout /= 0 then
2726                   if U4 > 500 then
2727                      U4 := U4 - 500;
2728
2729                   elsif U4 > 0 then
2730                      U4 := 1;
2731                   end if;
2732                end if;
2733
2734             else
2735                VT  := To_Timeval (Option.Timeout);
2736                Len := VT'Size / 8;
2737                Add := VT'Address;
2738             end if;
2739       end case;
2740
2741       if Option.Name in Specific_Option_Name then
2742          Onm := Options (Option.Name);
2743
2744       elsif Option.Optname = -1 then
2745          raise Socket_Error with "optname must be specified";
2746
2747       else
2748          Onm := Option.Optname;
2749       end if;
2750
2751       Res := C_Setsockopt
2752         (C.int (Socket),
2753          Levels (Level),
2754          Onm,
2755          Add, Len);
2756
2757       if Res = Failure then
2758          Raise_Socket_Error (Socket_Errno);
2759       end if;
2760    end Set_Socket_Option;
2761
2762    ---------------------
2763    -- Shutdown_Socket --
2764    ---------------------
2765
2766    procedure Shutdown_Socket
2767      (Socket : Socket_Type;
2768       How    : Shutmode_Type := Shut_Read_Write)
2769    is
2770       Res : C.int;
2771
2772    begin
2773       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2774
2775       if Res = Failure then
2776          Raise_Socket_Error (Socket_Errno);
2777       end if;
2778    end Shutdown_Socket;
2779
2780    ------------
2781    -- Stream --
2782    ------------
2783
2784    function Stream
2785      (Socket  : Socket_Type;
2786       Send_To : Sock_Addr_Type) return Stream_Access
2787    is
2788       S : Datagram_Socket_Stream_Access;
2789
2790    begin
2791       S        := new Datagram_Socket_Stream_Type;
2792       S.Socket := Socket;
2793       S.To     := Send_To;
2794       S.From   := Get_Socket_Name (Socket);
2795       return Stream_Access (S);
2796    end Stream;
2797
2798    ------------
2799    -- Stream --
2800    ------------
2801
2802    function Stream (Socket : Socket_Type) return Stream_Access is
2803       S : Stream_Socket_Stream_Access;
2804    begin
2805       S := new Stream_Socket_Stream_Type;
2806       S.Socket := Socket;
2807       return Stream_Access (S);
2808    end Stream;
2809
2810    ------------
2811    -- To_Ada --
2812    ------------
2813
2814    function To_Ada (Fd : Integer) return Socket_Type is
2815    begin
2816       return Socket_Type (Fd);
2817    end To_Ada;
2818
2819    ----------
2820    -- To_C --
2821    ----------
2822
2823    function To_C (Socket : Socket_Type) return Integer is
2824    begin
2825       return Integer (Socket);
2826    end To_C;
2827
2828    -----------------
2829    -- To_Duration --
2830    -----------------
2831
2832    function To_Duration (Val : Timeval) return Timeval_Duration is
2833       Max_D : constant Long_Long_Integer := Long_Long_Integer (Forever - 0.5);
2834       Tv_sec_64 : constant Boolean := SOSC.SIZEOF_tv_sec = 8;
2835       --  Need to separate this condition into the constant declaration to
2836       --  avoid GNAT warning about "always true" or "always false".
2837    begin
2838       if Tv_sec_64 then
2839          --  Check for possible Duration overflow when Tv_Sec field is 64 bit
2840          --  integer.
2841
2842          if Val.Tv_Sec > time_t (Max_D) or else
2843             (Val.Tv_Sec = time_t (Max_D) and then
2844              Val.Tv_Usec > suseconds_t ((Forever - Duration (Max_D)) * 1E6))
2845          then
2846             return Forever;
2847          end if;
2848       end if;
2849
2850       return Duration (Val.Tv_Sec) + Duration (Val.Tv_Usec) * 1.0E-6;
2851    end To_Duration;
2852
2853    -------------------
2854    -- To_Host_Entry --
2855    -------------------
2856
2857    function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is
2858       Aliases_Count, Addresses_Count : Natural;
2859
2860       Family : constant Family_Type :=
2861                  (case Hostent_H_Addrtype (E) is
2862                      when SOSC.AF_INET  => Family_Inet,
2863                      when SOSC.AF_INET6 => Family_Inet6,
2864                      when others        => Family_Unspec);
2865
2866       Addr_Len : constant C.size_t := C.size_t (Hostent_H_Length (E));
2867
2868    begin
2869       if Family = Family_Unspec then
2870          Raise_Socket_Error (SOSC.EPFNOSUPPORT);
2871       end if;
2872
2873       Aliases_Count := 0;
2874       while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2875          Aliases_Count := Aliases_Count + 1;
2876       end loop;
2877
2878       Addresses_Count := 0;
2879       while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop
2880          Addresses_Count := Addresses_Count + 1;
2881       end loop;
2882
2883       return Result : Host_Entry_Type
2884                         (Aliases_Length   => Aliases_Count,
2885                          Addresses_Length => Addresses_Count)
2886       do
2887          Result.Official := To_Name (Value (Hostent_H_Name (E)));
2888
2889          for J in Result.Aliases'Range loop
2890             Result.Aliases (J) :=
2891               To_Name (Value (Hostent_H_Alias
2892                                 (E, C.int (J - Result.Aliases'First))));
2893          end loop;
2894
2895          for J in Result.Addresses'Range loop
2896             declare
2897                Ia : In_Addr_Union (Family);
2898
2899                --  Hostent_H_Addr (E, <index>) may return an address that is
2900                --  not correctly aligned for In_Addr, so we need to use
2901                --  an intermediate copy operation on a type with an alignment
2902                --  of 1 to recover the value.
2903
2904                subtype Addr_Buf_T is C.char_array (1 .. Addr_Len);
2905                Unaligned_Addr : Addr_Buf_T;
2906                for Unaligned_Addr'Address
2907                  use Hostent_H_Addr (E, C.int (J - Result.Addresses'First));
2908                pragma Import (Ada, Unaligned_Addr);
2909
2910                Aligned_Addr : Addr_Buf_T;
2911                for Aligned_Addr'Address use Ia'Address;
2912                pragma Import (Ada, Aligned_Addr);
2913
2914             begin
2915                Aligned_Addr := Unaligned_Addr;
2916                if Family = Family_Inet6 then
2917                   To_Inet_Addr (Ia.In6, Result.Addresses (J));
2918                else
2919                   To_Inet_Addr (Ia.In4, Result.Addresses (J));
2920                end if;
2921             end;
2922          end loop;
2923       end return;
2924    end To_Host_Entry;
2925
2926    ------------
2927    -- To_Int --
2928    ------------
2929
2930    function To_Int (F : Request_Flag_Type) return C.int is
2931       Current : Request_Flag_Type := F;
2932       Result  : C.int := 0;
2933
2934    begin
2935       for J in Flags'Range loop
2936          exit when Current = 0;
2937
2938          if Current mod 2 /= 0 then
2939             if Flags (J) = -1 then
2940                pragma Annotate
2941                  (CodePeer, False_Positive,
2942                   "test always false", "self fulfilling prophecy");
2943
2944                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2945             end if;
2946
2947             Result := Result + Flags (J);
2948          end if;
2949
2950          Current := Current / 2;
2951       end loop;
2952
2953       return Result;
2954    end To_Int;
2955
2956    -------------
2957    -- To_Name --
2958    -------------
2959
2960    function To_Name (N : String) return Name_Type is
2961    begin
2962       return Name_Type'(N'Length, N);
2963    end To_Name;
2964
2965    ----------------------
2966    -- To_Service_Entry --
2967    ----------------------
2968
2969    function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
2970       Aliases_Count : Natural;
2971
2972    begin
2973       Aliases_Count := 0;
2974       while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop
2975          Aliases_Count := Aliases_Count + 1;
2976       end loop;
2977
2978       return Result : Service_Entry_Type (Aliases_Length   => Aliases_Count) do
2979          Result.Official := To_Name (Value (Servent_S_Name (E)));
2980
2981          for J in Result.Aliases'Range loop
2982             Result.Aliases (J) :=
2983               To_Name (Value (Servent_S_Alias
2984                                 (E, C.int (J - Result.Aliases'First))));
2985          end loop;
2986
2987          Result.Protocol := To_Name (Value (Servent_S_Proto (E)));
2988          Result.Port :=
2989            Port_Type (Network_To_Short (Servent_S_Port (E)));
2990       end return;
2991    end To_Service_Entry;
2992
2993    ---------------
2994    -- To_String --
2995    ---------------
2996
2997    function To_String (HN : Name_Type) return String is
2998    begin
2999       return HN.Name (1 .. HN.Length);
3000    end To_String;
3001
3002    ----------------
3003    -- To_Timeval --
3004    ----------------
3005
3006    function To_Timeval (Val : Timeval_Duration) return Timeval is
3007       S  : time_t;
3008       uS : suseconds_t;
3009
3010    begin
3011       --  If zero, set result as zero (otherwise it gets rounded down to -1)
3012
3013       if Val = 0.0 then
3014          S  := 0;
3015          uS := 0;
3016
3017       --  Normal case where we do round down
3018
3019       else
3020          S  := time_t (Val - 0.5);
3021          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)) - 0.5);
3022
3023          if uS = -1 then
3024             --  It happen on integer duration
3025             uS := 0;
3026          end if;
3027       end if;
3028
3029       return (S, uS);
3030    end To_Timeval;
3031
3032    -----------
3033    -- Value --
3034    -----------
3035
3036    function Value (S : System.Address) return String is
3037       Str : String (1 .. Positive'Last);
3038       for Str'Address use S;
3039       pragma Import (Ada, Str);
3040
3041       Terminator : Positive := Str'First;
3042
3043    begin
3044       while Str (Terminator) /= ASCII.NUL loop
3045          Terminator := Terminator + 1;
3046       end loop;
3047
3048       return Str (1 .. Terminator - 1);
3049    end Value;
3050
3051    -----------
3052    -- Write --
3053    -----------
3054
3055    procedure Write
3056      (Stream : in out Datagram_Socket_Stream_Type;
3057       Item   : Ada.Streams.Stream_Element_Array)
3058    is
3059       Last : Stream_Element_Offset;
3060
3061    begin
3062       Send_Socket
3063         (Stream.Socket,
3064          Item,
3065          Last,
3066          Stream.To);
3067
3068       --  It is an error if not all of the data has been sent
3069
3070       if Last /= Item'Last then
3071          Raise_Socket_Error (Socket_Errno);
3072       end if;
3073    end Write;
3074
3075    -----------
3076    -- Write --
3077    -----------
3078
3079    procedure Write
3080      (Stream : in out Stream_Socket_Stream_Type;
3081       Item   : Ada.Streams.Stream_Element_Array)
3082    is
3083       First : Ada.Streams.Stream_Element_Offset;
3084       Index : Ada.Streams.Stream_Element_Offset;
3085       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
3086
3087    begin
3088       First := Item'First;
3089       Index := First - 1;
3090       while First <= Max loop
3091          Send_Socket (Stream.Socket, Item (First .. Max), Index, null);
3092
3093          --  Exit when all or zero data sent. Zero means that the socket has
3094          --  been closed by peer.
3095
3096          exit when Index < First or else Index = Max;
3097
3098          First := Index + 1;
3099       end loop;
3100
3101       --  For an empty array, we have First > Max, and hence Index >= Max (no
3102       --  error, the loop above is never executed). After a successful send,
3103       --  Index = Max. The only remaining case, Index < Max, is therefore
3104       --  always an actual send failure.
3105
3106       if Index < Max then
3107          Raise_Socket_Error (Socket_Errno);
3108       end if;
3109    end Write;
3110
3111    Sockets_Library_Controller_Object : Sockets_Library_Controller;
3112    pragma Unreferenced (Sockets_Library_Controller_Object);
3113    --  The elaboration and finalization of this object perform the required
3114    --  initialization and cleanup actions for the sockets library.
3115
3116    --------------------
3117    -- Create_Address --
3118    --------------------
3119
3120    function Create_Address
3121      (Family : Family_Inet_4_6; Bytes : Inet_Addr_Bytes) return Inet_Addr_Type
3122    is
3123      (case Family is
3124          when Family_Inet => (Family_Inet, Bytes),
3125          when Family_Inet6 => (Family_Inet6, Bytes));
3126
3127    ---------------
3128    -- Get_Bytes --
3129    ---------------
3130
3131    function Get_Bytes (Addr : Inet_Addr_Type) return Inet_Addr_Bytes is
3132      (case Addr.Family is
3133          when Family_Inet => Addr.Sin_V4,
3134          when Family_Inet6 => Addr.Sin_V6);
3135
3136    ----------
3137    -- Mask --
3138    ----------
3139
3140    function Mask
3141      (Family : Family_Inet_4_6;
3142       Length : Natural;
3143       Host   : Boolean := False) return Inet_Addr_Type
3144    is
3145       Addr_Len : constant Natural := Inet_Addr_Bytes_Length (Family);
3146    begin
3147       if Length > 8 * Addr_Len then
3148          raise Constraint_Error with
3149            "invalid mask length for address family " & Family'Img;
3150       end if;
3151
3152       declare
3153          B    : Inet_Addr_Bytes (1 ..  Addr_Len);
3154          Part : Inet_Addr_Comp_Type;
3155       begin
3156          for J in 1 .. Length / 8 loop
3157             B (J) := (if Host then 0 else 255);
3158          end loop;
3159
3160          if Length < 8 * Addr_Len then
3161             Part := 2 ** (8 - Length mod 8) - 1;
3162             B (Length / 8 + 1) := (if Host then Part else not Part);
3163
3164             for J in Length / 8 + 2 .. B'Last loop
3165                B (J) := (if Host then 255 else 0);
3166             end loop;
3167          end if;
3168
3169          return Create_Address (Family, B);
3170       end;
3171    end Mask;
3172
3173    -------------------------
3174    -- Unix_Socket_Address --
3175    -------------------------
3176
3177    function Unix_Socket_Address (Addr : String) return Sock_Addr_Type is
3178    begin
3179       return Sock_Addr_Type'(Family_Unix, ASU.To_Unbounded_String (Addr));
3180    end Unix_Socket_Address;
3181
3182    -----------
3183    -- "and" --
3184    -----------
3185
3186    function "and" (Addr, Mask : Inet_Addr_Type) return Inet_Addr_Type is
3187    begin
3188       if Addr.Family /= Mask.Family then
3189          raise Constraint_Error with "incompatible address families";
3190       end if;
3191
3192       declare
3193          A : constant Inet_Addr_Bytes := Get_Bytes (Addr);
3194          M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
3195          R : Inet_Addr_Bytes (A'Range);
3196
3197       begin
3198          for J in A'Range loop
3199             R (J) := A (J) and M (J);
3200          end loop;
3201          return Create_Address (Addr.Family, R);
3202       end;
3203    end "and";
3204
3205    ----------
3206    -- "or" --
3207    ----------
3208
3209    function "or" (Net, Host : Inet_Addr_Type) return Inet_Addr_Type is
3210    begin
3211       if Net.Family /= Host.Family then
3212          raise Constraint_Error with "incompatible address families";
3213       end if;
3214
3215       declare
3216          N : constant Inet_Addr_Bytes := Get_Bytes (Net);
3217          H : constant Inet_Addr_Bytes := Get_Bytes (Host);
3218          R : Inet_Addr_Bytes (N'Range);
3219
3220       begin
3221          for J in N'Range loop
3222             R (J) := N (J) or H (J);
3223          end loop;
3224          return Create_Address (Net.Family, R);
3225       end;
3226    end "or";
3227
3228    -----------
3229    -- "not" --
3230    -----------
3231
3232    function "not" (Mask : Inet_Addr_Type) return Inet_Addr_Type is
3233       M : constant Inet_Addr_Bytes := Get_Bytes (Mask);
3234       R : Inet_Addr_Bytes (M'Range);
3235    begin
3236       for J in R'Range loop
3237          R (J) := not M (J);
3238       end loop;
3239       return Create_Address (Mask.Family, R);
3240    end "not";
3241
3242 end GNAT.Sockets;