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