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