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