gcc/ada/g-socket.adb

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