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