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