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