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       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       Res : C.int;
1408
1409    begin
1410       Res :=
1411         C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags));
1412
1413       if Res = Failure then
1414          Raise_Socket_Error (Socket_Errno);
1415       end if;
1416
1417       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1418    end Receive_Socket;
1419
1420    --------------------
1421    -- Receive_Socket --
1422    --------------------
1423
1424    procedure Receive_Socket
1425      (Socket : Socket_Type;
1426       Item   : out Ada.Streams.Stream_Element_Array;
1427       Last   : out Ada.Streams.Stream_Element_Offset;
1428       From   : out Sock_Addr_Type;
1429       Flags  : Request_Flag_Type := No_Request_Flag)
1430    is
1431       Res : C.int;
1432       Sin : aliased Sockaddr_In;
1433       Len : aliased C.int := Sin'Size / 8;
1434
1435    begin
1436       Res :=
1437         C_Recvfrom
1438           (C.int (Socket),
1439            Item'Address,
1440            Item'Length,
1441            To_Int (Flags),
1442            Sin'Unchecked_Access,
1443            Len'Unchecked_Access);
1444
1445       if Res = Failure then
1446          Raise_Socket_Error (Socket_Errno);
1447       end if;
1448
1449       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1450
1451       To_Inet_Addr (Sin.Sin_Addr, From.Addr);
1452       From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
1453    end Receive_Socket;
1454
1455    -------------------
1456    -- Resolve_Error --
1457    -------------------
1458
1459    function Resolve_Error
1460      (Error_Value : Integer;
1461       From_Errno  : Boolean := True) return Error_Type
1462    is
1463       use GNAT.Sockets.Constants;
1464
1465    begin
1466       if not From_Errno then
1467          case Error_Value is
1468             when Constants.HOST_NOT_FOUND => return Unknown_Host;
1469             when Constants.TRY_AGAIN      => return Host_Name_Lookup_Failure;
1470             when Constants.NO_RECOVERY    => return Non_Recoverable_Error;
1471             when Constants.NO_DATA        => return Unknown_Server_Error;
1472             when others                   => return Cannot_Resolve_Error;
1473          end case;
1474       end if;
1475
1476       case Error_Value is
1477          when ENOERROR        => return Success;
1478          when EACCES          => return Permission_Denied;
1479          when EADDRINUSE      => return Address_Already_In_Use;
1480          when EADDRNOTAVAIL   => return Cannot_Assign_Requested_Address;
1481          when EAFNOSUPPORT    => return
1482                                  Address_Family_Not_Supported_By_Protocol;
1483          when EALREADY        => return Operation_Already_In_Progress;
1484          when EBADF           => return Bad_File_Descriptor;
1485          when ECONNABORTED    => return Software_Caused_Connection_Abort;
1486          when ECONNREFUSED    => return Connection_Refused;
1487          when ECONNRESET      => return Connection_Reset_By_Peer;
1488          when EDESTADDRREQ    => return Destination_Address_Required;
1489          when EFAULT          => return Bad_Address;
1490          when EHOSTDOWN       => return Host_Is_Down;
1491          when EHOSTUNREACH    => return No_Route_To_Host;
1492          when EINPROGRESS     => return Operation_Now_In_Progress;
1493          when EINTR           => return Interrupted_System_Call;
1494          when EINVAL          => return Invalid_Argument;
1495          when EIO             => return Input_Output_Error;
1496          when EISCONN         => return Transport_Endpoint_Already_Connected;
1497          when ELOOP           => return Too_Many_Symbolic_Links;
1498          when EMFILE          => return Too_Many_Open_Files;
1499          when EMSGSIZE        => return Message_Too_Long;
1500          when ENAMETOOLONG    => return File_Name_Too_Long;
1501          when ENETDOWN        => return Network_Is_Down;
1502          when ENETRESET       => return
1503                                  Network_Dropped_Connection_Because_Of_Reset;
1504          when ENETUNREACH     => return Network_Is_Unreachable;
1505          when ENOBUFS         => return No_Buffer_Space_Available;
1506          when ENOPROTOOPT     => return Protocol_Not_Available;
1507          when ENOTCONN        => return Transport_Endpoint_Not_Connected;
1508          when ENOTSOCK        => return Socket_Operation_On_Non_Socket;
1509          when EOPNOTSUPP      => return Operation_Not_Supported;
1510          when EPFNOSUPPORT    => return Protocol_Family_Not_Supported;
1511          when EPROTONOSUPPORT => return Protocol_Not_Supported;
1512          when EPROTOTYPE      => return Protocol_Wrong_Type_For_Socket;
1513          when ESHUTDOWN       => return
1514                                  Cannot_Send_After_Transport_Endpoint_Shutdown;
1515          when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1516          when ETIMEDOUT       => return Connection_Timed_Out;
1517          when ETOOMANYREFS    => return Too_Many_References;
1518          when EWOULDBLOCK     => return Resource_Temporarily_Unavailable;
1519          when others          => null;
1520       end case;
1521
1522       return Cannot_Resolve_Error;
1523    end Resolve_Error;
1524
1525    -----------------------
1526    -- Resolve_Exception --
1527    -----------------------
1528
1529    function Resolve_Exception
1530      (Occurrence : Exception_Occurrence) return Error_Type
1531    is
1532       Id    : constant Exception_Id := Exception_Identity (Occurrence);
1533       Msg   : constant String       := Exception_Message (Occurrence);
1534       First : Natural;
1535       Last  : Natural;
1536       Val   : Integer;
1537
1538    begin
1539       First := Msg'First;
1540       while First <= Msg'Last
1541         and then Msg (First) not in '0' .. '9'
1542       loop
1543          First := First + 1;
1544       end loop;
1545
1546       if First > Msg'Last then
1547          return Cannot_Resolve_Error;
1548       end if;
1549
1550       Last := First;
1551       while Last < Msg'Last
1552         and then Msg (Last + 1) in '0' .. '9'
1553       loop
1554          Last := Last + 1;
1555       end loop;
1556
1557       Val := Integer'Value (Msg (First .. Last));
1558
1559       if Id = Socket_Error_Id then
1560          return Resolve_Error (Val);
1561       elsif Id = Host_Error_Id then
1562          return Resolve_Error (Val, False);
1563       else
1564          return Cannot_Resolve_Error;
1565       end if;
1566    end Resolve_Exception;
1567
1568    --------------------
1569    -- Receive_Vector --
1570    --------------------
1571
1572    procedure Receive_Vector
1573      (Socket : Socket_Type;
1574       Vector : Vector_Type;
1575       Count  : out Ada.Streams.Stream_Element_Count)
1576    is
1577       Res : C.int;
1578
1579    begin
1580       Res :=
1581         C_Readv
1582           (C.int (Socket),
1583            Vector'Address,
1584            Vector'Length);
1585
1586       if Res = Failure then
1587          Raise_Socket_Error (Socket_Errno);
1588       end if;
1589
1590       Count := Ada.Streams.Stream_Element_Count (Res);
1591    end Receive_Vector;
1592
1593    -----------------
1594    -- Send_Socket --
1595    -----------------
1596
1597    procedure Send_Socket
1598      (Socket : Socket_Type;
1599       Item   : Ada.Streams.Stream_Element_Array;
1600       Last   : out Ada.Streams.Stream_Element_Offset;
1601       Flags  : Request_Flag_Type := No_Request_Flag)
1602    is
1603       Res : C.int;
1604
1605    begin
1606       Res :=
1607         C_Send
1608           (C.int (Socket),
1609            Item'Address,
1610            Item'Length,
1611            Set_Forced_Flags (To_Int (Flags)));
1612
1613       if Res = Failure then
1614          Raise_Socket_Error (Socket_Errno);
1615       end if;
1616
1617       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1618    end Send_Socket;
1619
1620    -----------------
1621    -- Send_Socket --
1622    -----------------
1623
1624    procedure Send_Socket
1625      (Socket : Socket_Type;
1626       Item   : Ada.Streams.Stream_Element_Array;
1627       Last   : out Ada.Streams.Stream_Element_Offset;
1628       To     : Sock_Addr_Type;
1629       Flags  : Request_Flag_Type := No_Request_Flag)
1630    is
1631       Res : C.int;
1632       Sin : aliased Sockaddr_In;
1633       Len : constant C.int := Sin'Size / 8;
1634
1635    begin
1636       Set_Length (Sin'Unchecked_Access, Len);
1637       Set_Family (Sin'Unchecked_Access, Families (To.Family));
1638       Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
1639       Set_Port
1640         (Sin'Unchecked_Access,
1641          Short_To_Network (C.unsigned_short (To.Port)));
1642
1643       Res := C_Sendto
1644         (C.int (Socket),
1645          Item'Address,
1646          Item'Length,
1647          Set_Forced_Flags (To_Int (Flags)),
1648          Sin'Unchecked_Access,
1649          Len);
1650
1651       if Res = Failure then
1652          Raise_Socket_Error (Socket_Errno);
1653       end if;
1654
1655       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1656    end Send_Socket;
1657
1658    -----------------
1659    -- Send_Vector --
1660    -----------------
1661
1662    procedure Send_Vector
1663      (Socket : Socket_Type;
1664       Vector : Vector_Type;
1665       Count  : out Ada.Streams.Stream_Element_Count)
1666    is
1667       Res            : C.int;
1668       Iov_Count      : C.int;
1669       This_Iov_Count : C.int;
1670
1671    begin
1672       Count := 0;
1673       Iov_Count := 0;
1674       while Iov_Count < Vector'Length loop
1675
1676          pragma Warnings (Off);
1677          --  Following test may be compile time known on some targets
1678
1679          if Vector'Length - Iov_Count > Constants.IOV_MAX then
1680             This_Iov_Count := Constants.IOV_MAX;
1681          else
1682             This_Iov_Count := Vector'Length - Iov_Count;
1683          end if;
1684
1685          pragma Warnings (On);
1686
1687          Res :=
1688            C_Writev
1689              (C.int (Socket),
1690               Vector (Vector'First + Integer (Iov_Count))'Address,
1691               This_Iov_Count);
1692
1693          if Res = Failure then
1694             Raise_Socket_Error (Socket_Errno);
1695          end if;
1696
1697          Count := Count + Ada.Streams.Stream_Element_Count (Res);
1698          Iov_Count := Iov_Count + This_Iov_Count;
1699       end loop;
1700    end Send_Vector;
1701
1702    ---------
1703    -- Set --
1704    ---------
1705
1706    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1707    begin
1708       if Item.Set = No_Socket_Set then
1709          Item.Set  := New_Socket_Set (No_Socket_Set);
1710          Item.Last := Socket;
1711
1712       elsif Item.Last < Socket then
1713          Item.Last := Socket;
1714       end if;
1715
1716       Insert_Socket_In_Set (Item.Set, C.int (Socket));
1717    end Set;
1718
1719    ----------------------
1720    -- Set_Forced_Flags --
1721    ----------------------
1722
1723    function Set_Forced_Flags (F : C.int) return C.int is
1724       use type C.unsigned;
1725       function To_unsigned is
1726         new Ada.Unchecked_Conversion (C.int, C.unsigned);
1727       function To_int is
1728         new Ada.Unchecked_Conversion (C.unsigned, C.int);
1729    begin
1730       return To_int (To_unsigned (F) or Constants.MSG_Forced_Flags);
1731    end Set_Forced_Flags;
1732
1733    -----------------------
1734    -- Set_Socket_Option --
1735    -----------------------
1736
1737    procedure Set_Socket_Option
1738      (Socket : Socket_Type;
1739       Level  : Level_Type := Socket_Level;
1740       Option : Option_Type)
1741    is
1742       V8  : aliased Two_Ints;
1743       V4  : aliased C.int;
1744       V1  : aliased C.unsigned_char;
1745       VT  : aliased Timeval;
1746       Len : C.int;
1747       Add : System.Address := Null_Address;
1748       Res : C.int;
1749
1750    begin
1751       case Option.Name is
1752          when Keep_Alive      |
1753               Reuse_Address   |
1754               Broadcast       |
1755               No_Delay        =>
1756             V4  := C.int (Boolean'Pos (Option.Enabled));
1757             Len := V4'Size / 8;
1758             Add := V4'Address;
1759
1760          when Linger          =>
1761             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1762             V8 (V8'Last)  := C.int (Option.Seconds);
1763             Len := V8'Size / 8;
1764             Add := V8'Address;
1765
1766          when Send_Buffer     |
1767               Receive_Buffer  =>
1768             V4  := C.int (Option.Size);
1769             Len := V4'Size / 8;
1770             Add := V4'Address;
1771
1772          when Error           =>
1773             V4  := C.int (Boolean'Pos (True));
1774             Len := V4'Size / 8;
1775             Add := V4'Address;
1776
1777          when Add_Membership  |
1778               Drop_Membership =>
1779             V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
1780             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Local_Interface));
1781             Len := V8'Size / 8;
1782             Add := V8'Address;
1783
1784          when Multicast_If    =>
1785             V4  := To_Int (To_In_Addr (Option.Outgoing_If));
1786             Len := V4'Size / 8;
1787             Add := V4'Address;
1788
1789          when Multicast_TTL   =>
1790             V1  := C.unsigned_char (Option.Time_To_Live);
1791             Len := V1'Size / 8;
1792             Add := V1'Address;
1793
1794          when Multicast_Loop  =>
1795             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
1796             Len := V1'Size / 8;
1797             Add := V1'Address;
1798
1799          when Send_Timeout    |
1800               Receive_Timeout =>
1801             VT  := To_Timeval (Option.Timeout);
1802             Len := VT'Size / 8;
1803             Add := VT'Address;
1804
1805       end case;
1806
1807       Res := C_Setsockopt
1808         (C.int (Socket),
1809          Levels (Level),
1810          Options (Option.Name),
1811          Add, Len);
1812
1813       if Res = Failure then
1814          Raise_Socket_Error (Socket_Errno);
1815       end if;
1816    end Set_Socket_Option;
1817
1818    ----------------------
1819    -- Short_To_Network --
1820    ----------------------
1821
1822    function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
1823       use type C.unsigned_short;
1824
1825    begin
1826       --  Big-endian case. No conversion needed. On these platforms,
1827       --  htons() defaults to a null procedure.
1828
1829       pragma Warnings (Off);
1830       --  Since the test can generate "always True/False" warning
1831
1832       if Default_Bit_Order = High_Order_First then
1833          return S;
1834
1835          pragma Warnings (On);
1836
1837       --  Little-endian case. We must swap the high and low bytes of this
1838       --  short to make the port number network compliant.
1839
1840       else
1841          return (S / 256) + (S mod 256) * 256;
1842       end if;
1843    end Short_To_Network;
1844
1845    ---------------------
1846    -- Shutdown_Socket --
1847    ---------------------
1848
1849    procedure Shutdown_Socket
1850      (Socket : Socket_Type;
1851       How    : Shutmode_Type := Shut_Read_Write)
1852    is
1853       Res : C.int;
1854
1855    begin
1856       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1857
1858       if Res = Failure then
1859          Raise_Socket_Error (Socket_Errno);
1860       end if;
1861    end Shutdown_Socket;
1862
1863    ------------
1864    -- Stream --
1865    ------------
1866
1867    function Stream
1868      (Socket  : Socket_Type;
1869       Send_To : Sock_Addr_Type) return Stream_Access
1870    is
1871       S : Datagram_Socket_Stream_Access;
1872
1873    begin
1874       S        := new Datagram_Socket_Stream_Type;
1875       S.Socket := Socket;
1876       S.To     := Send_To;
1877       S.From   := Get_Socket_Name (Socket);
1878       return Stream_Access (S);
1879    end Stream;
1880
1881    ------------
1882    -- Stream --
1883    ------------
1884
1885    function Stream (Socket : Socket_Type) return Stream_Access is
1886       S : Stream_Socket_Stream_Access;
1887    begin
1888       S := new Stream_Socket_Stream_Type;
1889       S.Socket := Socket;
1890       return Stream_Access (S);
1891    end Stream;
1892
1893    ----------
1894    -- To_C --
1895    ----------
1896
1897    function To_C (Socket : Socket_Type) return Integer is
1898    begin
1899       return Integer (Socket);
1900    end To_C;
1901
1902    -----------------
1903    -- To_Duration --
1904    -----------------
1905
1906    function To_Duration (Val : Timeval) return Timeval_Duration is
1907    begin
1908       return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6;
1909    end To_Duration;
1910
1911    -------------------
1912    -- To_Host_Entry --
1913    -------------------
1914
1915    function To_Host_Entry (E : Hostent) return Host_Entry_Type is
1916       use type C.size_t;
1917
1918       Official : constant String :=
1919                   C.Strings.Value (E.H_Name);
1920
1921       Aliases : constant Chars_Ptr_Array :=
1922                   Chars_Ptr_Pointers.Value (E.H_Aliases);
1923       --  H_Aliases points to a list of name aliases. The list is terminated by
1924       --  a NULL pointer.
1925
1926       Addresses : constant In_Addr_Access_Array :=
1927                     In_Addr_Access_Pointers.Value (E.H_Addr_List);
1928       --  H_Addr_List points to a list of binary addresses (in network byte
1929       --  order). The list is terminated by a NULL pointer.
1930       --
1931       --  H_Length is not used because it is currently only set to 4.
1932       --  H_Addrtype is always AF_INET
1933
1934       Result : Host_Entry_Type
1935                  (Aliases_Length   => Aliases'Length - 1,
1936                   Addresses_Length => Addresses'Length - 1);
1937       --  The last element is a null pointer
1938
1939       Source : C.size_t;
1940       Target : Natural;
1941
1942    begin
1943       Result.Official := To_Name (Official);
1944
1945       Source := Aliases'First;
1946       Target := Result.Aliases'First;
1947       while Target <= Result.Aliases_Length loop
1948          Result.Aliases (Target) :=
1949            To_Name (C.Strings.Value (Aliases (Source)));
1950          Source := Source + 1;
1951          Target := Target + 1;
1952       end loop;
1953
1954       Source := Addresses'First;
1955       Target := Result.Addresses'First;
1956       while Target <= Result.Addresses_Length loop
1957          To_Inet_Addr (Addresses (Source).all, Result.Addresses (Target));
1958          Source := Source + 1;
1959          Target := Target + 1;
1960       end loop;
1961
1962       return Result;
1963    end To_Host_Entry;
1964
1965    ----------------
1966    -- To_In_Addr --
1967    ----------------
1968
1969    function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1970    begin
1971       if Addr.Family = Family_Inet then
1972          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1973                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1974                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1975                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1976       end if;
1977
1978       raise Socket_Error;
1979    end To_In_Addr;
1980
1981    ------------------
1982    -- To_Inet_Addr --
1983    ------------------
1984
1985    procedure To_Inet_Addr
1986      (Addr   : In_Addr;
1987       Result : out Inet_Addr_Type) is
1988    begin
1989       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1990       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1991       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
1992       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
1993    end To_Inet_Addr;
1994
1995    ------------
1996    -- To_Int --
1997    ------------
1998
1999    function To_Int (F : Request_Flag_Type) return C.int
2000    is
2001       Current : Request_Flag_Type := F;
2002       Result  : C.int := 0;
2003
2004    begin
2005       for J in Flags'Range loop
2006          exit when Current = 0;
2007
2008          if Current mod 2 /= 0 then
2009             if Flags (J) = -1 then
2010                Raise_Socket_Error (Constants.EOPNOTSUPP);
2011             end if;
2012
2013             Result := Result + Flags (J);
2014          end if;
2015
2016          Current := Current / 2;
2017       end loop;
2018
2019       return Result;
2020    end To_Int;
2021
2022    -------------
2023    -- To_Name --
2024    -------------
2025
2026    function To_Name (N : String) return Name_Type is
2027    begin
2028       return Name_Type'(N'Length, N);
2029    end To_Name;
2030
2031    ----------------------
2032    -- To_Service_Entry --
2033    ----------------------
2034
2035    function To_Service_Entry (E : Servent) return Service_Entry_Type is
2036       use type C.size_t;
2037
2038       Official : constant String := C.Strings.Value (E.S_Name);
2039
2040       Aliases : constant Chars_Ptr_Array :=
2041                   Chars_Ptr_Pointers.Value (E.S_Aliases);
2042       --  S_Aliases points to a list of name aliases. The list is
2043       --  terminated by a NULL pointer.
2044
2045       Protocol : constant String := C.Strings.Value (E.S_Proto);
2046
2047       Result : Service_Entry_Type (Aliases_Length => Aliases'Length - 1);
2048       --  The last element is a null pointer
2049
2050       Source : C.size_t;
2051       Target : Natural;
2052
2053    begin
2054       Result.Official := To_Name (Official);
2055
2056       Source := Aliases'First;
2057       Target := Result.Aliases'First;
2058       while Target <= Result.Aliases_Length loop
2059          Result.Aliases (Target) :=
2060            To_Name (C.Strings.Value (Aliases (Source)));
2061          Source := Source + 1;
2062          Target := Target + 1;
2063       end loop;
2064
2065       Result.Port :=
2066         Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
2067
2068       Result.Protocol := To_Name (Protocol);
2069       return Result;
2070    end To_Service_Entry;
2071
2072    ---------------
2073    -- To_String --
2074    ---------------
2075
2076    function To_String (HN : Name_Type) return String is
2077    begin
2078       return HN.Name (1 .. HN.Length);
2079    end To_String;
2080
2081    ----------------
2082    -- To_Timeval --
2083    ----------------
2084
2085    function To_Timeval (Val : Timeval_Duration) return Timeval is
2086       S  : time_t;
2087       uS : suseconds_t;
2088
2089    begin
2090       --  If zero, set result as zero (otherwise it gets rounded down to -1)
2091
2092       if Val = 0.0 then
2093          S  := 0;
2094          uS := 0;
2095
2096       --  Normal case where we do round down
2097
2098       else
2099          S  := time_t (Val - 0.5);
2100          uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S)));
2101       end if;
2102
2103       return (S, uS);
2104    end To_Timeval;
2105
2106    -----------
2107    -- Write --
2108    -----------
2109
2110    procedure Write
2111      (Stream : in out Datagram_Socket_Stream_Type;
2112       Item   : Ada.Streams.Stream_Element_Array)
2113    is
2114       First : Ada.Streams.Stream_Element_Offset          := Item'First;
2115       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
2116       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2117
2118    begin
2119       loop
2120          Send_Socket
2121            (Stream.Socket,
2122             Item (First .. Max),
2123             Index,
2124             Stream.To);
2125
2126          --  Exit when all or zero data sent. Zero means that the socket has
2127          --  been closed by peer.
2128
2129          exit when Index < First or else Index = Max;
2130
2131          First := Index + 1;
2132       end loop;
2133
2134       if Index /= Max then
2135          raise Socket_Error;
2136       end if;
2137    end Write;
2138
2139    -----------
2140    -- Write --
2141    -----------
2142
2143    procedure Write
2144      (Stream : in out Stream_Socket_Stream_Type;
2145       Item   : Ada.Streams.Stream_Element_Array)
2146    is
2147       First : Ada.Streams.Stream_Element_Offset          := Item'First;
2148       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
2149       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
2150
2151    begin
2152       loop
2153          Send_Socket (Stream.Socket, Item (First .. Max), Index);
2154
2155          --  Exit when all or zero data sent. Zero means that the socket has
2156          --  been closed by peer.
2157
2158          exit when Index < First or else Index = Max;
2159
2160          First := Index + 1;
2161       end loop;
2162
2163       if Index /= Max then
2164          raise Socket_Error;
2165       end if;
2166    end Write;
2167
2168 end GNAT.Sockets;