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