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