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                Msg_Iovlen     => SOSC.Msg_Iovlen_T (Vector'Length),
1668                Msg_Control    => System.Null_Address,
1669                Msg_Controllen => 0,
1670                Msg_Flags      => 0);
1671
1672    begin
1673       Res :=
1674         C_Recvmsg
1675           (C.int (Socket),
1676            Msg'Address,
1677            To_Int (Flags));
1678
1679       if Res = ssize_t (Failure) then
1680          Raise_Socket_Error (Socket_Errno);
1681       end if;
1682
1683       Count := Ada.Streams.Stream_Element_Count (Res);
1684    end Receive_Vector;
1685
1686    -------------------
1687    -- Resolve_Error --
1688    -------------------
1689
1690    function Resolve_Error
1691      (Error_Value : Integer;
1692       From_Errno  : Boolean := True) return Error_Type
1693    is
1694       use GNAT.Sockets.SOSC;
1695
1696    begin
1697       if not From_Errno then
1698          case Error_Value is
1699             when SOSC.HOST_NOT_FOUND => return Unknown_Host;
1700             when SOSC.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1701             when SOSC.NO_RECOVERY    => return Non_Recoverable_Error;
1702             when SOSC.NO_DATA        => return Unknown_Server_Error;
1703             when others              => return Cannot_Resolve_Error;
1704          end case;
1705       end if;
1706
1707       --  Special case: EAGAIN may be the same value as EWOULDBLOCK, so we
1708       --  can't include it in the case statement below.
1709
1710       pragma Warnings (Off);
1711       --  Condition "EAGAIN /= EWOULDBLOCK" is known at compile time
1712
1713       if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then
1714          return Resource_Temporarily_Unavailable;
1715       end if;
1716
1717       pragma Warnings (On);
1718
1719       case Error_Value is
1720          when ENOERROR        => return Success;
1721          when EACCES          => return Permission_Denied;
1722          when EADDRINUSE      => return Address_Already_In_Use;
1723          when EADDRNOTAVAIL   => return Cannot_Assign_Requested_Address;
1724          when EAFNOSUPPORT    => return
1725                                  Address_Family_Not_Supported_By_Protocol;
1726          when EALREADY        => return Operation_Already_In_Progress;
1727          when EBADF           => return Bad_File_Descriptor;
1728          when ECONNABORTED    => return Software_Caused_Connection_Abort;
1729          when ECONNREFUSED    => return Connection_Refused;
1730          when ECONNRESET      => return Connection_Reset_By_Peer;
1731          when EDESTADDRREQ    => return Destination_Address_Required;
1732          when EFAULT          => return Bad_Address;
1733          when EHOSTDOWN       => return Host_Is_Down;
1734          when EHOSTUNREACH    => return No_Route_To_Host;
1735          when EINPROGRESS     => return Operation_Now_In_Progress;
1736          when EINTR           => return Interrupted_System_Call;
1737          when EINVAL          => return Invalid_Argument;
1738          when EIO             => return Input_Output_Error;
1739          when EISCONN         => return Transport_Endpoint_Already_Connected;
1740          when ELOOP           => return Too_Many_Symbolic_Links;
1741          when EMFILE          => return Too_Many_Open_Files;
1742          when EMSGSIZE        => return Message_Too_Long;
1743          when ENAMETOOLONG    => return File_Name_Too_Long;
1744          when ENETDOWN        => return Network_Is_Down;
1745          when ENETRESET       => return
1746                                  Network_Dropped_Connection_Because_Of_Reset;
1747          when ENETUNREACH     => return Network_Is_Unreachable;
1748          when ENOBUFS         => return No_Buffer_Space_Available;
1749          when ENOPROTOOPT     => return Protocol_Not_Available;
1750          when ENOTCONN        => return Transport_Endpoint_Not_Connected;
1751          when ENOTSOCK        => return Socket_Operation_On_Non_Socket;
1752          when EOPNOTSUPP      => return Operation_Not_Supported;
1753          when EPFNOSUPPORT    => return Protocol_Family_Not_Supported;
1754          when EPIPE           => return Broken_Pipe;
1755          when EPROTONOSUPPORT => return Protocol_Not_Supported;
1756          when EPROTOTYPE      => return Protocol_Wrong_Type_For_Socket;
1757          when ESHUTDOWN       => return
1758                                  Cannot_Send_After_Transport_Endpoint_Shutdown;
1759          when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1760          when ETIMEDOUT       => return Connection_Timed_Out;
1761          when ETOOMANYREFS    => return Too_Many_References;
1762          when EWOULDBLOCK     => return Resource_Temporarily_Unavailable;
1763
1764          when others          => return Cannot_Resolve_Error;
1765       end case;
1766    end Resolve_Error;
1767
1768    -----------------------
1769    -- Resolve_Exception --
1770    -----------------------
1771
1772    function Resolve_Exception
1773      (Occurrence : Exception_Occurrence) return Error_Type
1774    is
1775       Id    : constant Exception_Id := Exception_Identity (Occurrence);
1776       Msg   : constant String       := Exception_Message (Occurrence);
1777       First : Natural;
1778       Last  : Natural;
1779       Val   : Integer;
1780
1781    begin
1782       First := Msg'First;
1783       while First <= Msg'Last
1784         and then Msg (First) not in '0' .. '9'
1785       loop
1786          First := First + 1;
1787       end loop;
1788
1789       if First > Msg'Last then
1790          return Cannot_Resolve_Error;
1791       end if;
1792
1793       Last := First;
1794       while Last < Msg'Last
1795         and then Msg (Last + 1) in '0' .. '9'
1796       loop
1797          Last := Last + 1;
1798       end loop;
1799
1800       Val := Integer'Value (Msg (First .. Last));
1801
1802       if Id = Socket_Error_Id then
1803          return Resolve_Error (Val);
1804
1805       elsif Id = Host_Error_Id then
1806          return Resolve_Error (Val, False);
1807
1808       else
1809          return Cannot_Resolve_Error;
1810       end if;
1811    end Resolve_Exception;
1812
1813    -----------------
1814    -- Send_Socket --
1815    -----------------
1816
1817    procedure Send_Socket
1818      (Socket : Socket_Type;
1819       Item   : Ada.Streams.Stream_Element_Array;
1820       Last   : out Ada.Streams.Stream_Element_Offset;
1821       Flags  : Request_Flag_Type := No_Request_Flag)
1822    is
1823    begin
1824       Send_Socket (Socket, Item, Last, To => null, Flags => Flags);
1825    end Send_Socket;
1826
1827    -----------------
1828    -- Send_Socket --
1829    -----------------
1830
1831    procedure Send_Socket
1832      (Socket : Socket_Type;
1833       Item   : Ada.Streams.Stream_Element_Array;
1834       Last   : out Ada.Streams.Stream_Element_Offset;
1835       To     : Sock_Addr_Type;
1836       Flags  : Request_Flag_Type := No_Request_Flag)
1837    is
1838    begin
1839       Send_Socket
1840         (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags);
1841    end Send_Socket;
1842
1843    -----------------
1844    -- Send_Socket --
1845    -----------------
1846
1847    procedure Send_Socket
1848      (Socket : Socket_Type;
1849       Item   : Ada.Streams.Stream_Element_Array;
1850       Last   : out Ada.Streams.Stream_Element_Offset;
1851       To     : access Sock_Addr_Type;
1852       Flags  : Request_Flag_Type := No_Request_Flag)
1853    is
1854       Res  : C.int;
1855
1856       Sin  : aliased Sockaddr_In;
1857       C_To : System.Address;
1858       Len  : C.int;
1859
1860    begin
1861       if To /= null then
1862          Set_Family  (Sin.Sin_Family, To.Family);
1863          Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
1864          Set_Port
1865            (Sin'Unchecked_Access,
1866             Short_To_Network (C.unsigned_short (To.Port)));
1867          C_To := Sin'Address;
1868          Len := Sin'Size / 8;
1869
1870       else
1871          C_To := System.Null_Address;
1872          Len := 0;
1873       end if;
1874
1875       Res := C_Sendto
1876         (C.int (Socket),
1877          Item'Address,
1878          Item'Length,
1879          Set_Forced_Flags (To_Int (Flags)),
1880          C_To,
1881          Len);
1882
1883       if Res = Failure then
1884          Raise_Socket_Error (Socket_Errno);
1885       end if;
1886
1887       Last := Last_Index (First => Item'First, Count => Res);
1888    end Send_Socket;
1889
1890    -----------------
1891    -- Send_Vector --
1892    -----------------
1893
1894    procedure Send_Vector
1895      (Socket : Socket_Type;
1896       Vector : Vector_Type;
1897       Count  : out Ada.Streams.Stream_Element_Count;
1898       Flags  : Request_Flag_Type := No_Request_Flag)
1899    is
1900       use SOSC;
1901       use Interfaces.C;
1902
1903       Res            : ssize_t;
1904       Iov_Count      : SOSC.Msg_Iovlen_T;
1905       This_Iov_Count : SOSC.Msg_Iovlen_T;
1906       Msg            : Msghdr;
1907
1908    begin
1909       Count := 0;
1910       Iov_Count := 0;
1911       while Iov_Count < Vector'Length loop
1912
1913          pragma Warnings (Off);
1914          --  Following test may be compile time known on some targets
1915
1916          This_Iov_Count :=
1917            (if Vector'Length - Iov_Count > SOSC.IOV_MAX
1918             then SOSC.IOV_MAX
1919             else Vector'Length - Iov_Count);
1920
1921          pragma Warnings (On);
1922
1923          Msg :=
1924            (Msg_Name       => System.Null_Address,
1925             Msg_Namelen    => 0,
1926             Msg_Iov        => Vector
1927                                 (Vector'First + Integer (Iov_Count))'Address,
1928             Msg_Iovlen     => This_Iov_Count,
1929             Msg_Control    => System.Null_Address,
1930             Msg_Controllen => 0,
1931             Msg_Flags      => 0);
1932
1933          Res :=
1934            C_Sendmsg
1935              (C.int (Socket),
1936               Msg'Address,
1937               Set_Forced_Flags (To_Int (Flags)));
1938
1939          if Res = ssize_t (Failure) then
1940             Raise_Socket_Error (Socket_Errno);
1941          end if;
1942
1943          Count := Count + Ada.Streams.Stream_Element_Count (Res);
1944          Iov_Count := Iov_Count + This_Iov_Count;
1945       end loop;
1946    end Send_Vector;
1947
1948    ---------
1949    -- Set --
1950    ---------
1951
1952    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1953    begin
1954       if Item.Last = No_Socket then
1955
1956          --  Uninitialized socket set, make sure it is properly zeroed out
1957
1958          Reset_Socket_Set (Item.Set'Access);
1959          Item.Last := Socket;
1960
1961       elsif Item.Last < Socket then
1962          Item.Last := Socket;
1963       end if;
1964
1965       Insert_Socket_In_Set (Item.Set'Access, C.int (Socket));
1966    end Set;
1967
1968    ----------------------
1969    -- Set_Forced_Flags --
1970    ----------------------
1971
1972    function Set_Forced_Flags (F : C.int) return C.int is
1973       use type C.unsigned;
1974       function To_unsigned is
1975         new Ada.Unchecked_Conversion (C.int, C.unsigned);
1976       function To_int is
1977         new Ada.Unchecked_Conversion (C.unsigned, C.int);
1978    begin
1979       return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags);
1980    end Set_Forced_Flags;
1981
1982    -----------------------
1983    -- Set_Socket_Option --
1984    -----------------------
1985
1986    procedure Set_Socket_Option
1987      (Socket : Socket_Type;
1988       Level  : Level_Type := Socket_Level;
1989       Option : Option_Type)
1990    is
1991       V8  : aliased Two_Ints;
1992       V4  : aliased C.int;
1993       V1  : aliased C.unsigned_char;
1994       VT  : aliased Timeval;
1995       Len : C.int;
1996       Add : System.Address := Null_Address;
1997       Res : C.int;
1998
1999    begin
2000       case Option.Name is
2001          when Keep_Alive      |
2002               Reuse_Address   |
2003               Broadcast       |
2004               No_Delay        =>
2005             V4  := C.int (Boolean'Pos (Option.Enabled));
2006             Len := V4'Size / 8;
2007             Add := V4'Address;
2008
2009          when Linger          =>
2010             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
2011             V8 (V8'Last)  := C.int (Option.Seconds);
2012             Len := V8'Size / 8;
2013             Add := V8'Address;
2014
2015          when Send_Buffer     |
2016               Receive_Buffer  =>
2017             V4  := C.int (Option.Size);
2018             Len := V4'Size / 8;
2019             Add := V4'Address;
2020
2021          when Error           =>
2022             V4  := C.int (Boolean'Pos (True));
2023             Len := V4'Size / 8;
2024             Add := V4'Address;
2025
2026          when Add_Membership  |
2027               Drop_Membership =>
2028             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
2029             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
2030             Len := V8'Size / 8;
2031             Add := V8'Address;
2032
2033          when Multicast_If    =>
2034             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
2035             Len := V4'Size / 8;
2036             Add := V4'Address;
2037
2038          when Multicast_TTL   =>
2039             V1  := C.unsigned_char (Option.Time_To_Live);
2040             Len := V1'Size / 8;
2041             Add := V1'Address;
2042
2043          when Multicast_Loop      |
2044               Receive_Packet_Info =>
2045             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
2046             Len := V1'Size / 8;
2047             Add := V1'Address;
2048
2049          when Send_Timeout    |
2050               Receive_Timeout =>
2051             VT  := To_Timeval (Option.Timeout);
2052             Len := VT'Size / 8;
2053             Add := VT'Address;
2054
2055       end case;
2056
2057       Res := C_Setsockopt
2058         (C.int (Socket),
2059          Levels (Level),
2060          Options (Option.Name),
2061          Add, Len);
2062
2063       if Res = Failure then
2064          Raise_Socket_Error (Socket_Errno);
2065       end if;
2066    end Set_Socket_Option;
2067
2068    ----------------------
2069    -- Short_To_Network --
2070    ----------------------
2071
2072    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
2073       use type C.unsigned_short;
2074
2075    begin
2076       --  Big-endian case. No conversion needed. On these platforms,
2077       --  htons() defaults to a null procedure.
2078
2079       pragma Warnings (Off);
2080       --  Since the test can generate "always True/False" warning
2081
2082       if Default_Bit_Order = High_Order_First then
2083          return S;
2084
2085          pragma Warnings (On);
2086
2087       --  Little-endian case. We must swap the high and low bytes of this
2088       --  short to make the port number network compliant.
2089
2090       else
2091          return (S / 256) + (S mod 256) * 256;
2092       end if;
2093    end Short_To_Network;
2094
2095    ---------------------
2096    -- Shutdown_Socket --
2097    ---------------------
2098
2099    procedure Shutdown_Socket
2100      (Socket : Socket_Type;
2101       How    : Shutmode_Type := Shut_Read_Write)
2102    is
2103       Res : C.int;
2104
2105    begin
2106       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
2107
2108       if Res = Failure then
2109          Raise_Socket_Error (Socket_Errno);
2110       end if;
2111    end Shutdown_Socket;
2112
2113    ------------
2114    -- Stream --
2115    ------------
2116
2117    function Stream
2118      (Socket  : Socket_Type;
2119       Send_To : Sock_Addr_Type) return Stream_Access
2120    is
2121       S : Datagram_Socket_Stream_Access;
2122
2123    begin
2124       S        := new Datagram_Socket_Stream_Type;
2125       S.Socket := Socket;
2126       S.To     := Send_To;
2127       S.From   := Get_Socket_Name (Socket);
2128       return Stream_Access (S);
2129    end Stream;
2130
2131    ------------
2132    -- Stream --
2133    ------------
2134
2135    function Stream (Socket : Socket_Type) return Stream_Access is
2136       S : Stream_Socket_Stream_Access;
2137    begin
2138       S := new Stream_Socket_Stream_Type;
2139       S.Socket := Socket;
2140       return Stream_Access (S);
2141    end Stream;
2142
2143    ------------------
2144    -- Stream_Write --
2145    ------------------
2146
2147    procedure Stream_Write
2148      (Socket : Socket_Type;
2149       Item   : Ada.Streams.Stream_Element_Array;
2150       To     : access Sock_Addr_Type)
2151    is
2152       First : Ada.Streams.Stream_Element_Offset;
2153       Index : Ada.Streams.Stream_Element_Offset;
2154       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2155
2156    begin
2157       First := Item'First;
2158       Index := First - 1;
2159       while First <= Max loop
2160          Send_Socket (Socket, Item (First .. Max), Index, To);
2161
2162          --  Exit when all or zero data sent. Zero means that the socket has
2163          --  been closed by peer.
2164
2165          exit when Index < First or else Index = Max;
2166
2167          First := Index + 1;
2168       end loop;
2169
2170       --  For an empty array, we have First > Max, and hence Index >= Max (no
2171       --  error, the loop above is never executed). After a succesful send,
2172       --  Index = Max. The only remaining case, Index < Max, is therefore
2173       --  always an actual send failure.
2174
2175       if Index < Max then
2176          Raise_Socket_Error (Socket_Errno);
2177       end if;
2178    end Stream_Write;
2179
2180    ----------
2181    -- To_C --
2182    ----------
2183
2184    function To_C (Socket : Socket_Type) return Integer is
2185    begin
2186       return Integer (Socket);
2187    end To_C;
2188
2189    -----------------
2190    -- To_Duration --
2191    -----------------
2192
2193    function To_Duration (Val : Timeval) return Timeval_Duration is
2194    begin
2195       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
2196    end To_Duration;
2197
2198    -------------------
2199    -- To_Host_Entry --
2200    -------------------
2201
2202    function To_Host_Entry (E : Hostent) return Host_Entry_Type is
2203       use type C.size_t;
2204
2205       Official : constant String :=
2206                   C.Strings.Value (E.H_Name);
2207
2208       Aliases : constant Chars_Ptr_Array :=
2209                   Chars_Ptr_Pointers.Value (E.H_Aliases);
2210       --  H_Aliases points to a list of name aliases. The list is terminated by
2211       --  a NULL pointer.
2212
2213       Addresses : constant In_Addr_Access_Array :=
2214                     In_Addr_Access_Pointers.Value (E.H_Addr_List);
2215       --  H_Addr_List points to a list of binary addresses (in network byte
2216       --  order). The list is terminated by a NULL pointer.
2217       --
2218       --  H_Length is not used because it is currently only set to 4.
2219       --  H_Addrtype is always AF_INET
2220
2221       Result : Host_Entry_Type
2222                  (Aliases_Length   => Aliases'Length - 1,
2223                   Addresses_Length => Addresses'Length - 1);
2224       --  The last element is a null pointer
2225
2226       Source : C.size_t;
2227       Target : Natural;
2228
2229    begin
2230       Result.Official := To_Name (Official);
2231
2232       Source := Aliases'First;
2233       Target := Result.Aliases'First;
2234       while Target <= Result.Aliases_Length loop
2235          Result.Aliases (Target) :=
2236            To_Name (C.Strings.Value (Aliases (Source)));
2237          Source := Source + 1;
2238          Target := Target + 1;
2239       end loop;
2240
2241       Source := Addresses'First;
2242       Target := Result.Addresses'First;
2243       while Target <= Result.Addresses_Length loop
2244          To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
2245          Source := Source + 1;
2246          Target := Target + 1;
2247       end loop;
2248
2249       return Result;
2250    end To_Host_Entry;
2251
2252    ----------------
2253    -- To_In_Addr --
2254    ----------------
2255
2256    function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is
2257    begin
2258       if Addr.Family = Family_Inet then
2259          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
2260                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
2261                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
2262                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
2263       end if;
2264
2265       raise Socket_Error with "IPv6 not supported";
2266    end To_In_Addr;
2267
2268    ------------------
2269    -- To_Inet_Addr --
2270    ------------------
2271
2272    procedure To_Inet_Addr
2273      (Addr   : In_Addr;
2274       Result : out Inet_Addr_Type) is
2275    begin
2276       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
2277       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
2278       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2279       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2280    end To_Inet_Addr;
2281
2282    ------------
2283    -- To_Int --
2284    ------------
2285
2286    function To_Int (F : Request_Flag_Type) return C.int
2287    is
2288       Current : Request_Flag_Type := F;
2289       Result  : C.int := 0;
2290
2291    begin
2292       for J in Flags'Range loop
2293          exit when Current = 0;
2294
2295          if Current mod 2 /= 0 then
2296             if Flags (J) = -1 then
2297                Raise_Socket_Error (SOSC.EOPNOTSUPP);
2298             end if;
2299
2300             Result := Result + Flags (J);
2301          end if;
2302
2303          Current := Current / 2;
2304       end loop;
2305
2306       return Result;
2307    end To_Int;
2308
2309    -------------
2310    -- To_Name --
2311    -------------
2312
2313    function To_Name (N : String) return Name_Type is
2314    begin
2315       return Name_Type'(N'Length, N);
2316    end To_Name;
2317
2318    ----------------------
2319    -- To_Service_Entry --
2320    ----------------------
2321
2322    function To_Service_Entry (E : Servent) return Service_Entry_Type is
2323       use type C.size_t;
2324
2325       Official : constant String := C.Strings.Value (E.S_Name);
2326
2327       Aliases : constant Chars_Ptr_Array :=
2328                   Chars_Ptr_Pointers.Value (E.S_Aliases);
2329       --  S_Aliases points to a list of name aliases. The list is
2330       --  terminated by a NULL pointer.
2331
2332       Protocol : constant String := C.Strings.Value (E.S_Proto);
2333
2334       Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
2335       --  The last element is a null pointer
2336
2337       Source : C.size_t;
2338       Target : Natural;
2339
2340    begin
2341       Result.Official := To_Name (Official);
2342
2343       Source := Aliases'First;
2344       Target := Result.Aliases'First;
2345       while Target <= Result.Aliases_Length loop
2346          Result.Aliases (Target) :=
2347            To_Name (C.Strings.Value (Aliases (Source)));
2348          Source := Source + 1;
2349          Target := Target + 1;
2350       end loop;
2351
2352       Result.Port :=
2353         Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2354
2355       Result.Protocol := To_Name (Protocol);
2356       return Result;
2357    end To_Service_Entry;
2358
2359    ---------------
2360    -- To_String --
2361    ---------------
2362
2363    function To_String (HN : Name_Type) return String is
2364    begin
2365       return HN.Name (1 .. HN.Length);
2366    end To_String;
2367
2368    ----------------
2369    -- To_Timeval --
2370    ----------------
2371
2372    function To_Timeval (Val : Timeval_Duration) return Timeval is
2373       S  : time_t;
2374       uS : suseconds_t;
2375
2376    begin
2377       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2378
2379       if Val = 0.0 then
2380          S  := 0;
2381          uS := 0;
2382
2383       --  Normal case where we do round down
2384
2385       else
2386          S  := time_t (Val - 0.5);
2387          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2388       end if;
2389
2390       return (S, uS);
2391    end To_Timeval;
2392
2393    -----------
2394    -- Write --
2395    -----------
2396
2397    procedure Write
2398      (Stream : in out Datagram_Socket_Stream_Type;
2399       Item   : Ada.Streams.Stream_Element_Array)
2400    is
2401    begin
2402       Stream_Write (Stream.Socket, Item, To => Stream.To'Unrestricted_Access);
2403    end Write;
2404
2405    -----------
2406    -- Write --
2407    -----------
2408
2409    procedure Write
2410      (Stream : in out Stream_Socket_Stream_Type;
2411       Item   : Ada.Streams.Stream_Element_Array)
2412    is
2413    begin
2414       Stream_Write (Stream.Socket, Item, To => null);
2415    end Write;
2416
2417    Sockets_Library_Controller_Object : Sockets_Library_Controller;
2418    pragma Unreferenced (Sockets_Library_Controller_Object);
2419    --  The elaboration and finalization of this object perform the required
2420    --  initialization and cleanup actions for the sockets library.
2421
2422 end GNAT.Sockets;