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