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