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