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