gcc/ada/g-socket.adb

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