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