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