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