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