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