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, System.Address;
  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       Res : C.int;
 577       Sin : aliased Sockaddr_In;
 578       Len : constant C.int := Sin'Size / 8;
 579
 580    begin
 581       if Server.Family = Family_Inet6 then
 582          raise Socket_Error;
 583       end if;
 584
 585       Set_Length (Sin'Unchecked_Access, Len);
 586       Set_Family (Sin'Unchecked_Access, Families (Server.Family));
 587       Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
 588       Set_Port
 589         (Sin'Unchecked_Access,
 590          Short_To_Network (C.unsigned_short (Server.Port)));
 591
 592       Res := C_Connect (C.int (Socket), Sin'Address, Len);
 593
 594       if Res = Failure then
 595          Raise_Socket_Error (Socket_Errno);
 596       end if;
 597    end Connect_Socket;
 598
 599    --------------------
 600    -- Control_Socket --
 601    --------------------
 602
 603    procedure Control_Socket
 604      (Socket  : Socket_Type;
 605       Request : in out Request_Type)
 606    is
 607       Arg : aliased C.int;
 608       Res : C.int;
 609
 610    begin
 611       case Request.Name is
 612          when Non_Blocking_IO =>
 613             Arg := C.int (Boolean'Pos (Request.Enabled));
 614
 615          when N_Bytes_To_Read =>
 616             null;
 617       end case;
 618
 619       Res := C_Ioctl
 620         (C.int (Socket),
 621          Requests (Request.Name),
 622          Arg'Unchecked_Access);
 623
 624       if Res = Failure then
 625          Raise_Socket_Error (Socket_Errno);
 626       end if;
 627
 628       case Request.Name is
 629          when Non_Blocking_IO =>
 630             null;
 631
 632          when N_Bytes_To_Read =>
 633             Request.Size := Natural (Arg);
 634       end case;
 635    end Control_Socket;
 636
 637    ----------
 638    -- Copy --
 639    ----------
 640
 641    procedure Copy
 642      (Source : Socket_Set_Type;
 643       Target : in out Socket_Set_Type)
 644    is
 645    begin
 646       Empty (Target);
 647       if Source.Last /= No_Socket then
 648          Target.Set  := New_Socket_Set (Source.Set);
 649          Target.Last := Source.Last;
 650       end if;
 651    end Copy;
 652
 653    ---------------------
 654    -- Create_Selector --
 655    ---------------------
 656
 657    procedure Create_Selector (Selector : out Selector_Type) is
 658       Two_Fds : aliased Fd_Pair;
 659       Res     : C.int;
 660
 661    begin
 662       --  We open two signalling file descriptors. One of them is used to send
 663       --  data to the other, which is included in a C_Select socket set. The
 664       --  communication is used to force a call to C_Select to complete, and
 665       --  the waiting task to resume its execution.
 666
 667       Res := Signalling_Fds.Create (Two_Fds'Access);
 668
 669       if Res = Failure then
 670          Raise_Socket_Error (Socket_Errno);
 671       end if;
 672
 673       Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
 674       Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
 675    end Create_Selector;
 676
 677    -------------------
 678    -- Create_Socket --
 679    -------------------
 680
 681    procedure Create_Socket
 682      (Socket : out Socket_Type;
 683       Family : Family_Type := Family_Inet;
 684       Mode   : Mode_Type   := Socket_Stream)
 685    is
 686       Res : C.int;
 687
 688    begin
 689       Res := C_Socket (Families (Family), Modes (Mode), 0);
 690
 691       if Res = Failure then
 692          Raise_Socket_Error (Socket_Errno);
 693       end if;
 694
 695       Socket := Socket_Type (Res);
 696    end Create_Socket;
 697
 698    -----------
 699    -- Empty --
 700    -----------
 701
 702    procedure Empty  (Item : in out Socket_Set_Type) is
 703    begin
 704       if Item.Set /= No_Socket_Set then
 705          Free_Socket_Set (Item.Set);
 706          Item.Set := No_Socket_Set;
 707       end if;
 708
 709       Item.Last := No_Socket;
 710    end Empty;
 711
 712    --------------------
 713    -- Err_Code_Image --
 714    --------------------
 715
 716    function Err_Code_Image (E : Integer) return String is
 717       Msg : String := E'Img & "] ";
 718    begin
 719       Msg (Msg'First) := '[';
 720       return Msg;
 721    end Err_Code_Image;
 722
 723    --------------
 724    -- Finalize --
 725    --------------
 726
 727    procedure Finalize is
 728    begin
 729       if not Finalized
 730         and then Initialized
 731       then
 732          Finalized := True;
 733          Thin.Finalize;
 734       end if;
 735    end Finalize;
 736
 737    ---------
 738    -- Get --
 739    ---------
 740
 741    procedure Get
 742      (Item   : in out Socket_Set_Type;
 743       Socket : out Socket_Type)
 744    is
 745       S : aliased C.int;
 746       L : aliased C.int := C.int (Item.Last);
 747
 748    begin
 749       if Item.Last /= No_Socket then
 750          Get_Socket_From_Set
 751            (Item.Set, L'Unchecked_Access, S'Unchecked_Access);
 752          Item.Last := Socket_Type (L);
 753          Socket    := Socket_Type (S);
 754       else
 755          Socket := No_Socket;
 756       end if;
 757    end Get;
 758
 759    -----------------
 760    -- Get_Address --
 761    -----------------
 762
 763    function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is
 764    begin
 765       if Stream = null then
 766          raise Socket_Error;
 767       elsif Stream.all in Datagram_Socket_Stream_Type then
 768          return Datagram_Socket_Stream_Type (Stream.all).From;
 769       else
 770          return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
 771       end if;
 772    end Get_Address;
 773
 774    -------------------------
 775    -- Get_Host_By_Address --
 776    -------------------------
 777
 778    function Get_Host_By_Address
 779      (Address : Inet_Addr_Type;
 780       Family  : Family_Type := Family_Inet) return Host_Entry_Type
 781    is
 782       pragma Unreferenced (Family);
 783
 784       HA     : aliased In_Addr := To_In_Addr (Address);
 785       Buflen : constant C.int := Netdb_Buffer_Size;
 786       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 787       Res    : aliased Hostent;
 788       Err    : aliased C.int;
 789
 790    begin
 791       if Safe_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET,
 792                              Res'Access, Buf'Address, Buflen, Err'Access) /= 0
 793       then
 794          Raise_Host_Error (Integer (Err));
 795       end if;
 796
 797       return To_Host_Entry (Res);
 798    end Get_Host_By_Address;
 799
 800    ----------------------
 801    -- Get_Host_By_Name --
 802    ----------------------
 803
 804    function Get_Host_By_Name (Name : String) return Host_Entry_Type is
 805    begin
 806       --  Detect IP address name and redirect to Inet_Addr
 807
 808       if Is_IP_Address (Name) then
 809          return Get_Host_By_Address (Inet_Addr (Name));
 810       end if;
 811
 812       declare
 813          HN     : constant C.char_array := C.To_C (Name);
 814          Buflen : constant C.int := Netdb_Buffer_Size;
 815          Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 816          Res    : aliased Hostent;
 817          Err    : aliased C.int;
 818
 819       begin
 820          if Safe_Gethostbyname
 821            (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
 822          then
 823             Raise_Host_Error (Integer (Err));
 824          end if;
 825
 826          return To_Host_Entry (Res);
 827       end;
 828    end Get_Host_By_Name;
 829
 830    -------------------
 831    -- Get_Peer_Name --
 832    -------------------
 833
 834    function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
 835       Sin : aliased Sockaddr_In;
 836       Len : aliased C.int := Sin'Size / 8;
 837       Res : Sock_Addr_Type (Family_Inet);
 838
 839    begin
 840       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
 841          Raise_Socket_Error (Socket_Errno);
 842       end if;
 843
 844       To_Inet_Addr (Sin.Sin_Addr, Res.Addr);
 845       Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 846
 847       return Res;
 848    end Get_Peer_Name;
 849
 850    -------------------------
 851    -- Get_Service_By_Name --
 852    -------------------------
 853
 854    function Get_Service_By_Name
 855      (Name     : String;
 856       Protocol : String) return Service_Entry_Type
 857    is
 858       SN     : constant C.char_array := C.To_C (Name);
 859       SP     : constant C.char_array := C.To_C (Protocol);
 860       Buflen : constant C.int := Netdb_Buffer_Size;
 861       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 862       Res    : aliased Servent;
 863
 864    begin
 865       if Safe_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then
 866          Ada.Exceptions.Raise_Exception
 867            (Service_Error'Identity, "Service not found");
 868       end if;
 869
 870       --  Translate from the C format to the API format
 871
 872       return To_Service_Entry (Res);
 873    end Get_Service_By_Name;
 874
 875    -------------------------
 876    -- Get_Service_By_Port --
 877    -------------------------
 878
 879    function Get_Service_By_Port
 880      (Port     : Port_Type;
 881       Protocol : String) return Service_Entry_Type
 882    is
 883       SP     : constant C.char_array := C.To_C (Protocol);
 884       Buflen : constant C.int := Netdb_Buffer_Size;
 885       Buf    : aliased C.char_array (1 .. Netdb_Buffer_Size);
 886       Res    : aliased Servent;
 887
 888    begin
 889       if Safe_Getservbyport
 890         (C.int (Short_To_Network (C.unsigned_short (Port))), SP,
 891          Res'Access, Buf'Address, Buflen) /= 0
 892       then
 893          Ada.Exceptions.Raise_Exception
 894            (Service_Error'Identity, "Service not found");
 895       end if;
 896
 897       --  Translate from the C format to the API format
 898
 899       return To_Service_Entry (Res);
 900    end Get_Service_By_Port;
 901
 902    ---------------------
 903    -- Get_Socket_Name --
 904    ---------------------
 905
 906    function Get_Socket_Name
 907      (Socket : Socket_Type) return Sock_Addr_Type
 908    is
 909       Sin  : aliased Sockaddr_In;
 910       Len  : aliased C.int := Sin'Size / 8;
 911       Res  : C.int;
 912       Addr : Sock_Addr_Type := No_Sock_Addr;
 913
 914    begin
 915       Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
 916
 917       if Res /= Failure then
 918          To_Inet_Addr (Sin.Sin_Addr, Addr.Addr);
 919          Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
 920       end if;
 921
 922       return Addr;
 923    end Get_Socket_Name;
 924
 925    -----------------------
 926    -- Get_Socket_Option --
 927    -----------------------
 928
 929    function Get_Socket_Option
 930      (Socket : Socket_Type;
 931       Level  : Level_Type := Socket_Level;
 932       Name   : Option_Name) return Option_Type
 933    is
 934       use type C.unsigned_char;
 935
 936       V8  : aliased Two_Ints;
 937       V4  : aliased C.int;
 938       V1  : aliased C.unsigned_char;
 939       VT  : aliased Timeval;
 940       Len : aliased C.int;
 941       Add : System.Address;
 942       Res : C.int;
 943       Opt : Option_Type (Name);
 944
 945    begin
 946       case Name is
 947          when Multicast_Loop  |
 948               Multicast_TTL   =>
 949             Len := V1'Size / 8;
 950             Add := V1'Address;
 951
 952          when Keep_Alive      |
 953               Reuse_Address   |
 954               Broadcast       |
 955               No_Delay        |
 956               Send_Buffer     |
 957               Receive_Buffer  |
 958               Multicast_If    |
 959               Error           =>
 960             Len := V4'Size / 8;
 961             Add := V4'Address;
 962
 963          when Send_Timeout    |
 964               Receive_Timeout =>
 965             Len := VT'Size / 8;
 966             Add := VT'Address;
 967
 968          when Linger          |
 969               Add_Membership  |
 970               Drop_Membership =>
 971             Len := V8'Size / 8;
 972             Add := V8'Address;
 973
 974       end case;
 975
 976       Res :=
 977         C_Getsockopt
 978           (C.int (Socket),
 979            Levels (Level),
 980            Options (Name),
 981            Add, Len'Unchecked_Access);
 982
 983       if Res = Failure then
 984          Raise_Socket_Error (Socket_Errno);
 985       end if;
 986
 987       case Name is
 988          when Keep_Alive      |
 989               Reuse_Address   |
 990               Broadcast       |
 991               No_Delay        =>
 992             Opt.Enabled := (V4 /= 0);
 993
 994          when Linger          =>
 995             Opt.Enabled := (V8 (V8'First) /= 0);
 996             Opt.Seconds := Natural (V8 (V8'Last));
 997
 998          when Send_Buffer     |
 999               Receive_Buffer  =>
1000             Opt.Size := Natural (V4);
1001
1002          when Error           =>
1003             Opt.Error := Resolve_Error (Integer (V4));
1004
1005          when Add_Membership  |
1006               Drop_Membership =>
1007             To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
1008             To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
1009
1010          when Multicast_If    =>
1011             To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
1012
1013          when Multicast_TTL   =>
1014             Opt.Time_To_Live := Integer (V1);
1015
1016          when Multicast_Loop  =>
1017             Opt.Enabled := (V1 /= 0);
1018
1019          when Send_Timeout    |
1020               Receive_Timeout =>
1021             Opt.Timeout := To_Duration (VT);
1022       end case;
1023
1024       return Opt;
1025    end Get_Socket_Option;
1026
1027    ---------------
1028    -- Host_Name --
1029    ---------------
1030
1031    function Host_Name return String is
1032       Name : aliased C.char_array (1 .. 64);
1033       Res  : C.int;
1034
1035    begin
1036       Res := C_Gethostname (Name'Address, Name'Length);
1037
1038       if Res = Failure then
1039          Raise_Socket_Error (Socket_Errno);
1040       end if;
1041
1042       return C.To_Ada (Name);
1043    end Host_Name;
1044
1045    -----------
1046    -- Image --
1047    -----------
1048
1049    function Image
1050      (Val : Inet_Addr_VN_Type;
1051       Hex : Boolean := False) return String
1052    is
1053       --  The largest Inet_Addr_Comp_Type image occurs with IPv4. It
1054       --  has at most a length of 3 plus one '.' character.
1055
1056       Buffer    : String (1 .. 4 * Val'Length);
1057       Length    : Natural := 1;
1058       Separator : Character;
1059
1060       procedure Img10 (V : Inet_Addr_Comp_Type);
1061       --  Append to Buffer image of V in decimal format
1062
1063       procedure Img16 (V : Inet_Addr_Comp_Type);
1064       --  Append to Buffer image of V in hexadecimal format
1065
1066       -----------
1067       -- Img10 --
1068       -----------
1069
1070       procedure Img10 (V : Inet_Addr_Comp_Type) is
1071          Img : constant String := V'Img;
1072          Len : constant Natural := Img'Length - 1;
1073       begin
1074          Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
1075          Length := Length + Len;
1076       end Img10;
1077
1078       -----------
1079       -- Img16 --
1080       -----------
1081
1082       procedure Img16 (V : Inet_Addr_Comp_Type) is
1083       begin
1084          Buffer (Length)     := Hex_To_Char (Natural (V / 16) + 1);
1085          Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
1086          Length := Length + 2;
1087       end Img16;
1088
1089    --  Start of processing for Image
1090
1091    begin
1092       if Hex then
1093          Separator := ':';
1094       else
1095          Separator := '.';
1096       end if;
1097
1098       for J in Val'Range loop
1099          if Hex then
1100             Img16 (Val (J));
1101          else
1102             Img10 (Val (J));
1103          end if;
1104
1105          if J /= Val'Last then
1106             Buffer (Length) := Separator;
1107             Length := Length + 1;
1108          end if;
1109       end loop;
1110
1111       return Buffer (1 .. Length - 1);
1112    end Image;
1113
1114    -----------
1115    -- Image --
1116    -----------
1117
1118    function Image (Value : Inet_Addr_Type) return String is
1119    begin
1120       if Value.Family = Family_Inet then
1121          return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
1122       else
1123          return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
1124       end if;
1125    end Image;
1126
1127    -----------
1128    -- Image --
1129    -----------
1130
1131    function Image (Value : Sock_Addr_Type) return String is
1132       Port : constant String := Value.Port'Img;
1133    begin
1134       return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1135    end Image;
1136
1137    -----------
1138    -- Image --
1139    -----------
1140
1141    function Image (Socket : Socket_Type) return String is
1142    begin
1143       return Socket'Img;
1144    end Image;
1145
1146    ---------------
1147    -- Inet_Addr --
1148    ---------------
1149
1150    function Inet_Addr (Image : String) return Inet_Addr_Type is
1151       use Interfaces.C.Strings;
1152
1153       Img    : chars_ptr;
1154       Res    : C.int;
1155       Result : Inet_Addr_Type;
1156
1157    begin
1158       --  Special case for the all-ones broadcast address: this address has the
1159       --  same in_addr_t value as Failure, and thus cannot be properly returned
1160       --  by inet_addr(3).
1161
1162       if Image = "255.255.255.255" then
1163          return Broadcast_Inet_Addr;
1164
1165       --  Special case for an empty Image as on some platforms (e.g. Windows)
1166       --  calling Inet_Addr("") will not return an error.
1167
1168       elsif Image = "" then
1169          Raise_Socket_Error (Constants.EINVAL);
1170       end if;
1171
1172       Img := New_String (Image);
1173       Res := C_Inet_Addr (Img);
1174       Free (Img);
1175
1176       if Res = Failure then
1177          Raise_Socket_Error (Constants.EINVAL);
1178       end if;
1179
1180       To_Inet_Addr (To_In_Addr (Res), Result);
1181       return Result;
1182    end Inet_Addr;
1183
1184    ----------------
1185    -- Initialize --
1186    ----------------
1187
1188    procedure Initialize (Process_Blocking_IO : Boolean) is
1189       Expected : constant Boolean := not Constants.Thread_Blocking_IO;
1190    begin
1191       if Process_Blocking_IO /= Expected then
1192          raise Socket_Error with
1193            "incorrect Process_Blocking_IO setting, expected " & Expected'Img;
1194       end if;
1195
1196       Initialize;
1197    end Initialize;
1198
1199    ----------------
1200    -- Initialize --
1201    ----------------
1202
1203    procedure Initialize is
1204    begin
1205       if not Initialized then
1206          Initialized := True;
1207          Thin.Initialize;
1208       end if;
1209    end Initialize;
1210
1211    --------------
1212    -- Is_Empty --
1213    --------------
1214
1215    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1216    begin
1217       return Item.Last = No_Socket;
1218    end Is_Empty;
1219
1220    -------------------
1221    -- Is_IP_Address --
1222    -------------------
1223
1224    function Is_IP_Address (Name : String) return Boolean is
1225    begin
1226       for J in Name'Range loop
1227          if Name (J) /= '.'
1228            and then Name (J) not in '0' .. '9'
1229          then
1230             return False;
1231          end if;
1232       end loop;
1233
1234       return True;
1235    end Is_IP_Address;
1236
1237    ------------
1238    -- Is_Set --
1239    ------------
1240
1241    function Is_Set
1242      (Item   : Socket_Set_Type;
1243       Socket : Socket_Type) return Boolean
1244    is
1245    begin
1246       return Item.Last /= No_Socket
1247         and then Socket <= Item.Last
1248         and then Is_Socket_In_Set (Item.Set, C.int (Socket)) /= 0;
1249    end Is_Set;
1250
1251    -------------------
1252    -- Listen_Socket --
1253    -------------------
1254
1255    procedure Listen_Socket
1256      (Socket : Socket_Type;
1257       Length : Positive := 15)
1258    is
1259       Res : constant C.int := C_Listen (C.int (Socket), C.int (Length));
1260    begin
1261       if Res = Failure then
1262          Raise_Socket_Error (Socket_Errno);
1263       end if;
1264    end Listen_Socket;
1265
1266    ------------
1267    -- Narrow --
1268    ------------
1269
1270    procedure Narrow (Item : in out Socket_Set_Type) is
1271       Last : aliased C.int := C.int (Item.Last);
1272    begin
1273       if Item.Set /= No_Socket_Set then
1274          Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
1275          Item.Last := Socket_Type (Last);
1276       end if;
1277    end Narrow;
1278
1279    -------------------
1280    -- Official_Name --
1281    -------------------
1282
1283    function Official_Name (E : Host_Entry_Type) return String is
1284    begin
1285       return To_String (E.Official);
1286    end Official_Name;
1287
1288    -------------------
1289    -- Official_Name --
1290    -------------------
1291
1292    function Official_Name (S : Service_Entry_Type) return String is
1293    begin
1294       return To_String (S.Official);
1295    end Official_Name;
1296
1297    -----------------
1298    -- Port_Number --
1299    -----------------
1300
1301    function Port_Number (S : Service_Entry_Type) return Port_Type is
1302    begin
1303       return S.Port;
1304    end Port_Number;
1305
1306    -------------------
1307    -- Protocol_Name --
1308    -------------------
1309
1310    function Protocol_Name (S : Service_Entry_Type) return String is
1311    begin
1312       return To_String (S.Protocol);
1313    end Protocol_Name;
1314
1315    ----------------------
1316    -- Raise_Host_Error --
1317    ----------------------
1318
1319    procedure Raise_Host_Error (H_Error : Integer) is
1320    begin
1321       Ada.Exceptions.Raise_Exception (Host_Error'Identity,
1322         Err_Code_Image (H_Error)
1323         & C.Strings.Value (Host_Error_Messages.Host_Error_Message (H_Error)));
1324    end Raise_Host_Error;
1325
1326    ------------------------
1327    -- Raise_Socket_Error --
1328    ------------------------
1329
1330    procedure Raise_Socket_Error (Error : Integer) is
1331       use type C.Strings.chars_ptr;
1332    begin
1333       Ada.Exceptions.Raise_Exception (Socket_Error'Identity,
1334         Err_Code_Image (Error)
1335         & C.Strings.Value (Socket_Error_Message (Error)));
1336    end Raise_Socket_Error;
1337
1338    ----------
1339    -- Read --
1340    ----------
1341
1342    procedure Read
1343      (Stream : in out Datagram_Socket_Stream_Type;
1344       Item   : out Ada.Streams.Stream_Element_Array;
1345       Last   : out Ada.Streams.Stream_Element_Offset)
1346    is
1347       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1348       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1349       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1350
1351    begin
1352       loop
1353          Receive_Socket
1354            (Stream.Socket,
1355             Item (First .. Max),
1356             Index,
1357             Stream.From);
1358
1359          Last := Index;
1360
1361          --  Exit when all or zero data received. Zero means that the socket
1362          --  peer is closed.
1363
1364          exit when Index < First or else Index = Max;
1365
1366          First := Index + 1;
1367       end loop;
1368    end Read;
1369
1370    ----------
1371    -- Read --
1372    ----------
1373
1374    procedure Read
1375      (Stream : in out Stream_Socket_Stream_Type;
1376       Item   : out Ada.Streams.Stream_Element_Array;
1377       Last   : out Ada.Streams.Stream_Element_Offset)
1378    is
1379       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1380       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1381       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1382
1383    begin
1384       loop
1385          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1386          Last  := Index;
1387
1388          --  Exit when all or zero data received. Zero means that the socket
1389          --  peer is closed.
1390
1391          exit when Index < First or else Index = Max;
1392
1393          First := Index + 1;
1394       end loop;
1395    end Read;
1396
1397    --------------------
1398    -- Receive_Socket --
1399    --------------------
1400
1401    procedure Receive_Socket
1402      (Socket : Socket_Type;
1403       Item   : out Ada.Streams.Stream_Element_Array;
1404       Last   : out Ada.Streams.Stream_Element_Offset;
1405       Flags  : Request_Flag_Type := No_Request_Flag)
1406    is
1407       use type Ada.Streams.Stream_Element_Offset;
1408
1409       Res : C.int;
1410
1411    begin
1412       Res :=
1413         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1414
1415       if Res = Failure then
1416          Raise_Socket_Error (Socket_Errno);
1417       end if;
1418
1419       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1420    end Receive_Socket;
1421
1422    --------------------
1423    -- Receive_Socket --
1424    --------------------
1425
1426    procedure Receive_Socket
1427      (Socket : Socket_Type;
1428       Item   : out Ada.Streams.Stream_Element_Array;
1429       Last   : out Ada.Streams.Stream_Element_Offset;
1430       From   : out Sock_Addr_Type;
1431       Flags  : Request_Flag_Type := No_Request_Flag)
1432    is
1433       use type Ada.Streams.Stream_Element_Offset;
1434
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'Unchecked_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       use type Ada.Streams.Stream_Element_Offset;
1608
1609       Res : C.int;
1610
1611    begin
1612       Res :=
1613         C_Send
1614           (C.int (Socket),
1615            Item'Address,
1616            Item'Length,
1617            Set_Forced_Flags (To_Int (Flags)));
1618
1619       if Res = Failure then
1620          Raise_Socket_Error (Socket_Errno);
1621       end if;
1622
1623       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1624    end Send_Socket;
1625
1626    -----------------
1627    -- Send_Socket --
1628    -----------------
1629
1630    procedure Send_Socket
1631      (Socket : Socket_Type;
1632       Item   : Ada.Streams.Stream_Element_Array;
1633       Last   : out Ada.Streams.Stream_Element_Offset;
1634       To     : Sock_Addr_Type;
1635       Flags  : Request_Flag_Type := No_Request_Flag)
1636    is
1637       use type Ada.Streams.Stream_Element_Offset;
1638
1639       Res : C.int;
1640       Sin : aliased Sockaddr_In;
1641       Len : constant C.int := Sin'Size / 8;
1642
1643    begin
1644       Set_Length (Sin'Unchecked_Access, Len);
1645       Set_Family (Sin'Unchecked_Access, Families (To.Family));
1646       Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
1647       Set_Port
1648         (Sin'Unchecked_Access,
1649          Short_To_Network (C.unsigned_short (To.Port)));
1650
1651       Res := C_Sendto
1652         (C.int (Socket),
1653          Item'Address,
1654          Item'Length,
1655          Set_Forced_Flags (To_Int (Flags)),
1656          Sin'Unchecked_Access,
1657          Len);
1658
1659       if Res = Failure then
1660          Raise_Socket_Error (Socket_Errno);
1661       end if;
1662
1663       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1664    end Send_Socket;
1665
1666    -----------------
1667    -- Send_Vector --
1668    -----------------
1669
1670    procedure Send_Vector
1671      (Socket : Socket_Type;
1672       Vector : Vector_Type;
1673       Count  : out Ada.Streams.Stream_Element_Count)
1674    is
1675       Res            : C.int;
1676       Iov_Count      : C.int;
1677       This_Iov_Count : C.int;
1678
1679    begin
1680       Count := 0;
1681       Iov_Count := 0;
1682       while Iov_Count < Vector'Length loop
1683
1684          pragma Warnings (Off);
1685          --  Following test may be compile time known on some targets
1686
1687          if Vector'Length - Iov_Count > Constants.IOV_MAX then
1688             This_Iov_Count := Constants.IOV_MAX;
1689          else
1690             This_Iov_Count := Vector'Length - Iov_Count;
1691          end if;
1692
1693          pragma Warnings (On);
1694
1695          Res :=
1696            C_Writev
1697              (C.int (Socket),
1698               Vector (Vector'First + Integer (Iov_Count))'Address,
1699               This_Iov_Count);
1700
1701          if Res = Failure then
1702             Raise_Socket_Error (Socket_Errno);
1703          end if;
1704
1705          Count := Count + Ada.Streams.Stream_Element_Count (Res);
1706          Iov_Count := Iov_Count + This_Iov_Count;
1707       end loop;
1708    end Send_Vector;
1709
1710    ---------
1711    -- Set --
1712    ---------
1713
1714    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1715    begin
1716       if Item.Set = No_Socket_Set then
1717          Item.Set  := New_Socket_Set (No_Socket_Set);
1718          Item.Last := Socket;
1719
1720       elsif Item.Last < Socket then
1721          Item.Last := Socket;
1722       end if;
1723
1724       Insert_Socket_In_Set (Item.Set, C.int (Socket));
1725    end Set;
1726
1727    ----------------------
1728    -- Set_Forced_Flags --
1729    ----------------------
1730
1731    function Set_Forced_Flags (F : C.int) return C.int is
1732       use type C.unsigned;
1733       function To_unsigned is
1734         new Ada.Unchecked_Conversion (C.int, C.unsigned);
1735       function To_int is
1736         new Ada.Unchecked_Conversion (C.unsigned, C.int);
1737    begin
1738       return To_int (To_unsigned (F) or Constants.MSG_Forced_Flags);
1739    end Set_Forced_Flags;
1740
1741    -----------------------
1742    -- Set_Socket_Option --
1743    -----------------------
1744
1745    procedure Set_Socket_Option
1746      (Socket : Socket_Type;
1747       Level  : Level_Type := Socket_Level;
1748       Option : Option_Type)
1749    is
1750       V8  : aliased Two_Ints;
1751       V4  : aliased C.int;
1752       V1  : aliased C.unsigned_char;
1753       VT  : aliased Timeval;
1754       Len : C.int;
1755       Add : System.Address := Null_Address;
1756       Res : C.int;
1757
1758    begin
1759       case Option.Name is
1760          when Keep_Alive      |
1761               Reuse_Address   |
1762               Broadcast       |
1763               No_Delay        =>
1764             V4  := C.int (Boolean'Pos (Option.Enabled));
1765             Len := V4'Size / 8;
1766             Add := V4'Address;
1767
1768          when Linger          =>
1769             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1770             V8 (V8'Last)  := C.int (Option.Seconds);
1771             Len := V8'Size / 8;
1772             Add := V8'Address;
1773
1774          when Send_Buffer     |
1775               Receive_Buffer  =>
1776             V4  := C.int (Option.Size);
1777             Len := V4'Size / 8;
1778             Add := V4'Address;
1779
1780          when Error           =>
1781             V4  := C.int (Boolean'Pos (True));
1782             Len := V4'Size / 8;
1783             Add := V4'Address;
1784
1785          when Add_Membership  |
1786               Drop_Membership =>
1787             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
1788             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
1789             Len := V8'Size / 8;
1790             Add := V8'Address;
1791
1792          when Multicast_If    =>
1793             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
1794             Len := V4'Size / 8;
1795             Add := V4'Address;
1796
1797          when Multicast_TTL   =>
1798             V1  := C.unsigned_char (Option.Time_To_Live);
1799             Len := V1'Size / 8;
1800             Add := V1'Address;
1801
1802          when Multicast_Loop  =>
1803             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
1804             Len := V1'Size / 8;
1805             Add := V1'Address;
1806
1807          when Send_Timeout    |
1808               Receive_Timeout =>
1809             VT  := To_Timeval (Option.Timeout);
1810             Len := VT'Size / 8;
1811             Add := VT'Address;
1812
1813       end case;
1814
1815       Res := C_Setsockopt
1816         (C.int (Socket),
1817          Levels (Level),
1818          Options (Option.Name),
1819          Add, Len);
1820
1821       if Res = Failure then
1822          Raise_Socket_Error (Socket_Errno);
1823       end if;
1824    end Set_Socket_Option;
1825
1826    ----------------------
1827    -- Short_To_Network --
1828    ----------------------
1829
1830    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
1831       use type C.unsigned_short;
1832
1833    begin
1834       --  Big-endian case. No conversion needed. On these platforms,
1835       --  htons() defaults to a null procedure.
1836
1837       pragma Warnings (Off);
1838       --  Since the test can generate "always True/False" warning
1839
1840       if Default_Bit_Order = High_Order_First then
1841          return S;
1842
1843          pragma Warnings (On);
1844
1845       --  Little-endian case. We must swap the high and low bytes of this
1846       --  short to make the port number network compliant.
1847
1848       else
1849          return (S / 256) + (S mod 256) * 256;
1850       end if;
1851    end Short_To_Network;
1852
1853    ---------------------
1854    -- Shutdown_Socket --
1855    ---------------------
1856
1857    procedure Shutdown_Socket
1858      (Socket : Socket_Type;
1859       How    : Shutmode_Type := Shut_Read_Write)
1860    is
1861       Res : C.int;
1862
1863    begin
1864       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1865
1866       if Res = Failure then
1867          Raise_Socket_Error (Socket_Errno);
1868       end if;
1869    end Shutdown_Socket;
1870
1871    ------------
1872    -- Stream --
1873    ------------
1874
1875    function Stream
1876      (Socket  : Socket_Type;
1877       Send_To : Sock_Addr_Type) return Stream_Access
1878    is
1879       S : Datagram_Socket_Stream_Access;
1880
1881    begin
1882       S        := new Datagram_Socket_Stream_Type;
1883       S.Socket := Socket;
1884       S.To     := Send_To;
1885       S.From   := Get_Socket_Name (Socket);
1886       return Stream_Access (S);
1887    end Stream;
1888
1889    ------------
1890    -- Stream --
1891    ------------
1892
1893    function Stream (Socket : Socket_Type) return Stream_Access is
1894       S : Stream_Socket_Stream_Access;
1895    begin
1896       S := new Stream_Socket_Stream_Type;
1897       S.Socket := Socket;
1898       return Stream_Access (S);
1899    end Stream;
1900
1901    ----------
1902    -- To_C --
1903    ----------
1904
1905    function To_C (Socket : Socket_Type) return Integer is
1906    begin
1907       return Integer (Socket);
1908    end To_C;
1909
1910    -----------------
1911    -- To_Duration --
1912    -----------------
1913
1914    function To_Duration (Val : Timeval) return Timeval_Duration is
1915    begin
1916       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
1917    end To_Duration;
1918
1919    -------------------
1920    -- To_Host_Entry --
1921    -------------------
1922
1923    function To_Host_Entry (E : Hostent) return Host_Entry_Type is
1924       use type C.size_t;
1925
1926       Official : constant String :=
1927                   C.Strings.Value (E.H_Name);
1928
1929       Aliases : constant Chars_Ptr_Array :=
1930                   Chars_Ptr_Pointers.Value (E.H_Aliases);
1931       --  H_Aliases points to a list of name aliases. The list is terminated by
1932       --  a NULL pointer.
1933
1934       Addresses : constant In_Addr_Access_Array :=
1935                     In_Addr_Access_Pointers.Value (E.H_Addr_List);
1936       --  H_Addr_List points to a list of binary addresses (in network byte
1937       --  order). The list is terminated by a NULL pointer.
1938       --
1939       --  H_Length is not used because it is currently only set to 4.
1940       --  H_Addrtype is always AF_INET
1941
1942       Result : Host_Entry_Type
1943                  (Aliases_Length   => Aliases'Length - 1,
1944                   Addresses_Length => Addresses'Length - 1);
1945       --  The last element is a null pointer
1946
1947       Source : C.size_t;
1948       Target : Natural;
1949
1950    begin
1951       Result.Official := To_Name (Official);
1952
1953       Source := Aliases'First;
1954       Target := Result.Aliases'First;
1955       while Target <= Result.Aliases_Length loop
1956          Result.Aliases (Target) :=
1957            To_Name (C.Strings.Value (Aliases (Source)));
1958          Source := Source + 1;
1959          Target := Target + 1;
1960       end loop;
1961
1962       Source := Addresses'First;
1963       Target := Result.Addresses'First;
1964       while Target <= Result.Addresses_Length loop
1965          To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
1966          Source := Source + 1;
1967          Target := Target + 1;
1968       end loop;
1969
1970       return Result;
1971    end To_Host_Entry;
1972
1973    ----------------
1974    -- To_In_Addr --
1975    ----------------
1976
1977    function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1978    begin
1979       if Addr.Family = Family_Inet then
1980          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1981                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1982                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1983                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1984       end if;
1985
1986       raise Socket_Error;
1987    end To_In_Addr;
1988
1989    ------------------
1990    -- To_Inet_Addr --
1991    ------------------
1992
1993    procedure To_Inet_Addr
1994      (Addr   : In_Addr;
1995       Result : out Inet_Addr_Type) is
1996    begin
1997       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1998       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1999       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
2000       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
2001    end To_Inet_Addr;
2002
2003    ------------
2004    -- To_Int --
2005    ------------
2006
2007    function To_Int (F : Request_Flag_Type) return C.int
2008    is
2009       Current : Request_Flag_Type := F;
2010       Result  : C.int := 0;
2011
2012    begin
2013       for J in Flags'Range loop
2014          exit when Current = 0;
2015
2016          if Current mod 2 /= 0 then
2017             if Flags (J) = -1 then
2018                Raise_Socket_Error (Constants.EOPNOTSUPP);
2019             end if;
2020
2021             Result := Result + Flags (J);
2022          end if;
2023
2024          Current := Current / 2;
2025       end loop;
2026
2027       return Result;
2028    end To_Int;
2029
2030    -------------
2031    -- To_Name --
2032    -------------
2033
2034    function To_Name (N : String) return Name_Type is
2035    begin
2036       return Name_Type'(N'Length, N);
2037    end To_Name;
2038
2039    ----------------------
2040    -- To_Service_Entry --
2041    ----------------------
2042
2043    function To_Service_Entry (E : Servent) return Service_Entry_Type is
2044       use type C.size_t;
2045
2046       Official : constant String := C.Strings.Value (E.S_Name);
2047
2048       Aliases : constant Chars_Ptr_Array :=
2049                   Chars_Ptr_Pointers.Value (E.S_Aliases);
2050       --  S_Aliases points to a list of name aliases. The list is
2051       --  terminated by a NULL pointer.
2052
2053       Protocol : constant String := C.Strings.Value (E.S_Proto);
2054
2055       Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
2056       --  The last element is a null pointer
2057
2058       Source : C.size_t;
2059       Target : Natural;
2060
2061    begin
2062       Result.Official := To_Name (Official);
2063
2064       Source := Aliases'First;
2065       Target := Result.Aliases'First;
2066       while Target <= Result.Aliases_Length loop
2067          Result.Aliases (Target) :=
2068            To_Name (C.Strings.Value (Aliases (Source)));
2069          Source := Source + 1;
2070          Target := Target + 1;
2071       end loop;
2072
2073       Result.Port :=
2074         Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2075
2076       Result.Protocol := To_Name (Protocol);
2077       return Result;
2078    end To_Service_Entry;
2079
2080    ---------------
2081    -- To_String --
2082    ---------------
2083
2084    function To_String (HN : Name_Type) return String is
2085    begin
2086       return HN.Name (1 .. HN.Length);
2087    end To_String;
2088
2089    ----------------
2090    -- To_Timeval --
2091    ----------------
2092
2093    function To_Timeval (Val : Timeval_Duration) return Timeval is
2094       S  : time_t;
2095       uS : suseconds_t;
2096
2097    begin
2098       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2099
2100       if Val = 0.0 then
2101          S  := 0;
2102          uS := 0;
2103
2104       --  Normal case where we do round down
2105
2106       else
2107          S  := time_t (Val - 0.5);
2108          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2109       end if;
2110
2111       return (S, uS);
2112    end To_Timeval;
2113
2114    -----------
2115    -- Write --
2116    -----------
2117
2118    procedure Write
2119      (Stream : in out Datagram_Socket_Stream_Type;
2120       Item   : Ada.Streams.Stream_Element_Array)
2121    is
2122       First : Ada.Streams.Stream_Element_Offset          := Item'First;
2123       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
2124       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2125
2126    begin
2127       loop
2128          Send_Socket
2129            (Stream.Socket,
2130             Item (First .. Max),
2131             Index,
2132             Stream.To);
2133
2134          --  Exit when all or zero data sent. Zero means that the socket has
2135          --  been closed by peer.
2136
2137          exit when Index < First or else Index = Max;
2138
2139          First := Index + 1;
2140       end loop;
2141
2142       if Index /= Max then
2143          raise Socket_Error;
2144       end if;
2145    end Write;
2146
2147    -----------
2148    -- Write --
2149    -----------
2150
2151    procedure Write
2152      (Stream : in out Stream_Socket_Stream_Type;
2153       Item   : Ada.Streams.Stream_Element_Array)
2154    is
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;