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-2006, AdaCore                     --
  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       function VxWorks_hostGetByAddr
 271         (Addr : C.int; Buf : System.Address) return C.int;
 272       pragma Import (C, VxWorks_hostGetByAddr, "hostGetByAddr");
 273
 274       Host_Name : aliased C.char_array (1 .. Max_Name_Length);
 275
 276    begin
 277       if VxWorks_hostGetByAddr (To_Pointer (Addr).all,
 278                                 Host_Name (Host_Name'First)'Address)
 279            /= Constants.OK
 280       then
 281          return null;
 282       end if;
 283
 284       In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all);
 285       Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name);
 286
 287       return Local_Hostent;
 288    end C_Gethostbyaddr;
 289
 290    ---------------------
 291    -- C_Gethostbyname --
 292    ---------------------
 293
 294    function C_Gethostbyname
 295      (Name : C.char_array) return Hostent_Access
 296    is
 297       function VxWorks_hostGetByName
 298         (Name : C.char_array) return C.int;
 299       pragma Import (C, VxWorks_hostGetByName, "hostGetByName");
 300
 301       Addr : C.int;
 302
 303    begin
 304       Addr := VxWorks_hostGetByName (Name);
 305       if Addr = Constants.ERROR then
 306          return null;
 307       end if;
 308
 309       In_Addr_Access_Ptr.all.all := To_In_Addr (Addr);
 310       Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name));
 311
 312       return Local_Hostent;
 313    end C_Gethostbyname;
 314
 315    ---------------------
 316    -- C_Getservbyname --
 317    ---------------------
 318
 319    function C_Getservbyname
 320      (Name  : C.char_array;
 321       Proto : C.char_array) return Servent_Access
 322    is
 323       pragma Warnings (Off, Name);
 324       pragma Warnings (Off, Proto);
 325
 326    begin
 327       return null;
 328    end C_Getservbyname;
 329
 330    ---------------------
 331    -- C_Getservbyport --
 332    ---------------------
 333
 334    function C_Getservbyport
 335      (Port  : C.int;
 336       Proto : C.char_array) return Servent_Access
 337    is
 338       pragma Warnings (Off, Port);
 339       pragma Warnings (Off, Proto);
 340
 341    begin
 342       return null;
 343    end C_Getservbyport;
 344
 345    -------------
 346    -- C_Ioctl --
 347    -------------
 348
 349    function C_Ioctl
 350      (S    : C.int;
 351       Req  : C.int;
 352       Arg  : Int_Access) 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) return C.int
 375    is
 376       Res : C.int;
 377
 378    begin
 379       loop
 380          Res := Syscall_Recv (S, Msg, Len, Flags);
 381          exit when Thread_Blocking_IO
 382            or else Res /= Failure
 383            or else Non_Blocking_Socket (S)
 384            or else Errno /= Constants.EWOULDBLOCK;
 385          delay Quantum;
 386       end loop;
 387
 388       return Res;
 389    end C_Recv;
 390
 391    ----------------
 392    -- C_Recvfrom --
 393    ----------------
 394
 395    function C_Recvfrom
 396      (S       : C.int;
 397       Msg     : System.Address;
 398       Len     : C.int;
 399       Flags   : C.int;
 400       From    : Sockaddr_In_Access;
 401       Fromlen : access C.int) return C.int
 402    is
 403       Res : C.int;
 404
 405    begin
 406       loop
 407          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 408          exit when Thread_Blocking_IO
 409            or else Res /= Failure
 410            or else Non_Blocking_Socket (S)
 411            or else Errno /= Constants.EWOULDBLOCK;
 412          delay Quantum;
 413       end loop;
 414
 415       return Res;
 416    end C_Recvfrom;
 417
 418    ------------
 419    -- C_Send --
 420    ------------
 421
 422    function C_Send
 423      (S     : C.int;
 424       Msg   : System.Address;
 425       Len   : C.int;
 426       Flags : C.int) return C.int
 427    is
 428       Res : C.int;
 429
 430    begin
 431       loop
 432          Res := Syscall_Send (S, Msg, Len, Flags);
 433          exit when Thread_Blocking_IO
 434            or else Res /= Failure
 435            or else Non_Blocking_Socket (S)
 436            or else Errno /= Constants.EWOULDBLOCK;
 437          delay Quantum;
 438       end loop;
 439
 440       return Res;
 441    end C_Send;
 442
 443    --------------
 444    -- C_Sendto --
 445    --------------
 446
 447    function C_Sendto
 448      (S     : C.int;
 449       Msg   : System.Address;
 450       Len   : C.int;
 451       Flags : C.int;
 452       To    : Sockaddr_In_Access;
 453       Tolen : C.int) return C.int
 454    is
 455       Res : C.int;
 456
 457    begin
 458       loop
 459          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 460          exit when Thread_Blocking_IO
 461            or else Res /= Failure
 462            or else Non_Blocking_Socket (S)
 463            or else Errno /= Constants.EWOULDBLOCK;
 464          delay Quantum;
 465       end loop;
 466
 467       return Res;
 468    end C_Sendto;
 469
 470    --------------
 471    -- C_Socket --
 472    --------------
 473
 474    function C_Socket
 475      (Domain   : C.int;
 476       Typ      : C.int;
 477       Protocol : C.int) return C.int
 478    is
 479       R   : C.int;
 480       Val : aliased C.int := 1;
 481
 482       Res : C.int;
 483       pragma Unreferenced (Res);
 484
 485    begin
 486       R := Syscall_Socket (Domain, Typ, Protocol);
 487
 488       if not Thread_Blocking_IO
 489         and then R /= Failure
 490       then
 491          --  Do not use C_Ioctl as this subprogram tracks sockets set
 492          --  in non-blocking mode by user.
 493
 494          Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 495          --  Is it OK to ignore result ???
 496          Set_Non_Blocking_Socket (R, False);
 497       end if;
 498
 499       return R;
 500    end C_Socket;
 501
 502    --------------
 503    -- Finalize --
 504    --------------
 505
 506    procedure Finalize is
 507    begin
 508       null;
 509    end Finalize;
 510
 511    ----------------
 512    -- Initialize --
 513    ----------------
 514
 515    procedure Initialize (Process_Blocking_IO : Boolean) is
 516    begin
 517       Thread_Blocking_IO := not Process_Blocking_IO;
 518    end Initialize;
 519
 520    -------------------------
 521    -- Non_Blocking_Socket --
 522    -------------------------
 523
 524    function Non_Blocking_Socket (S : C.int) return Boolean is
 525       R : Boolean;
 526    begin
 527       Task_Lock.Lock;
 528       R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
 529       Task_Lock.Unlock;
 530       return R;
 531    end Non_Blocking_Socket;
 532
 533    -----------------
 534    -- Set_Address --
 535    -----------------
 536
 537    procedure Set_Address
 538      (Sin     : Sockaddr_In_Access;
 539       Address : In_Addr)
 540    is
 541    begin
 542       Sin.Sin_Addr   := Address;
 543    end Set_Address;
 544
 545    ----------------
 546    -- Set_Family --
 547    ----------------
 548
 549    procedure Set_Family
 550      (Sin    : Sockaddr_In_Access;
 551       Family : C.int)
 552    is
 553    begin
 554       Sin.Sin_Family := C.unsigned_char (Family);
 555    end Set_Family;
 556
 557    ----------------
 558    -- Set_Length --
 559    ----------------
 560
 561    procedure Set_Length
 562      (Sin : Sockaddr_In_Access;
 563       Len : C.int)
 564    is
 565    begin
 566       Sin.Sin_Length := C.unsigned_char (Len);
 567    end Set_Length;
 568
 569    -----------------------------
 570    -- Set_Non_Blocking_Socket --
 571    -----------------------------
 572
 573    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 574    begin
 575       Task_Lock.Lock;
 576       if V then
 577          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 578       else
 579          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 580       end if;
 581
 582       Task_Lock.Unlock;
 583    end Set_Non_Blocking_Socket;
 584
 585    --------------
 586    -- Set_Port --
 587    --------------
 588
 589    procedure Set_Port
 590      (Sin  : Sockaddr_In_Access;
 591       Port : C.unsigned_short)
 592    is
 593    begin
 594       Sin.Sin_Port   := Port;
 595    end Set_Port;
 596
 597    --------------------------
 598    -- Socket_Error_Message --
 599    --------------------------
 600
 601    function Socket_Error_Message
 602      (Errno : Integer) return C.Strings.chars_ptr
 603    is
 604       use type Interfaces.C.Strings.chars_ptr;
 605
 606       C_Msg : C.Strings.chars_ptr;
 607
 608    begin
 609       C_Msg := C_Strerror (C.int (Errno));
 610
 611       if C_Msg = C.Strings.Null_Ptr then
 612          return Unknown_System_Error;
 613
 614       else
 615          return C_Msg;
 616       end if;
 617    end Socket_Error_Message;
 618
 619 --  Package elaboration
 620
 621 begin
 622    Local_Hostent.all.H_Aliases   := Alias_Access;
 623
 624    --  VxWorks currently only supports AF_INET
 625
 626    Local_Hostent.all.H_Addrtype  := Constants.AF_INET;
 627
 628    Local_Hostent.all.H_Length    := 1;
 629    Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr;
 630
 631 end GNAT.Sockets.Thin;