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