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