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-2009, 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
  45 package body GNAT.Sockets.Thin is
  46
  47    Non_Blocking_Sockets : aliased Fd_Set;
  48    --  When this package is initialized with Process_Blocking_IO set
  49    --  to True, sockets are set in non-blocking mode to avoid blocking
  50    --  the whole process when a thread wants to perform a blocking IO
  51    --  operation. But the user can also set a socket in non-blocking
  52    --  mode by purpose. In order to make a difference between these
  53    --  two situations, we track the origin of non-blocking mode in
  54    --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
  55    --  been set in non-blocking mode by the user.
  56
  57    Quantum : constant Duration := 0.2;
  58    --  When SOSC.Thread_Blocking_IO is False, we set sockets in
  59    --  non-blocking mode and we spend a period of time Quantum between
  60    --  two attempts on a blocking operation.
  61
  62    Unknown_System_Error : constant C.Strings.chars_ptr :=
  63                             C.Strings.New_String ("Unknown system error");
  64
  65    -----------------------
  66    -- Local Subprograms --
  67    -----------------------
  68
  69    --  All these require comments ???
  70
  71    function Syscall_Accept
  72      (S       : C.int;
  73       Addr    : System.Address;
  74       Addrlen : not null access C.int) return C.int;
  75    pragma Import (C, Syscall_Accept, "accept");
  76
  77    function Syscall_Connect
  78      (S       : C.int;
  79       Name    : System.Address;
  80       Namelen : C.int) return C.int;
  81    pragma Import (C, Syscall_Connect, "connect");
  82
  83    function Syscall_Recv
  84      (S     : C.int;
  85       Msg   : System.Address;
  86       Len   : C.int;
  87       Flags : C.int) return C.int;
  88    pragma Import (C, Syscall_Recv, "recv");
  89
  90    function Syscall_Recvfrom
  91      (S       : C.int;
  92       Msg     : System.Address;
  93       Len     : C.int;
  94       Flags   : C.int;
  95       From    : System.Address;
  96       Fromlen : not null access C.int) return C.int;
  97    pragma Import (C, Syscall_Recvfrom, "recvfrom");
  98
  99    function Syscall_Recvmsg
 100      (S     : C.int;
 101       Msg   : System.Address;
 102       Flags : C.int) return C.int;
 103    pragma Import (C, Syscall_Recvmsg, "recvmsg");
 104
 105    function Syscall_Sendmsg
 106      (S     : C.int;
 107       Msg   : System.Address;
 108       Flags : C.int) return C.int;
 109    pragma Import (C, Syscall_Sendmsg, "sendmsg");
 110
 111    function Syscall_Send
 112      (S     : C.int;
 113       Msg   : System.Address;
 114       Len   : C.int;
 115       Flags : C.int) return C.int;
 116    pragma Import (C, Syscall_Send, "send");
 117
 118    function Syscall_Sendto
 119      (S     : C.int;
 120       Msg   : System.Address;
 121       Len   : C.int;
 122       Flags : C.int;
 123       To    : System.Address;
 124       Tolen : C.int) return C.int;
 125    pragma Import (C, Syscall_Sendto, "sendto");
 126
 127    function Syscall_Socket
 128      (Domain   : C.int;
 129       Typ      : C.int;
 130       Protocol : C.int) return C.int;
 131    pragma Import (C, Syscall_Socket, "socket");
 132
 133    function Non_Blocking_Socket (S : C.int) return Boolean;
 134    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 135
 136    --------------
 137    -- C_Accept --
 138    --------------
 139
 140    function C_Accept
 141      (S       : C.int;
 142       Addr    : System.Address;
 143       Addrlen : not null access C.int) return C.int
 144    is
 145       R   : C.int;
 146       Val : aliased C.int := 1;
 147
 148       Res : C.int;
 149       pragma Unreferenced (Res);
 150
 151    begin
 152       loop
 153          R := Syscall_Accept (S, Addr, Addrlen);
 154          exit when SOSC.Thread_Blocking_IO
 155            or else R /= Failure
 156            or else Non_Blocking_Socket (S)
 157            or else Errno /= SOSC.EWOULDBLOCK;
 158          delay Quantum;
 159       end loop;
 160
 161       if not SOSC.Thread_Blocking_IO
 162         and then R /= Failure
 163       then
 164          --  A socket inherits the properties of its server especially
 165          --  the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
 166          --  tracks sockets set in non-blocking mode by user.
 167
 168          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 169          Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 170          --  Is it OK to ignore result ???
 171       end if;
 172
 173       return R;
 174    end C_Accept;
 175
 176    ---------------
 177    -- C_Connect --
 178    ---------------
 179
 180    function C_Connect
 181      (S       : C.int;
 182       Name    : System.Address;
 183       Namelen : C.int) return C.int
 184    is
 185       Res : C.int;
 186
 187    begin
 188       Res := Syscall_Connect (S, Name, Namelen);
 189
 190       if SOSC.Thread_Blocking_IO
 191         or else Res /= Failure
 192         or else Non_Blocking_Socket (S)
 193         or else Errno /= SOSC.EINPROGRESS
 194       then
 195          return Res;
 196       end if;
 197
 198       declare
 199          WSet : aliased Fd_Set;
 200          Now  : aliased Timeval;
 201       begin
 202          Reset_Socket_Set (WSet'Access);
 203          loop
 204             Insert_Socket_In_Set (WSet'Access, S);
 205             Now := Immediat;
 206             Res := C_Select
 207               (S + 1,
 208                No_Fd_Set_Access,
 209                WSet'Access,
 210                No_Fd_Set_Access,
 211                Now'Unchecked_Access);
 212
 213             exit when Res > 0;
 214
 215             if Res = Failure then
 216                return Res;
 217             end if;
 218
 219             delay Quantum;
 220          end loop;
 221       end;
 222
 223       Res := Syscall_Connect (S, Name, Namelen);
 224
 225       if Res = Failure
 226         and then Errno = SOSC.EISCONN
 227       then
 228          return Thin_Common.Success;
 229       else
 230          return Res;
 231       end if;
 232    end C_Connect;
 233
 234    ------------------
 235    -- Socket_Ioctl --
 236    ------------------
 237
 238    function Socket_Ioctl
 239      (S   : C.int;
 240       Req : C.int;
 241       Arg : access C.int) return C.int
 242    is
 243    begin
 244       if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
 245          if Arg.all /= 0 then
 246             Set_Non_Blocking_Socket (S, True);
 247          end if;
 248       end if;
 249
 250       return C_Ioctl (S, Req, Arg);
 251    end Socket_Ioctl;
 252
 253    ------------
 254    -- C_Recv --
 255    ------------
 256
 257    function C_Recv
 258      (S     : C.int;
 259       Msg   : System.Address;
 260       Len   : C.int;
 261       Flags : C.int) return C.int
 262    is
 263       Res : C.int;
 264
 265    begin
 266       loop
 267          Res := Syscall_Recv (S, Msg, Len, Flags);
 268          exit when SOSC.Thread_Blocking_IO
 269            or else Res /= Failure
 270            or else Non_Blocking_Socket (S)
 271            or else Errno /= SOSC.EWOULDBLOCK;
 272          delay Quantum;
 273       end loop;
 274
 275       return Res;
 276    end C_Recv;
 277
 278    ----------------
 279    -- C_Recvfrom --
 280    ----------------
 281
 282    function C_Recvfrom
 283      (S       : C.int;
 284       Msg     : System.Address;
 285       Len     : C.int;
 286       Flags   : C.int;
 287       From    : System.Address;
 288       Fromlen : not null access C.int) return C.int
 289    is
 290       Res : C.int;
 291
 292    begin
 293       loop
 294          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 295          exit when SOSC.Thread_Blocking_IO
 296            or else Res /= Failure
 297            or else Non_Blocking_Socket (S)
 298            or else Errno /= SOSC.EWOULDBLOCK;
 299          delay Quantum;
 300       end loop;
 301
 302       return Res;
 303    end C_Recvfrom;
 304
 305    ---------------
 306    -- C_Recvmsg --
 307    ---------------
 308
 309    function C_Recvmsg
 310      (S     : C.int;
 311       Msg   : System.Address;
 312       Flags : C.int) return ssize_t
 313    is
 314       Res : C.int;
 315
 316    begin
 317       loop
 318          Res := Syscall_Recvmsg (S, Msg, Flags);
 319          exit when SOSC.Thread_Blocking_IO
 320            or else Res /= Failure
 321            or else Non_Blocking_Socket (S)
 322            or else Errno /= SOSC.EWOULDBLOCK;
 323          delay Quantum;
 324       end loop;
 325
 326       return ssize_t (Res);
 327    end C_Recvmsg;
 328
 329    ---------------
 330    -- C_Sendmsg --
 331    ---------------
 332
 333    function C_Sendmsg
 334      (S     : C.int;
 335       Msg   : System.Address;
 336       Flags : C.int) return ssize_t
 337    is
 338       Res : C.int;
 339
 340    begin
 341       loop
 342          Res := Syscall_Sendmsg (S, Msg, Flags);
 343          exit when SOSC.Thread_Blocking_IO
 344            or else Res /= Failure
 345            or else Non_Blocking_Socket (S)
 346            or else Errno /= SOSC.EWOULDBLOCK;
 347          delay Quantum;
 348       end loop;
 349
 350       return ssize_t (Res);
 351    end C_Sendmsg;
 352
 353    --------------
 354    -- C_Sendto --
 355    --------------
 356
 357    function C_Sendto
 358      (S     : C.int;
 359       Msg   : System.Address;
 360       Len   : C.int;
 361       Flags : C.int;
 362       To    : System.Address;
 363       Tolen : C.int) return C.int
 364    is
 365       use System;
 366
 367       Res : C.int;
 368
 369    begin
 370       loop
 371          if To = Null_Address then
 372
 373             --  In violation of the standard sockets API, VxWorks does not
 374             --  support sendto(2) calls on connected sockets with a null
 375             --  destination address, so use send(2) instead in that case.
 376
 377             Res := Syscall_Send (S, Msg, Len, Flags);
 378
 379          --  Normal case where destination address is non-null
 380
 381          else
 382             Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 383          end if;
 384
 385          exit when SOSC.Thread_Blocking_IO
 386            or else Res /= Failure
 387            or else Non_Blocking_Socket (S)
 388            or else Errno /= SOSC.EWOULDBLOCK;
 389          delay Quantum;
 390       end loop;
 391
 392       return Res;
 393    end C_Sendto;
 394
 395    --------------
 396    -- C_Socket --
 397    --------------
 398
 399    function C_Socket
 400      (Domain   : C.int;
 401       Typ      : C.int;
 402       Protocol : C.int) return C.int
 403    is
 404       R   : C.int;
 405       Val : aliased C.int := 1;
 406
 407       Res : C.int;
 408       pragma Unreferenced (Res);
 409
 410    begin
 411       R := Syscall_Socket (Domain, Typ, Protocol);
 412
 413       if not SOSC.Thread_Blocking_IO
 414         and then R /= Failure
 415       then
 416          --  Do not use Socket_Ioctl as this subprogram tracks sockets set
 417          --  in non-blocking mode by user.
 418
 419          Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 420          --  Is it OK to ignore result ???
 421          Set_Non_Blocking_Socket (R, False);
 422       end if;
 423
 424       return R;
 425    end C_Socket;
 426
 427    --------------
 428    -- Finalize --
 429    --------------
 430
 431    procedure Finalize is
 432    begin
 433       null;
 434    end Finalize;
 435
 436    -------------------------
 437    -- Host_Error_Messages --
 438    -------------------------
 439
 440    package body Host_Error_Messages is separate;
 441
 442    ----------------
 443    -- Initialize --
 444    ----------------
 445
 446    procedure Initialize is
 447    begin
 448       Reset_Socket_Set (Non_Blocking_Sockets'Access);
 449    end Initialize;
 450
 451    -------------------------
 452    -- Non_Blocking_Socket --
 453    -------------------------
 454
 455    function Non_Blocking_Socket (S : C.int) return Boolean is
 456       R : Boolean;
 457    begin
 458       Task_Lock.Lock;
 459       R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
 460       Task_Lock.Unlock;
 461       return R;
 462    end Non_Blocking_Socket;
 463
 464    -----------------------------
 465    -- Set_Non_Blocking_Socket --
 466    -----------------------------
 467
 468    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 469    begin
 470       Task_Lock.Lock;
 471       if V then
 472          Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
 473       else
 474          Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
 475       end if;
 476
 477       Task_Lock.Unlock;
 478    end Set_Non_Blocking_Socket;
 479
 480    --------------------
 481    -- Signalling_Fds --
 482    --------------------
 483
 484    package body Signalling_Fds is separate;
 485
 486    --------------------------
 487    -- Socket_Error_Message --
 488    --------------------------
 489
 490    function Socket_Error_Message
 491      (Errno : Integer) return C.Strings.chars_ptr
 492    is separate;
 493
 494 end GNAT.Sockets.Thin;