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