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