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