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