gcc/ada/3zsocthi.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                    G N A T . S O C K E T S . T H I N                     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2002-2003 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 was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This package provides a target dependent thin interface to the sockets
  35 --  layer for use by the GNAT.Sockets package (g-socket.ads). This package
  36 --  should not be directly with'ed by an applications program.
  37
  38 --  This version is for VxWorks
  39
  40 with GNAT.OS_Lib;  use GNAT.OS_Lib;
  41 with GNAT.Task_Lock;
  42
  43 with Interfaces.C; use Interfaces.C;
  44 with Unchecked_Conversion;
  45
  46 package body GNAT.Sockets.Thin is
  47
  48    Non_Blocking_Sockets : Fd_Set_Access := New_Socket_Set (No_Socket_Set);
  49    --  When this package is initialized with Process_Blocking_IO set
  50    --  to True, sockets are set in non-blocking mode to avoid blocking
  51    --  the whole process when a thread wants to perform a blocking IO
  52    --  operation. But the user can also set a socket in non-blocking
  53    --  mode by purpose. In order to make a difference between these
  54    --  two situations, we track the origin of non-blocking mode in
  55    --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
  56    --  been set in non-blocking mode by the user.
  57
  58    Quantum : constant Duration := 0.2;
  59    --  When Thread_Blocking_IO is False, we set sockets in
  60    --  non-blocking mode and we spend a period of time Quantum between
  61    --  two attempts on a blocking operation.
  62    Thread_Blocking_IO : Boolean := True;
  63
  64    --  The following types and variables are required to create a Hostent
  65    --  record "by hand".
  66
  67    type In_Addr_Access_Array_Access is access In_Addr_Access_Array;
  68
  69    Alias_Access : Chars_Ptr_Pointers.Pointer :=
  70                     new C.Strings.chars_ptr'(C.Strings.Null_Ptr);
  71
  72    In_Addr_Access_Array_A : In_Addr_Access_Array_Access :=
  73                               new In_Addr_Access_Array'(new In_Addr, null);
  74
  75    In_Addr_Access_Ptr : In_Addr_Access_Pointers.Pointer :=
  76                           In_Addr_Access_Array_A
  77                             (In_Addr_Access_Array_A'First)'Access;
  78
  79    Local_Hostent : Hostent_Access := new Hostent;
  80
  81    -----------------------
  82    -- Local Subprograms --
  83    -----------------------
  84
  85    --  All these require comments ???
  86
  87    function Syscall_Accept
  88      (S       : C.int;
  89       Addr    : System.Address;
  90       Addrlen : access C.int)
  91       return    C.int;
  92    pragma Import (C, Syscall_Accept, "accept");
  93
  94    function Syscall_Connect
  95      (S       : C.int;
  96       Name    : System.Address;
  97       Namelen : C.int)
  98       return    C.int;
  99    pragma Import (C, Syscall_Connect, "connect");
 100
 101    function Syscall_Ioctl
 102      (S    : C.int;
 103       Req  : C.int;
 104       Arg  : Int_Access)
 105       return C.int;
 106    pragma Import (C, Syscall_Ioctl, "ioctl");
 107
 108    function Syscall_Recv
 109      (S     : C.int;
 110       Msg   : System.Address;
 111       Len   : C.int;
 112       Flags : C.int)
 113       return  C.int;
 114    pragma Import (C, Syscall_Recv, "recv");
 115
 116    function Syscall_Recvfrom
 117      (S       : C.int;
 118       Msg     : System.Address;
 119       Len     : C.int;
 120       Flags   : C.int;
 121       From    : Sockaddr_In_Access;
 122       Fromlen : access C.int)
 123       return    C.int;
 124    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 125
 126    function Syscall_Send
 127      (S     : C.int;
 128       Msg   : System.Address;
 129       Len   : C.int;
 130       Flags : C.int)
 131       return  C.int;
 132    pragma Import (C, Syscall_Send, "send");
 133
 134    function Syscall_Sendto
 135      (S     : C.int;
 136       Msg   : System.Address;
 137       Len   : C.int;
 138       Flags : C.int;
 139       To    : Sockaddr_In_Access;
 140       Tolen : C.int)
 141       return  C.int;
 142    pragma Import (C, Syscall_Sendto, "sendto");
 143
 144    function Syscall_Socket
 145      (Domain   : C.int;
 146       Typ      : C.int;
 147       Protocol : C.int)
 148       return     C.int;
 149    pragma Import (C, Syscall_Socket, "socket");
 150
 151    function  Non_Blocking_Socket (S : C.int) return Boolean;
 152    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 153
 154    --------------
 155    -- C_Accept --
 156    --------------
 157
 158    function C_Accept
 159      (S       : C.int;
 160       Addr    : System.Address;
 161       Addrlen : access C.int)
 162       return    C.int
 163    is
 164       R   : C.int;
 165       Val : aliased C.int := 1;
 166       Res : C.int;
 167
 168    begin
 169       loop
 170          R := Syscall_Accept (S, Addr, Addrlen);
 171          exit when Thread_Blocking_IO
 172            or else R /= Failure
 173            or else Non_Blocking_Socket (S)
 174            or else Errno /= Constants.EWOULDBLOCK;
 175          delay Quantum;
 176       end loop;
 177
 178       if not Thread_Blocking_IO
 179         and then R /= Failure
 180       then
 181          --  A socket inherits the properties ot its server especially
 182          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 183          --  tracks sockets set in non-blocking mode by user.
 184
 185          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 186          Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 187       end if;
 188
 189       return R;
 190    end C_Accept;
 191
 192    ---------------
 193    -- C_Connect --
 194    ---------------
 195
 196    function C_Connect
 197      (S       : C.int;
 198       Name    : System.Address;
 199       Namelen : C.int)
 200       return    C.int
 201    is
 202       Res : C.int;
 203
 204    begin
 205       Res := Syscall_Connect (S, Name, Namelen);
 206
 207       if Thread_Blocking_IO
 208         or else Res /= Failure
 209         or else Non_Blocking_Socket (S)
 210         or else Errno /= Constants.EINPROGRESS
 211       then
 212          return Res;
 213       end if;
 214
 215       declare
 216          WSet : Fd_Set_Access;
 217          Now  : aliased Timeval;
 218
 219       begin
 220          WSet := New_Socket_Set (No_Socket_Set);
 221
 222          loop
 223             Insert_Socket_In_Set (WSet, S);
 224             Now := Immediat;
 225             Res := C_Select
 226               (S + 1,
 227                No_Fd_Set,
 228                WSet,
 229                No_Fd_Set,
 230                Now'Unchecked_Access);
 231
 232             exit when Res > 0;
 233
 234             if Res = Failure then
 235                Free_Socket_Set (WSet);
 236                return Res;
 237             end if;
 238
 239             delay Quantum;
 240          end loop;
 241
 242          Free_Socket_Set (WSet);
 243       end;
 244
 245       Res := Syscall_Connect (S, Name, Namelen);
 246
 247       if Res = Failure
 248         and then Errno = Constants.EISCONN
 249       then
 250          return Thin.Success;
 251       else
 252          return Res;
 253       end if;
 254    end C_Connect;
 255
 256    ---------------------
 257    -- C_Gethostbyaddr --
 258    ---------------------
 259
 260    function C_Gethostbyaddr
 261      (Addr : System.Address;
 262       Len  : C.int;
 263       Typ  : C.int)
 264       return Hostent_Access
 265    is
 266       pragma Warnings (Off, Len);
 267       pragma Warnings (Off, Typ);
 268
 269       type int_Access is access int;
 270       function To_Pointer is
 271         new Unchecked_Conversion (System.Address, int_Access);
 272
 273       procedure VxWorks_Gethostbyaddr
 274         (Addr : C.int; Buf : out C.char_array);
 275       pragma Import (C, VxWorks_Gethostbyaddr, "hostGetByAddr");
 276
 277       Host_Name : C.char_array (1 .. Max_Name_Length);
 278
 279    begin
 280       VxWorks_Gethostbyaddr (To_Pointer (Addr).all, Host_Name);
 281
 282       In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all);
 283       Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name);
 284
 285       return Local_Hostent;
 286    end C_Gethostbyaddr;
 287
 288    ---------------------
 289    -- C_Gethostbyname --
 290    ---------------------
 291
 292    function C_Gethostbyname
 293      (Name : C.char_array)
 294       return Hostent_Access
 295    is
 296       function VxWorks_Gethostbyname
 297         (Name : C.char_array)
 298         return C.int;
 299       pragma Import (C, VxWorks_Gethostbyname, "hostGetByName");
 300
 301       Addr : C.int;
 302
 303    begin
 304       Addr := VxWorks_Gethostbyname (Name);
 305
 306       In_Addr_Access_Ptr.all.all := To_In_Addr (Addr);
 307       Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name));
 308
 309       return Local_Hostent;
 310    end C_Gethostbyname;
 311
 312    ---------------------
 313    -- C_Getservbyname --
 314    ---------------------
 315
 316    function C_Getservbyname
 317      (Name  : C.char_array;
 318       Proto : C.char_array)
 319       return  Servent_Access
 320    is
 321       pragma Warnings (Off, Name);
 322       pragma Warnings (Off, Proto);
 323
 324    begin
 325       return null;
 326    end C_Getservbyname;
 327
 328    ---------------------
 329    -- C_Getservbyport --
 330    ---------------------
 331
 332    function C_Getservbyport
 333      (Port  : C.int;
 334       Proto : C.char_array)
 335       return  Servent_Access
 336    is
 337       pragma Warnings (Off, Port);
 338       pragma Warnings (Off, Proto);
 339
 340    begin
 341       return null;
 342    end C_Getservbyport;
 343
 344    -------------
 345    -- C_Ioctl --
 346    -------------
 347
 348    function C_Ioctl
 349      (S    : C.int;
 350       Req  : C.int;
 351       Arg  : Int_Access)
 352       return C.int
 353    is
 354    begin
 355       if not Thread_Blocking_IO
 356         and then Req = Constants.FIONBIO
 357       then
 358          if Arg.all /= 0 then
 359             Set_Non_Blocking_Socket (S, True);
 360          end if;
 361       end if;
 362
 363       return Syscall_Ioctl (S, Req, Arg);
 364    end C_Ioctl;
 365
 366    ------------
 367    -- C_Recv --
 368    ------------
 369
 370    function C_Recv
 371      (S     : C.int;
 372       Msg   : System.Address;
 373       Len   : C.int;
 374       Flags : C.int)
 375       return  C.int
 376    is
 377       Res : C.int;
 378
 379    begin
 380       loop
 381          Res := Syscall_Recv (S, Msg, Len, Flags);
 382          exit when Thread_Blocking_IO
 383            or else Res /= Failure
 384            or else Non_Blocking_Socket (S)
 385            or else Errno /= Constants.EWOULDBLOCK;
 386          delay Quantum;
 387       end loop;
 388
 389       return Res;
 390    end C_Recv;
 391
 392    ----------------
 393    -- C_Recvfrom --
 394    ----------------
 395
 396    function C_Recvfrom
 397      (S       : C.int;
 398       Msg     : System.Address;
 399       Len     : C.int;
 400       Flags   : C.int;
 401       From    : Sockaddr_In_Access;
 402       Fromlen : access C.int)
 403       return    C.int
 404    is
 405       Res : C.int;
 406
 407    begin
 408       loop
 409          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 410          exit when Thread_Blocking_IO
 411            or else Res /= Failure
 412            or else Non_Blocking_Socket (S)
 413            or else Errno /= Constants.EWOULDBLOCK;
 414          delay Quantum;
 415       end loop;
 416
 417       return Res;
 418    end C_Recvfrom;
 419
 420    ------------
 421    -- C_Send --
 422    ------------
 423
 424    function C_Send
 425      (S     : C.int;
 426       Msg   : System.Address;
 427       Len   : C.int;
 428       Flags : C.int)
 429       return  C.int
 430    is
 431       Res : C.int;
 432
 433    begin
 434       loop
 435          Res := Syscall_Send (S, Msg, Len, Flags);
 436          exit when Thread_Blocking_IO
 437            or else Res /= Failure
 438            or else Non_Blocking_Socket (S)
 439            or else Errno /= Constants.EWOULDBLOCK;
 440          delay Quantum;
 441       end loop;
 442
 443       return Res;
 444    end C_Send;
 445
 446    --------------
 447    -- C_Sendto --
 448    --------------
 449
 450    function C_Sendto
 451      (S     : C.int;
 452       Msg   : System.Address;
 453       Len   : C.int;
 454       Flags : C.int;
 455       To    : Sockaddr_In_Access;
 456       Tolen : C.int)
 457       return  C.int
 458    is
 459       Res : C.int;
 460
 461    begin
 462       loop
 463          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 464          exit when Thread_Blocking_IO
 465            or else Res /= Failure
 466            or else Non_Blocking_Socket (S)
 467            or else Errno /= Constants.EWOULDBLOCK;
 468          delay Quantum;
 469       end loop;
 470
 471       return Res;
 472    end C_Sendto;
 473
 474    --------------
 475    -- C_Socket --
 476    --------------
 477
 478    function C_Socket
 479      (Domain   : C.int;
 480       Typ      : C.int;
 481       Protocol : C.int)
 482       return     C.int
 483    is
 484       R   : C.int;
 485       Val : aliased C.int := 1;
 486       Res : C.int;
 487
 488    begin
 489       R := Syscall_Socket (Domain, Typ, Protocol);
 490
 491       if not Thread_Blocking_IO
 492         and then R /= Failure
 493       then
 494          --  Do not use C_Ioctl as this subprogram tracks sockets set
 495          --  in non-blocking mode by user.
 496
 497          Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 498          Set_Non_Blocking_Socket (R, False);
 499       end if;
 500
 501       return R;
 502    end C_Socket;
 503
 504    --------------
 505    -- Finalize --
 506    --------------
 507
 508    procedure Finalize is
 509    begin
 510       null;
 511    end Finalize;
 512
 513    ----------------
 514    -- Initialize --
 515    ----------------
 516
 517    procedure Initialize (Process_Blocking_IO : Boolean) is
 518    begin
 519       Thread_Blocking_IO := not Process_Blocking_IO;
 520    end Initialize;
 521
 522    -------------------------
 523    -- Non_Blocking_Socket --
 524    -------------------------
 525
 526    function Non_Blocking_Socket (S : C.int) return Boolean is
 527       R : Boolean;
 528
 529    begin
 530       Task_Lock.Lock;
 531       R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
 532       Task_Lock.Unlock;
 533       return R;
 534    end Non_Blocking_Socket;
 535
 536    -----------------
 537    -- Set_Address --
 538    -----------------
 539
 540    procedure Set_Address
 541      (Sin     : Sockaddr_In_Access;
 542       Address : In_Addr)
 543    is
 544    begin
 545       Sin.Sin_Addr   := Address;
 546    end Set_Address;
 547
 548    ----------------
 549    -- Set_Family --
 550    ----------------
 551
 552    procedure Set_Family
 553      (Sin    : Sockaddr_In_Access;
 554       Family : C.int)
 555    is
 556    begin
 557       Sin.Sin_Family := C.unsigned_char (Family);
 558    end Set_Family;
 559
 560    ----------------
 561    -- Set_Length --
 562    ----------------
 563
 564    procedure Set_Length
 565      (Sin : Sockaddr_In_Access;
 566       Len : C.int)
 567    is
 568    begin
 569       Sin.Sin_Length := C.unsigned_char (Len);
 570    end Set_Length;
 571
 572    -----------------------------
 573    -- Set_Non_Blocking_Socket --
 574    -----------------------------
 575
 576    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 577    begin
 578       Task_Lock.Lock;
 579       if V then
 580          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 581       else
 582          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 583       end if;
 584
 585       Task_Lock.Unlock;
 586    end Set_Non_Blocking_Socket;
 587
 588    --------------
 589    -- Set_Port --
 590    --------------
 591
 592    procedure Set_Port
 593      (Sin  : Sockaddr_In_Access;
 594       Port : C.unsigned_short)
 595    is
 596    begin
 597       Sin.Sin_Port   := Port;
 598    end Set_Port;
 599
 600    --------------------------
 601    -- Socket_Error_Message --
 602    --------------------------
 603
 604    function Socket_Error_Message (Errno : Integer) return String is
 605       use type Interfaces.C.Strings.chars_ptr;
 606
 607       C_Msg : C.Strings.chars_ptr;
 608
 609    begin
 610       C_Msg := C_Strerror (C.int (Errno));
 611
 612       if C_Msg = C.Strings.Null_Ptr then
 613          return "Unknown system error";
 614
 615       else
 616          return C.Strings.Value (C_Msg);
 617       end if;
 618    end Socket_Error_Message;
 619
 620 --  Package elaboration
 621
 622 begin
 623    Local_Hostent.all.H_Aliases   := Alias_Access;
 624
 625    --  VxWorks currently only supports AF_INET
 626
 627    Local_Hostent.all.H_Addrtype  := Constants.AF_INET;
 628
 629    Local_Hostent.all.H_Length    := 1;
 630    Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr;
 631
 632 end GNAT.Sockets.Thin;