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