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