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