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