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 --                            $Revision: 1.21 $
  10 --                                                                          --
  11 --              Copyright (C) 2001 Ada Core Technologies, Inc.              --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Streams;                use Ada.Streams;
  36 with Ada.Exceptions;             use Ada.Exceptions;
  37 with Ada.Unchecked_Deallocation;
  38 with Ada.Unchecked_Conversion;
  39
  40 with Interfaces.C.Strings;
  41
  42 with GNAT.OS_Lib;                use GNAT.OS_Lib;
  43 with GNAT.Sockets.Constants;
  44 with GNAT.Sockets.Thin;          use GNAT.Sockets.Thin;
  45 with GNAT.Task_Lock;
  46
  47 with GNAT.Sockets.Linker_Options;
  48 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
  49 --  Need to include pragma Linker_Options which is platform dependent.
  50
  51 with System; use System;
  52
  53 package body GNAT.Sockets is
  54
  55    use type C.int, System.Address;
  56
  57    Finalized   : Boolean := False;
  58    Initialized : Boolean := False;
  59
  60    --  Correspondance tables
  61
  62    Families : constant array (Family_Type) of C.int :=
  63      (Family_Inet  => Constants.AF_INET,
  64       Family_Inet6 => Constants.AF_INET6);
  65
  66    Levels : constant array (Level_Type) of C.int :=
  67      (Socket_Level              => Constants.SOL_SOCKET,
  68       IP_Protocol_For_IP_Level  => Constants.IPPROTO_IP,
  69       IP_Protocol_For_UDP_Level => Constants.IPPROTO_UDP,
  70       IP_Protocol_For_TCP_Level => Constants.IPPROTO_TCP);
  71
  72    Modes : constant array (Mode_Type) of C.int :=
  73      (Socket_Stream   => Constants.SOCK_STREAM,
  74       Socket_Datagram => Constants.SOCK_DGRAM);
  75
  76    Shutmodes : constant array (Shutmode_Type) of C.int :=
  77      (Shut_Read       => Constants.SHUT_RD,
  78       Shut_Write      => Constants.SHUT_WR,
  79       Shut_Read_Write => Constants.SHUT_RDWR);
  80
  81    Requests : constant array (Request_Name) of C.int :=
  82      (Non_Blocking_IO => Constants.FIONBIO,
  83       N_Bytes_To_Read => Constants.FIONREAD);
  84
  85    Options : constant array (Option_Name) of C.int :=
  86      (Keep_Alive      => Constants.SO_KEEPALIVE,
  87       Reuse_Address   => Constants.SO_REUSEADDR,
  88       Broadcast       => Constants.SO_BROADCAST,
  89       Send_Buffer     => Constants.SO_SNDBUF,
  90       Receive_Buffer  => Constants.SO_RCVBUF,
  91       Linger          => Constants.SO_LINGER,
  92       Error           => Constants.SO_ERROR,
  93       No_Delay        => Constants.TCP_NODELAY,
  94       Add_Membership  => Constants.IP_ADD_MEMBERSHIP,
  95       Drop_Membership => Constants.IP_DROP_MEMBERSHIP,
  96       Multicast_TTL   => Constants.IP_MULTICAST_TTL,
  97       Multicast_Loop  => Constants.IP_MULTICAST_LOOP);
  98
  99    Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
 100    Host_Error_Id : constant Exception_Id := Host_Error'Identity;
 101
 102    Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
 103    --  Use to print in hexadecimal format
 104
 105    function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
 106    function To_Int     is new Ada.Unchecked_Conversion (In_Addr, C.int);
 107
 108    -----------------------
 109    -- Local subprograms --
 110    -----------------------
 111
 112    function Resolve_Error
 113      (Error_Value : Integer;
 114       From_Errno  : Boolean := True)
 115      return         Error_Type;
 116    --  Associate an enumeration value (error_type) to en error value
 117    --  (errno). From_Errno prevents from mixing h_errno with errno.
 118
 119    function To_Host_Name (N  : String) return Host_Name_Type;
 120    function To_String    (HN : Host_Name_Type) return String;
 121    --  Conversion functions
 122
 123    function Port_To_Network
 124      (Port : C.unsigned_short)
 125       return C.unsigned_short;
 126    pragma Inline (Port_To_Network);
 127    --  Convert a port number into a network port number
 128
 129    function Network_To_Port
 130      (Net_Port : C.unsigned_short)
 131       return     C.unsigned_short
 132    renames Port_To_Network;
 133    --  Symetric operation
 134
 135    function Image
 136      (Val :  Inet_Addr_VN_Type;
 137       Hex :  Boolean := False)
 138       return String;
 139    --  Output an array of inet address components either in
 140    --  hexadecimal or in decimal mode.
 141
 142    function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr;
 143    function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type;
 144    --  Conversion functions
 145
 146    function To_Host_Entry (Host : Hostent) return Host_Entry_Type;
 147    --  Conversion function
 148
 149    function To_Timeval (Val : Duration) return Timeval;
 150    --  Separate Val in seconds and microseconds
 151
 152    procedure Raise_Socket_Error (Error : Integer);
 153    --  Raise Socket_Error with an exception message describing
 154    --  the error code.
 155
 156    procedure Raise_Host_Error (Error : Integer);
 157    --  Raise Host_Error exception with message describing error code
 158    --  (note hstrerror seems to be obsolete).
 159
 160    --  Types needed for Socket_Set_Type
 161
 162    type Socket_Set_Record is new Fd_Set;
 163
 164    procedure Free is
 165      new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type);
 166
 167    --  Types needed for Datagram_Socket_Stream_Type
 168
 169    type Datagram_Socket_Stream_Type is new Root_Stream_Type with
 170       record
 171          Socket : Socket_Type;
 172          To     : Sock_Addr_Type;
 173          From   : Sock_Addr_Type;
 174       end record;
 175
 176    type Datagram_Socket_Stream_Access is
 177      access all Datagram_Socket_Stream_Type;
 178
 179    procedure Read
 180      (Stream : in out Datagram_Socket_Stream_Type;
 181       Item   : out Ada.Streams.Stream_Element_Array;
 182       Last   : out Ada.Streams.Stream_Element_Offset);
 183
 184    procedure Write
 185      (Stream : in out Datagram_Socket_Stream_Type;
 186       Item   : Ada.Streams.Stream_Element_Array);
 187
 188    --  Types needed for Stream_Socket_Stream_Type
 189
 190    type Stream_Socket_Stream_Type is new Root_Stream_Type with
 191       record
 192          Socket : Socket_Type;
 193       end record;
 194
 195    type Stream_Socket_Stream_Access is
 196      access all Stream_Socket_Stream_Type;
 197
 198    procedure Read
 199      (Stream : in out Stream_Socket_Stream_Type;
 200       Item   : out Ada.Streams.Stream_Element_Array;
 201       Last   : out Ada.Streams.Stream_Element_Offset);
 202
 203    procedure Write
 204      (Stream : in out Stream_Socket_Stream_Type;
 205       Item   : Ada.Streams.Stream_Element_Array);
 206
 207    --------------------
 208    -- Abort_Selector --
 209    --------------------
 210
 211    procedure Abort_Selector (Selector : Selector_Type) is
 212    begin
 213       --  Send an empty array to unblock C select system call
 214
 215       if Selector.In_Progress then
 216          declare
 217             Buf : Character;
 218             Res : C.int;
 219          begin
 220             Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 0);
 221          end;
 222       end if;
 223    end Abort_Selector;
 224
 225    -------------------
 226    -- Accept_Socket --
 227    -------------------
 228
 229    procedure Accept_Socket
 230      (Server  : Socket_Type;
 231       Socket  : out Socket_Type;
 232       Address : out Sock_Addr_Type)
 233    is
 234       Res : C.int;
 235       Sin : aliased Sockaddr_In;
 236       Len : aliased C.int := Sin'Size / 8;
 237
 238    begin
 239       Res := C_Accept (C.int (Server), Sin'Address, Len'Access);
 240       if Res = Failure then
 241          Raise_Socket_Error (Socket_Errno);
 242       end if;
 243
 244       Socket := Socket_Type (Res);
 245
 246       Address.Addr := To_Inet_Addr (Sin.Sin_Addr);
 247       Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
 248    end Accept_Socket;
 249
 250    ---------------
 251    -- Addresses --
 252    ---------------
 253
 254    function Addresses
 255      (E    : Host_Entry_Type;
 256       N    : Positive := 1)
 257       return Inet_Addr_Type
 258    is
 259    begin
 260       return E.Addresses (N);
 261    end Addresses;
 262
 263    ----------------------
 264    -- Addresses_Length --
 265    ----------------------
 266
 267    function Addresses_Length (E : Host_Entry_Type) return Natural is
 268    begin
 269       return E.Addresses_Length;
 270    end Addresses_Length;
 271
 272    -------------
 273    -- Aliases --
 274    -------------
 275
 276    function Aliases
 277      (E    : Host_Entry_Type;
 278       N    : Positive := 1)
 279       return String
 280    is
 281    begin
 282       return To_String (E.Aliases (N));
 283    end Aliases;
 284
 285    --------------------
 286    -- Aliases_Length --
 287    --------------------
 288
 289    function Aliases_Length (E : Host_Entry_Type) return Natural is
 290    begin
 291       return E.Aliases_Length;
 292    end Aliases_Length;
 293
 294    -----------------
 295    -- Bind_Socket --
 296    -----------------
 297
 298    procedure Bind_Socket
 299      (Socket  : Socket_Type;
 300       Address : Sock_Addr_Type)
 301    is
 302       Res : C.int;
 303       Sin : aliased Sockaddr_In;
 304       Len : aliased C.int := Sin'Size / 8;
 305
 306    begin
 307       if Address.Family = Family_Inet6 then
 308          raise Socket_Error;
 309       end if;
 310
 311       Sin.Sin_Family := C.unsigned_short (Families (Address.Family));
 312       Sin.Sin_Port   := Port_To_Network (C.unsigned_short (Address.Port));
 313
 314       Res := C_Bind (C.int (Socket), Sin'Address, Len);
 315
 316       if Res = Failure then
 317          Raise_Socket_Error (Socket_Errno);
 318       end if;
 319    end Bind_Socket;
 320
 321    --------------------
 322    -- Check_Selector --
 323    --------------------
 324
 325    procedure Check_Selector
 326      (Selector     : in out Selector_Type;
 327       R_Socket_Set : in out Socket_Set_Type;
 328       W_Socket_Set : in out Socket_Set_Type;
 329       Status       : out Selector_Status;
 330       Timeout      : Duration := Forever)
 331    is
 332       Res  : C.int;
 333       Len  : C.int;
 334       RSet : aliased Fd_Set;
 335       WSet : aliased Fd_Set;
 336       TVal : aliased Timeval;
 337       TPtr : Timeval_Access;
 338
 339    begin
 340       Status := Completed;
 341
 342       --  No timeout or Forever is indicated by a null timeval pointer.
 343
 344       if Timeout = Forever then
 345          TPtr := null;
 346       else
 347          TVal := To_Timeval (Timeout);
 348          TPtr := TVal'Unchecked_Access;
 349       end if;
 350
 351       --  Copy R_Socket_Set in RSet and add read signalling socket.
 352
 353       if R_Socket_Set = null then
 354          RSet := Null_Fd_Set;
 355       else
 356          RSet := Fd_Set (R_Socket_Set.all);
 357       end if;
 358
 359       Set (RSet, C.int (Selector.R_Sig_Socket));
 360       Len := Max (RSet) + 1;
 361
 362       --  Copy W_Socket_Set in WSet.
 363
 364       if W_Socket_Set = null then
 365          WSet := Null_Fd_Set;
 366       else
 367          WSet := Fd_Set (W_Socket_Set.all);
 368       end if;
 369       Len := C.int'Max (Max (RSet) + 1, Len);
 370
 371       Selector.In_Progress := True;
 372       Res :=
 373         C_Select
 374          (Len,
 375           RSet'Unchecked_Access,
 376           WSet'Unchecked_Access,
 377           null, TPtr);
 378       Selector.In_Progress := False;
 379
 380       --  If Select was resumed because of read signalling socket,
 381       --  read this data and remove socket from set.
 382
 383       if Is_Set (RSet, C.int (Selector.R_Sig_Socket)) then
 384          Clear (RSet, C.int (Selector.R_Sig_Socket));
 385
 386          declare
 387             Buf : Character;
 388          begin
 389             Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 0);
 390          end;
 391
 392          --  Select was resumed because of read signalling socket, but
 393          --  the call is said aborted only when there is no other read
 394          --  or write event.
 395
 396          if Is_Empty (RSet)
 397            and then Is_Empty (WSet)
 398          then
 399             Status := Aborted;
 400          end if;
 401
 402       elsif Res = 0 then
 403          Status := Expired;
 404       end if;
 405
 406       if R_Socket_Set /= null then
 407          R_Socket_Set.all := Socket_Set_Record (RSet);
 408       end if;
 409
 410       if W_Socket_Set /= null then
 411          W_Socket_Set.all := Socket_Set_Record (WSet);
 412       end if;
 413    end Check_Selector;
 414
 415    -----------
 416    -- Clear --
 417    -----------
 418
 419    procedure Clear
 420      (Item   : in out Socket_Set_Type;
 421       Socket : Socket_Type)
 422    is
 423    begin
 424       if Item = null then
 425          Item := new Socket_Set_Record;
 426          Empty (Fd_Set (Item.all));
 427       end if;
 428
 429       Clear (Fd_Set (Item.all), C.int (Socket));
 430    end Clear;
 431
 432    --------------------
 433    -- Close_Selector --
 434    --------------------
 435
 436    procedure Close_Selector (Selector : in out Selector_Type) is
 437    begin
 438       begin
 439          Close_Socket (Selector.R_Sig_Socket);
 440       exception when Socket_Error =>
 441          null;
 442       end;
 443
 444       begin
 445          Close_Socket (Selector.W_Sig_Socket);
 446       exception when Socket_Error =>
 447          null;
 448       end;
 449    end Close_Selector;
 450
 451    ------------------
 452    -- Close_Socket --
 453    ------------------
 454
 455    procedure Close_Socket (Socket : Socket_Type) is
 456       Res : C.int;
 457
 458    begin
 459       Res := C_Close (C.int (Socket));
 460
 461       if Res = Failure then
 462          Raise_Socket_Error (Socket_Errno);
 463       end if;
 464    end Close_Socket;
 465
 466    --------------------
 467    -- Connect_Socket --
 468    --------------------
 469
 470    procedure Connect_Socket
 471      (Socket : Socket_Type;
 472       Server : in out Sock_Addr_Type)
 473    is
 474       Res : C.int;
 475       Sin : aliased Sockaddr_In;
 476       Len : aliased C.int := Sin'Size / 8;
 477
 478    begin
 479       if Server.Family = Family_Inet6 then
 480          raise Socket_Error;
 481       end if;
 482
 483       Sin.Sin_Family := C.unsigned_short (Families (Server.Family));
 484       Sin.Sin_Addr   := To_In_Addr (Server.Addr);
 485       Sin.Sin_Port   := Port_To_Network (C.unsigned_short (Server.Port));
 486
 487       Res := C_Connect (C.int (Socket), Sin'Address, Len);
 488
 489       if Res = Failure then
 490          Raise_Socket_Error (Socket_Errno);
 491       end if;
 492    end Connect_Socket;
 493
 494    --------------------
 495    -- Control_Socket --
 496    --------------------
 497
 498    procedure Control_Socket
 499      (Socket  : Socket_Type;
 500       Request : in out Request_Type)
 501    is
 502       Arg : aliased C.int;
 503       Res : C.int;
 504
 505    begin
 506       case Request.Name is
 507          when Non_Blocking_IO =>
 508             Arg := C.int (Boolean'Pos (Request.Enabled));
 509
 510          when N_Bytes_To_Read =>
 511             null;
 512
 513       end case;
 514
 515       Res := C_Ioctl
 516         (C.int (Socket),
 517          Requests (Request.Name),
 518          Arg'Unchecked_Access);
 519
 520       if Res = Failure then
 521          Raise_Socket_Error (Socket_Errno);
 522       end if;
 523
 524       case Request.Name is
 525          when Non_Blocking_IO =>
 526             null;
 527
 528          when N_Bytes_To_Read =>
 529             Request.Size := Natural (Arg);
 530
 531       end case;
 532    end Control_Socket;
 533
 534    ---------------------
 535    -- Create_Selector --
 536    ---------------------
 537
 538    procedure Create_Selector (Selector : out Selector_Type) is
 539       S0  : C.int;
 540       S1  : C.int;
 541       S2  : C.int;
 542       Res : C.int;
 543       Sin : aliased Sockaddr_In;
 544       Len : aliased C.int := Sin'Size / 8;
 545       Err : Integer;
 546
 547    begin
 548       --  We open two signalling sockets. One socket to send a signal
 549       --  to a another socket that always included in a C_Select
 550       --  socket set. When received, it resumes the task suspended in
 551       --  C_Select.
 552
 553       --  Create a listening socket
 554
 555       S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 556       if S0 = Failure then
 557          Raise_Socket_Error (Socket_Errno);
 558       end if;
 559
 560       --  Sin is already correctly initialized. Bind the socket to any
 561       --  unused port.
 562
 563       Res := C_Bind (S0, Sin'Address, Len);
 564       if Res = Failure then
 565          Err := Socket_Errno;
 566          Res := C_Close (S0);
 567          Raise_Socket_Error (Err);
 568       end if;
 569
 570       --  Get the port used by the socket
 571
 572       Res := C_Getsockname (S0, Sin'Address, Len'Access);
 573       if Res = Failure then
 574          Err := Socket_Errno;
 575          Res := C_Close (S0);
 576          Raise_Socket_Error (Err);
 577       end if;
 578
 579       Res := C_Listen (S0, 2);
 580       if Res = Failure then
 581          Err := Socket_Errno;
 582          Res := C_Close (S0);
 583          Raise_Socket_Error (Err);
 584       end if;
 585
 586       S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 587       if S1 = Failure then
 588          Err := Socket_Errno;
 589          Res := C_Close (S0);
 590          Raise_Socket_Error (Err);
 591       end if;
 592
 593       --  Use INADDR_LOOPBACK
 594
 595       Sin.Sin_Addr.S_B1 := 127;
 596       Sin.Sin_Addr.S_B2 := 0;
 597       Sin.Sin_Addr.S_B3 := 0;
 598       Sin.Sin_Addr.S_B4 := 1;
 599
 600       --  Do a connect and accept the connection
 601
 602       Res := C_Connect (S1, Sin'Address, Len);
 603       if Res = Failure then
 604          Err := Socket_Errno;
 605          Res := C_Close (S0);
 606          Res := C_Close (S1);
 607          Raise_Socket_Error (Err);
 608       end if;
 609
 610       S2 := C_Accept (S0, Sin'Address, Len'Access);
 611       if S2 = Failure then
 612          Err := Socket_Errno;
 613          Res := C_Close (S0);
 614          Res := C_Close (S1);
 615          Raise_Socket_Error (Err);
 616       end if;
 617
 618       Res := C_Close (S0);
 619       if Res = Failure then
 620          Raise_Socket_Error (Socket_Errno);
 621       end if;
 622
 623       Selector.R_Sig_Socket := Socket_Type (S1);
 624       Selector.W_Sig_Socket := Socket_Type (S2);
 625    end Create_Selector;
 626
 627    -------------------
 628    -- Create_Socket --
 629    -------------------
 630
 631    procedure Create_Socket
 632      (Socket : out Socket_Type;
 633       Family : Family_Type := Family_Inet;
 634       Mode   : Mode_Type   := Socket_Stream)
 635    is
 636       Res : C.int;
 637
 638    begin
 639       Res := C_Socket (Families (Family), Modes (Mode), 0);
 640
 641       if Res = Failure then
 642          Raise_Socket_Error (Socket_Errno);
 643       end if;
 644
 645       Socket := Socket_Type (Res);
 646    end Create_Socket;
 647
 648    -----------
 649    -- Empty --
 650    -----------
 651
 652    procedure Empty  (Item : in out Socket_Set_Type) is
 653    begin
 654       if Item /= null then
 655          Free (Item);
 656       end if;
 657    end Empty;
 658
 659    --------------
 660    -- Finalize --
 661    --------------
 662
 663    procedure Finalize is
 664    begin
 665       if not Finalized
 666         and then Initialized
 667       then
 668          Finalized := True;
 669          Thin.Finalize;
 670       end if;
 671    end Finalize;
 672
 673    -----------------
 674    -- Get_Address --
 675    -----------------
 676
 677    function Get_Address (Stream : Stream_Access) return Sock_Addr_Type is
 678    begin
 679       if Stream = null then
 680          raise Socket_Error;
 681
 682       elsif Stream.all in Datagram_Socket_Stream_Type then
 683          return Datagram_Socket_Stream_Type (Stream.all).From;
 684
 685       else
 686          return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket);
 687       end if;
 688    end Get_Address;
 689
 690    -------------------------
 691    -- Get_Host_By_Address --
 692    -------------------------
 693
 694    function Get_Host_By_Address
 695      (Address : Inet_Addr_Type;
 696       Family  : Family_Type := Family_Inet)
 697       return    Host_Entry_Type
 698    is
 699       HA  : aliased In_Addr := To_In_Addr (Address);
 700       Res : Hostent_Access;
 701       Err : Integer;
 702
 703    begin
 704       --  This C function is not always thread-safe. Protect against
 705       --  concurrent access.
 706
 707       Task_Lock.Lock;
 708       Res := C_Gethostbyaddr (HA'Address, HA'Size / 8, Constants.AF_INET);
 709
 710       if Res = null then
 711          Err := Socket_Errno;
 712          Task_Lock.Unlock;
 713          Raise_Host_Error (Err);
 714       end if;
 715
 716       --  Translate from the C format to the API format
 717
 718       declare
 719          HE : Host_Entry_Type := To_Host_Entry (Res.all);
 720
 721       begin
 722          Task_Lock.Unlock;
 723          return HE;
 724       end;
 725    end Get_Host_By_Address;
 726
 727    ----------------------
 728    -- Get_Host_By_Name --
 729    ----------------------
 730
 731    function Get_Host_By_Name
 732      (Name : String)
 733       return Host_Entry_Type
 734    is
 735       HN  : C.char_array := C.To_C (Name);
 736       Res : Hostent_Access;
 737       Err : Integer;
 738
 739    begin
 740       --  This C function is not always thread-safe. Protect against
 741       --  concurrent access.
 742
 743       Task_Lock.Lock;
 744       Res := C_Gethostbyname (HN);
 745
 746       if Res = null then
 747          Err := Socket_Errno;
 748          Task_Lock.Unlock;
 749          Raise_Host_Error (Err);
 750       end if;
 751
 752       --  Translate from the C format to the API format
 753
 754       declare
 755          HE : Host_Entry_Type := To_Host_Entry (Res.all);
 756
 757       begin
 758          Task_Lock.Unlock;
 759          return HE;
 760       end;
 761    end Get_Host_By_Name;
 762
 763    -------------------
 764    -- Get_Peer_Name --
 765    -------------------
 766
 767    function Get_Peer_Name
 768      (Socket : Socket_Type)
 769       return   Sock_Addr_Type
 770    is
 771       Sin : aliased Sockaddr_In;
 772       Len : aliased C.int := Sin'Size / 8;
 773       Res : Sock_Addr_Type (Family_Inet);
 774
 775    begin
 776       if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then
 777          Raise_Socket_Error (Socket_Errno);
 778       end if;
 779
 780       Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
 781       Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
 782
 783       return Res;
 784    end Get_Peer_Name;
 785
 786    ---------------------
 787    -- Get_Socket_Name --
 788    ---------------------
 789
 790    function Get_Socket_Name
 791      (Socket : Socket_Type)
 792       return   Sock_Addr_Type
 793    is
 794       Sin : aliased Sockaddr_In;
 795       Len : aliased C.int := Sin'Size / 8;
 796       Res : Sock_Addr_Type (Family_Inet);
 797
 798    begin
 799       if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then
 800          Raise_Socket_Error (Socket_Errno);
 801       end if;
 802
 803       Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
 804       Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
 805
 806       return Res;
 807    end Get_Socket_Name;
 808
 809    -----------------------
 810    -- Get_Socket_Option --
 811    -----------------------
 812
 813    function Get_Socket_Option
 814      (Socket : Socket_Type;
 815       Level  : Level_Type := Socket_Level;
 816       Name   : Option_Name)
 817       return   Option_Type
 818    is
 819       use type C.unsigned_char;
 820
 821       V8  : aliased Two_Int;
 822       V4  : aliased C.int;
 823       V1  : aliased C.unsigned_char;
 824       Len : aliased C.int;
 825       Add : System.Address;
 826       Res : C.int;
 827       Opt : Option_Type (Name);
 828
 829    begin
 830       case Name is
 831          when Multicast_Loop  |
 832               Multicast_TTL   =>
 833             Len := V1'Size / 8;
 834             Add := V1'Address;
 835
 836          when Keep_Alive      |
 837               Reuse_Address   |
 838               Broadcast       |
 839               No_Delay        |
 840               Send_Buffer     |
 841               Receive_Buffer  |
 842               Error           =>
 843             Len := V4'Size / 8;
 844             Add := V4'Address;
 845
 846          when Linger          |
 847               Add_Membership  |
 848               Drop_Membership =>
 849             Len := V8'Size / 8;
 850             Add := V8'Address;
 851
 852       end case;
 853
 854       Res := C_Getsockopt
 855         (C.int (Socket),
 856          Levels (Level),
 857          Options (Name),
 858          Add, Len'Unchecked_Access);
 859
 860       if Res = Failure then
 861          Raise_Socket_Error (Socket_Errno);
 862       end if;
 863
 864       case Name is
 865          when Keep_Alive      |
 866               Reuse_Address   |
 867               Broadcast       |
 868               No_Delay        =>
 869             Opt.Enabled := (V4 /= 0);
 870
 871          when Linger          =>
 872             Opt.Enabled := (V8 (V8'First) /= 0);
 873             Opt.Seconds := Natural (V8 (V8'Last));
 874
 875          when Send_Buffer     |
 876               Receive_Buffer  =>
 877             Opt.Size := Natural (V4);
 878
 879          when Error           =>
 880             Opt.Error := Resolve_Error (Integer (V4));
 881
 882          when Add_Membership  |
 883               Drop_Membership =>
 884             Opt.Multiaddr := To_Inet_Addr (To_In_Addr (V8 (V8'First)));
 885             Opt.Interface := To_Inet_Addr (To_In_Addr (V8 (V8'Last)));
 886
 887          when Multicast_TTL   =>
 888             Opt.Time_To_Live := Integer (V1);
 889
 890          when Multicast_Loop  =>
 891             Opt.Enabled := (V1 /= 0);
 892
 893       end case;
 894
 895       return Opt;
 896    end Get_Socket_Option;
 897
 898    ---------------
 899    -- Host_Name --
 900    ---------------
 901
 902    function Host_Name return String is
 903       Name : aliased C.char_array (1 .. 64);
 904       Res  : C.int;
 905
 906    begin
 907       Res := C_Gethostname (Name'Address, Name'Length);
 908
 909       if Res = Failure then
 910          Raise_Socket_Error (Socket_Errno);
 911       end if;
 912
 913       return C.To_Ada (Name);
 914    end Host_Name;
 915
 916    -----------
 917    -- Image --
 918    -----------
 919
 920    function Image
 921      (Val  : Inet_Addr_VN_Type;
 922       Hex  : Boolean := False)
 923       return String
 924    is
 925       --  The largest Inet_Addr_Comp_Type image occurs with IPv4. It
 926       --  has at most a length of 3 plus one '.' character.
 927
 928       Buffer    : String (1 .. 4 * Val'Length);
 929       Length    : Natural := 1;
 930       Separator : Character;
 931
 932       procedure Img10 (V : Inet_Addr_Comp_Type);
 933       --  Append to Buffer image of V in decimal format
 934
 935       procedure Img16 (V : Inet_Addr_Comp_Type);
 936       --  Append to Buffer image of V in hexadecimal format
 937
 938       procedure Img10 (V : Inet_Addr_Comp_Type) is
 939          Img : constant String := V'Img;
 940          Len : Natural := Img'Length - 1;
 941
 942       begin
 943          Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
 944          Length := Length + Len;
 945       end Img10;
 946
 947       procedure Img16 (V : Inet_Addr_Comp_Type) is
 948       begin
 949          Buffer (Length)     := Hex_To_Char (Natural (V / 16) + 1);
 950          Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1);
 951          Length := Length + 2;
 952       end Img16;
 953
 954    --  Start of processing for Image
 955
 956    begin
 957       if Hex then
 958          Separator := ':';
 959       else
 960          Separator := '.';
 961       end if;
 962
 963       for J in Val'Range loop
 964          if Hex then
 965             Img16 (Val (J));
 966          else
 967             Img10 (Val (J));
 968          end if;
 969
 970          if J /= Val'Last then
 971             Buffer (Length) := Separator;
 972             Length := Length + 1;
 973          end if;
 974       end loop;
 975
 976       return Buffer (1 .. Length - 1);
 977    end Image;
 978
 979    -----------
 980    -- Image --
 981    -----------
 982
 983    function Image (Value : Inet_Addr_Type) return String is
 984    begin
 985       if Value.Family = Family_Inet then
 986          return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False);
 987       else
 988          return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True);
 989       end if;
 990    end Image;
 991
 992    -----------
 993    -- Image --
 994    -----------
 995
 996    function Image (Value : Sock_Addr_Type) return String is
 997       Port : constant String := Value.Port'Img;
 998
 999    begin
1000       return Image (Value.Addr) & ':' & Port (2 .. Port'Last);
1001    end Image;
1002
1003    -----------
1004    -- Image --
1005    -----------
1006
1007    function Image (Socket : Socket_Type) return String is
1008    begin
1009       return Socket'Img;
1010    end Image;
1011
1012    ---------------
1013    -- Inet_Addr --
1014    ---------------
1015
1016    function Inet_Addr (Image : String) return Inet_Addr_Type is
1017       use Interfaces.C.Strings;
1018
1019       Img : chars_ptr := New_String (Image);
1020       Res : C.int;
1021       Err : Integer;
1022
1023    begin
1024       Res := C_Inet_Addr (Img);
1025       Err := Errno;
1026       Free (Img);
1027
1028       if Res = Failure then
1029          Raise_Socket_Error (Err);
1030       end if;
1031
1032       return To_Inet_Addr (To_In_Addr (Res));
1033    end Inet_Addr;
1034
1035    ----------------
1036    -- Initialize --
1037    ----------------
1038
1039    procedure Initialize (Process_Blocking_IO : Boolean := False) is
1040    begin
1041       if not Initialized then
1042          Initialized := True;
1043          Thin.Initialize (Process_Blocking_IO);
1044       end if;
1045    end Initialize;
1046
1047    --------------
1048    -- Is_Empty --
1049    --------------
1050
1051    function Is_Empty (Item : Socket_Set_Type) return Boolean is
1052    begin
1053       return Item = null or else Is_Empty (Fd_Set (Item.all));
1054    end Is_Empty;
1055
1056    ------------
1057    -- Is_Set --
1058    ------------
1059
1060    function Is_Set
1061      (Item   : Socket_Set_Type;
1062       Socket : Socket_Type) return Boolean
1063    is
1064    begin
1065       return Item /= null
1066         and then Is_Set (Fd_Set (Item.all), C.int (Socket));
1067    end Is_Set;
1068
1069    -------------------
1070    -- Listen_Socket --
1071    -------------------
1072
1073    procedure Listen_Socket
1074      (Socket : Socket_Type;
1075       Length : Positive := 15)
1076    is
1077       Res : C.int;
1078
1079    begin
1080       Res := C_Listen (C.int (Socket), C.int (Length));
1081       if Res = Failure then
1082          Raise_Socket_Error (Socket_Errno);
1083       end if;
1084    end Listen_Socket;
1085
1086    -------------------
1087    -- Official_Name --
1088    -------------------
1089
1090    function Official_Name (E : Host_Entry_Type) return String is
1091    begin
1092       return To_String (E.Official);
1093    end Official_Name;
1094
1095    ---------------------
1096    -- Port_To_Network --
1097    ---------------------
1098
1099    function Port_To_Network
1100      (Port : C.unsigned_short)
1101       return C.unsigned_short
1102    is
1103       use type C.unsigned_short;
1104    begin
1105       if Default_Bit_Order = High_Order_First then
1106
1107          --  No conversion needed. On these platforms, htons() defaults
1108          --  to a null procedure.
1109
1110          return Port;
1111
1112       else
1113          --  We need to swap the high and low byte on this short to make
1114          --  the port number network compliant.
1115
1116          return (Port / 256) + (Port mod 256) * 256;
1117       end if;
1118    end Port_To_Network;
1119
1120    ----------------------
1121    -- Raise_Host_Error --
1122    ----------------------
1123
1124    procedure Raise_Host_Error (Error : Integer) is
1125
1126       function Error_Message return String;
1127       --  We do not use a C function like strerror because hstrerror
1128       --  that would correspond seems to be obsolete. Return
1129       --  appropriate string for error value.
1130
1131       function Error_Message return String is
1132       begin
1133          case Error is
1134             when Constants.HOST_NOT_FOUND => return "Host not found";
1135             when Constants.TRY_AGAIN      => return "Try again";
1136             when Constants.NO_RECOVERY    => return "No recovery";
1137             when Constants.NO_ADDRESS     => return "No address";
1138             when others                   => return "Unknown error";
1139          end case;
1140       end Error_Message;
1141
1142    --  Start of processing for Raise_Host_Error
1143
1144    begin
1145       Ada.Exceptions.Raise_Exception (Host_Error'Identity, Error_Message);
1146    end Raise_Host_Error;
1147
1148    ------------------------
1149    -- Raise_Socket_Error --
1150    ------------------------
1151
1152    procedure Raise_Socket_Error (Error : Integer) is
1153       use type C.Strings.chars_ptr;
1154
1155       function Image (E : Integer) return String;
1156       function Image (E : Integer) return String is
1157          Msg : String := E'Img & "] ";
1158       begin
1159          Msg (Msg'First) := '[';
1160          return Msg;
1161       end Image;
1162
1163    begin
1164       Ada.Exceptions.Raise_Exception
1165         (Socket_Error'Identity, Image (Error) & Socket_Error_Message (Error));
1166    end Raise_Socket_Error;
1167
1168    ----------
1169    -- Read --
1170    ----------
1171
1172    procedure Read
1173      (Stream : in out Datagram_Socket_Stream_Type;
1174       Item   : out Ada.Streams.Stream_Element_Array;
1175       Last   : out Ada.Streams.Stream_Element_Offset)
1176    is
1177       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1178       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1179       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1180
1181    begin
1182       loop
1183          Receive_Socket
1184            (Stream.Socket,
1185             Item (First .. Max),
1186             Index,
1187             Stream.From);
1188
1189          Last  := Index;
1190
1191          --  Exit when all or zero data received. Zero means that
1192          --  the socket peer is closed.
1193
1194          exit when Index < First or else Index = Max;
1195
1196          First := Index + 1;
1197       end loop;
1198    end Read;
1199
1200    ----------
1201    -- Read --
1202    ----------
1203
1204    procedure Read
1205      (Stream : in out Stream_Socket_Stream_Type;
1206       Item   : out Ada.Streams.Stream_Element_Array;
1207       Last   : out Ada.Streams.Stream_Element_Offset)
1208    is
1209       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1210       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1211       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1212
1213    begin
1214       loop
1215          Receive_Socket (Stream.Socket, Item (First .. Max), Index);
1216          Last  := Index;
1217
1218          --  Exit when all or zero data received. Zero means that
1219          --  the socket peer is closed.
1220
1221          exit when Index < First or else Index = Max;
1222
1223          First := Index + 1;
1224       end loop;
1225    end Read;
1226
1227    -------------------
1228    -- Resolve_Error --
1229    -------------------
1230
1231    function Resolve_Error
1232      (Error_Value : Integer;
1233       From_Errno  : Boolean := True)
1234      return         Error_Type
1235    is
1236       use GNAT.Sockets.Constants;
1237
1238    begin
1239       if not From_Errno then
1240          case Error_Value is
1241             when HOST_NOT_FOUND => return Unknown_Host;
1242             when TRY_AGAIN      => return Host_Name_Lookup_Failure;
1243             when NO_RECOVERY    => return No_Address_Associated_With_Name;
1244             when NO_ADDRESS     => return Unknown_Server_Error;
1245             when others         => return Cannot_Resolve_Error;
1246          end case;
1247       end if;
1248       case Error_Value is
1249          when EACCES          => return Permission_Denied;
1250          when EADDRINUSE      => return Address_Already_In_Use;
1251          when EADDRNOTAVAIL   => return Cannot_Assign_Requested_Address;
1252          when EAFNOSUPPORT    =>
1253             return Address_Family_Not_Supported_By_Protocol;
1254          when EALREADY        => return Operation_Already_In_Progress;
1255          when EBADF           => return Bad_File_Descriptor;
1256          when ECONNREFUSED    => return Connection_Refused;
1257          when EFAULT          => return Bad_Address;
1258          when EINPROGRESS     => return Operation_Now_In_Progress;
1259          when EINTR           => return Interrupted_System_Call;
1260          when EINVAL          => return Invalid_Argument;
1261          when EIO             => return Input_Output_Error;
1262          when EISCONN         => return Transport_Endpoint_Already_Connected;
1263          when EMSGSIZE        => return Message_Too_Long;
1264          when ENETUNREACH     => return Network_Is_Unreachable;
1265          when ENOBUFS         => return No_Buffer_Space_Available;
1266          when ENOPROTOOPT     => return Protocol_Not_Available;
1267          when ENOTCONN        => return Transport_Endpoint_Not_Connected;
1268          when EOPNOTSUPP      => return Operation_Not_Supported;
1269          when EPROTONOSUPPORT => return Protocol_Not_Supported;
1270          when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
1271          when ETIMEDOUT       => return Connection_Timed_Out;
1272          when EWOULDBLOCK     => return Resource_Temporarily_Unavailable;
1273          when others          => return Cannot_Resolve_Error;
1274       end case;
1275    end Resolve_Error;
1276
1277    -----------------------
1278    -- Resolve_Exception --
1279    -----------------------
1280
1281    function Resolve_Exception
1282      (Occurrence : Exception_Occurrence)
1283      return        Error_Type
1284    is
1285       Id    : Exception_Id := Exception_Identity (Occurrence);
1286       Msg   : constant String := Exception_Message (Occurrence);
1287       First : Natural := Msg'First;
1288       Last  : Natural;
1289       Val   : Integer;
1290
1291    begin
1292       while First <= Msg'Last
1293         and then Msg (First) not in '0' .. '9'
1294       loop
1295          First := First + 1;
1296       end loop;
1297
1298       if First > Msg'Last then
1299          return Cannot_Resolve_Error;
1300       end if;
1301
1302       Last := First;
1303
1304       while Last < Msg'Last
1305         and then Msg (Last + 1) in '0' .. '9'
1306       loop
1307          Last := Last + 1;
1308       end loop;
1309
1310       Val := Integer'Value (Msg (First .. Last));
1311
1312       if Id = Socket_Error_Id then
1313          return Resolve_Error (Val);
1314
1315       elsif Id = Host_Error_Id then
1316          return Resolve_Error (Val, False);
1317
1318       else
1319          return Cannot_Resolve_Error;
1320       end if;
1321    end Resolve_Exception;
1322
1323    --------------------
1324    -- Receive_Socket --
1325    --------------------
1326
1327    procedure Receive_Socket
1328      (Socket : Socket_Type;
1329       Item   : out Ada.Streams.Stream_Element_Array;
1330       Last   : out Ada.Streams.Stream_Element_Offset)
1331    is
1332       use type Ada.Streams.Stream_Element_Offset;
1333
1334       Res : C.int;
1335
1336    begin
1337       Res := C_Recv
1338         (C.int (Socket),
1339          Item (Item'First)'Address,
1340          Item'Length, 0);
1341
1342       if Res = Failure then
1343          Raise_Socket_Error (Socket_Errno);
1344       end if;
1345
1346       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1347    end Receive_Socket;
1348
1349    --------------------
1350    -- Receive_Socket --
1351    --------------------
1352
1353    procedure Receive_Socket
1354      (Socket : Socket_Type;
1355       Item   : out Ada.Streams.Stream_Element_Array;
1356       Last   : out Ada.Streams.Stream_Element_Offset;
1357       From   : out Sock_Addr_Type)
1358    is
1359       use type Ada.Streams.Stream_Element_Offset;
1360
1361       Res  : C.int;
1362       Sin  : aliased Sockaddr_In;
1363       Len  : aliased C.int := Sin'Size / 8;
1364
1365    begin
1366       Res := C_Recvfrom
1367         (C.int (Socket),
1368          Item (Item'First)'Address,
1369          Item'Length, 0,
1370          Sin'Unchecked_Access,
1371          Len'Unchecked_Access);
1372
1373       if Res = Failure then
1374          Raise_Socket_Error (Socket_Errno);
1375       end if;
1376
1377       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1378
1379       From.Addr := To_Inet_Addr (Sin.Sin_Addr);
1380       From.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
1381    end Receive_Socket;
1382
1383    -----------------
1384    -- Send_Socket --
1385    -----------------
1386
1387    procedure Send_Socket
1388      (Socket : Socket_Type;
1389       Item   : Ada.Streams.Stream_Element_Array;
1390       Last   : out Ada.Streams.Stream_Element_Offset)
1391    is
1392       use type Ada.Streams.Stream_Element_Offset;
1393
1394       Res  : C.int;
1395
1396    begin
1397       Res := C_Send
1398         (C.int (Socket),
1399          Item (Item'First)'Address,
1400          Item'Length, 0);
1401
1402       if Res = Failure then
1403          Raise_Socket_Error (Socket_Errno);
1404       end if;
1405
1406       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1407    end Send_Socket;
1408
1409    -----------------
1410    -- Send_Socket --
1411    -----------------
1412
1413    procedure Send_Socket
1414      (Socket : Socket_Type;
1415       Item   : Ada.Streams.Stream_Element_Array;
1416       Last   : out Ada.Streams.Stream_Element_Offset;
1417       To     : Sock_Addr_Type)
1418    is
1419       use type Ada.Streams.Stream_Element_Offset;
1420
1421       Res : C.int;
1422       Sin : aliased Sockaddr_In;
1423       Len : aliased C.int := Sin'Size / 8;
1424
1425    begin
1426       Sin.Sin_Family := C.unsigned_short (Families (To.Family));
1427       Sin.Sin_Addr   := To_In_Addr (To.Addr);
1428       Sin.Sin_Port   := Port_To_Network (C.unsigned_short (To.Port));
1429
1430       Res := C_Sendto
1431         (C.int (Socket),
1432          Item (Item'First)'Address,
1433          Item'Length, 0,
1434          Sin'Unchecked_Access,
1435          Len);
1436
1437       if Res = Failure then
1438          Raise_Socket_Error (Socket_Errno);
1439       end if;
1440
1441       Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
1442    end Send_Socket;
1443
1444    ---------
1445    -- Set --
1446    ---------
1447
1448    procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
1449    begin
1450       if Item = null then
1451          Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set));
1452       end if;
1453
1454       Set (Fd_Set (Item.all), C.int (Socket));
1455    end Set;
1456
1457    -----------------------
1458    -- Set_Socket_Option --
1459    -----------------------
1460
1461    procedure Set_Socket_Option
1462      (Socket : Socket_Type;
1463       Level  : Level_Type := Socket_Level;
1464       Option : Option_Type)
1465    is
1466       V8  : aliased Two_Int;
1467       V4  : aliased C.int;
1468       V1  : aliased C.unsigned_char;
1469       Len : aliased C.int;
1470       Add : System.Address := Null_Address;
1471       Res : C.int;
1472
1473    begin
1474       case Option.Name is
1475          when Keep_Alive      |
1476               Reuse_Address   |
1477               Broadcast       |
1478               No_Delay        =>
1479             V4  := C.int (Boolean'Pos (Option.Enabled));
1480             Len := V4'Size / 8;
1481             Add := V4'Address;
1482
1483          when Linger          =>
1484             V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
1485             V8 (V8'Last)  := C.int (Option.Seconds);
1486             Len := V8'Size / 8;
1487             Add := V8'Address;
1488
1489          when Send_Buffer     |
1490               Receive_Buffer  =>
1491             V4  := C.int (Option.Size);
1492             Len := V4'Size / 8;
1493             Add := V4'Address;
1494
1495          when Error           =>
1496             V4  := C.int (Boolean'Pos (True));
1497             Len := V4'Size / 8;
1498             Add := V4'Address;
1499
1500          when Add_Membership  |
1501               Drop_Membership =>
1502             V8 (V8'First) := To_Int (To_In_Addr (Option.Multiaddr));
1503             V8 (V8'Last)  := To_Int (To_In_Addr (Option.Interface));
1504             Len := V8'Size / 8;
1505             Add := V8'Address;
1506
1507          when Multicast_TTL   =>
1508             V1  := C.unsigned_char (Option.Time_To_Live);
1509             Len := V1'Size / 8;
1510             Add := V1'Address;
1511
1512          when Multicast_Loop  =>
1513             V1  := C.unsigned_char (Boolean'Pos (Option.Enabled));
1514             Len := V1'Size / 8;
1515             Add := V1'Address;
1516
1517       end case;
1518
1519       Res := C_Setsockopt
1520         (C.int (Socket),
1521          Levels (Level),
1522          Options (Option.Name),
1523          Add, Len);
1524
1525       if Res = Failure then
1526          Raise_Socket_Error (Socket_Errno);
1527       end if;
1528    end Set_Socket_Option;
1529
1530    ---------------------
1531    -- Shutdown_Socket --
1532    ---------------------
1533
1534    procedure Shutdown_Socket
1535      (Socket : Socket_Type;
1536       How    : Shutmode_Type := Shut_Read_Write)
1537    is
1538       Res : C.int;
1539
1540    begin
1541       Res := C_Shutdown (C.int (Socket), Shutmodes (How));
1542       if Res = Failure then
1543          Raise_Socket_Error (Socket_Errno);
1544       end if;
1545    end Shutdown_Socket;
1546
1547    ------------
1548    -- Stream --
1549    ------------
1550
1551    function Stream
1552      (Socket  : Socket_Type;
1553       Send_To : Sock_Addr_Type)
1554      return Stream_Access
1555    is
1556       S : Datagram_Socket_Stream_Access;
1557
1558    begin
1559       S := new Datagram_Socket_Stream_Type;
1560       S.Socket := Socket;
1561       S.To     := Send_To;
1562       S.From   := Get_Socket_Name (Socket);
1563       return Stream_Access (S);
1564    end Stream;
1565
1566    ------------
1567    -- Stream --
1568    ------------
1569
1570    function Stream
1571      (Socket : Socket_Type)
1572      return Stream_Access
1573    is
1574       S : Stream_Socket_Stream_Access;
1575
1576    begin
1577       S := new Stream_Socket_Stream_Type;
1578       S.Socket := Socket;
1579       return Stream_Access (S);
1580    end Stream;
1581
1582    ----------
1583    -- To_C --
1584    ----------
1585
1586    function To_C (Socket : Socket_Type) return Integer is
1587    begin
1588       return Integer (Socket);
1589    end To_C;
1590
1591    -------------------
1592    -- To_Host_Entry --
1593    -------------------
1594
1595    function To_Host_Entry
1596      (Host : Hostent)
1597       return Host_Entry_Type
1598    is
1599       use type C.size_t;
1600
1601       Official : constant String :=
1602                    C.Strings.Value (Host.H_Name);
1603
1604       Aliases : constant Chars_Ptr_Array :=
1605                   Chars_Ptr_Pointers.Value (Host.H_Aliases);
1606       --  H_Aliases points to a list of name aliases. The list is
1607       --  terminated by a NULL pointer.
1608
1609       Addresses : constant In_Addr_Access_Array :=
1610                     In_Addr_Access_Pointers.Value (Host.H_Addr_List);
1611       --  H_Addr_List points to a list of binary addresses (in network
1612       --  byte order). The list is terminated by a NULL pointer.
1613
1614       --  H_Length is not used because it is currently only set to 4.
1615       --  H_Addrtype is always AF_INET
1616
1617       Result    : Host_Entry_Type
1618         (Aliases_Length   => Aliases'Length - 1,
1619          Addresses_Length => Addresses'Length - 1);
1620       --  The last element is a null pointer.
1621
1622       Source : C.size_t;
1623       Target : Natural;
1624
1625    begin
1626       Result.Official := To_Host_Name (Official);
1627
1628       Source := Aliases'First;
1629       Target := Result.Aliases'First;
1630       while Target <= Result.Aliases_Length loop
1631          Result.Aliases (Target) :=
1632            To_Host_Name (C.Strings.Value (Aliases (Source)));
1633          Source := Source + 1;
1634          Target := Target + 1;
1635       end loop;
1636
1637       Source := Addresses'First;
1638       Target := Result.Addresses'First;
1639       while Target <= Result.Addresses_Length loop
1640          Result.Addresses (Target) :=
1641            To_Inet_Addr (Addresses (Source).all);
1642          Source := Source + 1;
1643          Target := Target + 1;
1644       end loop;
1645
1646       return Result;
1647    end To_Host_Entry;
1648
1649    ------------------
1650    -- To_Host_Name --
1651    ------------------
1652
1653    function To_Host_Name (N : String) return Host_Name_Type is
1654    begin
1655       return (N'Length, N);
1656    end To_Host_Name;
1657
1658    ----------------
1659    -- To_In_Addr --
1660    ----------------
1661
1662    function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr is
1663    begin
1664       if Addr.Family = Family_Inet then
1665          return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)),
1666                  S_B2 => C.unsigned_char (Addr.Sin_V4 (2)),
1667                  S_B3 => C.unsigned_char (Addr.Sin_V4 (3)),
1668                  S_B4 => C.unsigned_char (Addr.Sin_V4 (4)));
1669       end if;
1670
1671       raise Socket_Error;
1672    end To_In_Addr;
1673
1674    ------------------
1675    -- To_Inet_Addr --
1676    ------------------
1677
1678    function To_Inet_Addr
1679      (Addr : In_Addr)
1680       return Inet_Addr_Type
1681    is
1682       Result : Inet_Addr_Type;
1683
1684    begin
1685       Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1);
1686       Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2);
1687       Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3);
1688       Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4);
1689
1690       return Result;
1691    end To_Inet_Addr;
1692
1693    ---------------
1694    -- To_String --
1695    ---------------
1696
1697    function To_String (HN : Host_Name_Type) return String is
1698    begin
1699       return HN.Name (1 .. HN.Length);
1700    end To_String;
1701
1702    ----------------
1703    -- To_Timeval --
1704    ----------------
1705
1706    function To_Timeval (Val : Duration) return Timeval is
1707       S  : Timeval_Unit := Timeval_Unit (Val);
1708       MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S)));
1709
1710    begin
1711       return (S, MS);
1712    end To_Timeval;
1713
1714    -----------
1715    -- Write --
1716    -----------
1717
1718    procedure Write
1719      (Stream : in out Datagram_Socket_Stream_Type;
1720       Item   : Ada.Streams.Stream_Element_Array)
1721    is
1722       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1723       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1724       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1725
1726    begin
1727       loop
1728          Send_Socket
1729            (Stream.Socket,
1730             Item (First .. Max),
1731             Index,
1732             Stream.To);
1733
1734          --  Exit when all or zero data sent. Zero means that the
1735          --  socket has been closed by peer.
1736
1737          exit when Index < First or else Index = Max;
1738
1739          First := Index + 1;
1740       end loop;
1741
1742       if Index /= Max then
1743          raise Socket_Error;
1744       end if;
1745    end Write;
1746
1747    -----------
1748    -- Write --
1749    -----------
1750
1751    procedure Write
1752      (Stream : in out Stream_Socket_Stream_Type;
1753       Item   : Ada.Streams.Stream_Element_Array)
1754    is
1755       First : Ada.Streams.Stream_Element_Offset          := Item'First;
1756       Index : Ada.Streams.Stream_Element_Offset          := First - 1;
1757       Max   : constant Ada.Streams.Stream_Element_Offset := Item'Last;
1758
1759    begin
1760       loop
1761          Send_Socket (Stream.Socket, Item (First .. Max), Index);
1762
1763          --  Exit when all or zero data sent. Zero means that the
1764          --  socket has been closed by peer.
1765
1766          exit when Index < First or else Index = Max;
1767
1768          First := Index + 1;
1769       end loop;
1770
1771       if Index /= Max then
1772          raise Socket_Error;
1773       end if;
1774    end Write;
1775
1776 end GNAT.Sockets;