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