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