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