gcc/ada/g-socthi-vms.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) 2001-2013, 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 is the version for OpenVMS
  33
  34 with GNAT.OS_Lib; use GNAT.OS_Lib;
  35 with GNAT.Task_Lock;
  36
  37 with Interfaces.C; use Interfaces.C;
  38
  39 package body GNAT.Sockets.Thin is
  40
  41    type VMS_Msghdr is new Msghdr;
  42    pragma Pack (VMS_Msghdr);
  43    --  On VMS 8.x (unlike other platforms), struct msghdr is packed, so a
  44    --  specific derived type is required. This structure was not packed on
  45    --  VMS 7.3.
  46
  47    function Is_VMS_V7 return Integer;
  48    pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7");
  49    --  Helper (defined in init.c) that returns a non-zero value if the VMS
  50    --  version is 7.x.
  51
  52    VMS_V7 : constant Boolean := Is_VMS_V7 /= 0;
  53    --  True if VMS version is 7.x.
  54
  55    Non_Blocking_Sockets : aliased Fd_Set;
  56    --  When this package is initialized with Process_Blocking_IO set to True,
  57    --  sockets are set in non-blocking mode to avoid blocking the whole process
  58    --  when a thread wants to perform a blocking IO operation. But the user can
  59    --  also set a socket in non-blocking mode by purpose. In order to make a
  60    --  difference between these two situations, we track the origin of
  61    --  non-blocking mode in Non_Blocking_Sockets. Note that if S is in
  62    --  Non_Blocking_Sockets, it has been set in non-blocking mode by the user.
  63
  64    Quantum : constant Duration := 0.2;
  65    --  When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking
  66    --  mode and we spend a period of time Quantum between two attempts on a
  67    --  blocking operation.
  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_Sendto
 110      (S     : C.int;
 111       Msg   : System.Address;
 112       Len   : C.int;
 113       Flags : C.int;
 114       To    : System.Address;
 115       Tolen : C.int) return C.int;
 116    pragma Import (C, Syscall_Sendto, "sendto");
 117
 118    function Syscall_Socket
 119      (Domain, Typ, Protocol : C.int) return C.int;
 120    pragma Import (C, Syscall_Socket, "socket");
 121
 122    function Non_Blocking_Socket (S : C.int) return Boolean;
 123    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 124
 125    --------------
 126    -- C_Accept --
 127    --------------
 128
 129    function C_Accept
 130      (S       : C.int;
 131       Addr    : System.Address;
 132       Addrlen : not null access C.int) return C.int
 133    is
 134       R   : C.int;
 135       Val : aliased C.int := 1;
 136
 137       Discard : C.int;
 138       pragma Warnings (Off, Discard);
 139
 140    begin
 141       loop
 142          R := Syscall_Accept (S, Addr, Addrlen);
 143          exit when SOSC.Thread_Blocking_IO
 144            or else R /= Failure
 145            or else Non_Blocking_Socket (S)
 146            or else Errno /= SOSC.EWOULDBLOCK;
 147          delay Quantum;
 148       end loop;
 149
 150       if not SOSC.Thread_Blocking_IO
 151         and then R /= Failure
 152       then
 153          --  A socket inherits the properties of its server, especially
 154          --  the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
 155          --  tracks sockets set in non-blocking mode by user.
 156
 157          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 158          Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 159       end if;
 160
 161       return R;
 162    end C_Accept;
 163
 164    ---------------
 165    -- C_Connect --
 166    ---------------
 167
 168    function C_Connect
 169      (S       : C.int;
 170       Name    : System.Address;
 171       Namelen : C.int) return C.int
 172    is
 173       Res : C.int;
 174
 175    begin
 176       Res := Syscall_Connect (S, Name, Namelen);
 177
 178       if SOSC.Thread_Blocking_IO
 179         or else Res /= Failure
 180         or else Non_Blocking_Socket (S)
 181         or else Errno /= SOSC.EINPROGRESS
 182       then
 183          return Res;
 184       end if;
 185
 186       declare
 187          WSet : aliased Fd_Set;
 188          Now  : aliased Timeval;
 189
 190       begin
 191          Reset_Socket_Set (WSet'Access);
 192          loop
 193             Insert_Socket_In_Set (WSet'Access, S);
 194             Now := Immediat;
 195             Res := C_Select
 196               (S + 1,
 197                No_Fd_Set_Access,
 198                WSet'Access,
 199                No_Fd_Set_Access,
 200                Now'Unchecked_Access);
 201
 202             exit when Res > 0;
 203
 204             if Res = Failure then
 205                return Res;
 206             end if;
 207
 208             delay Quantum;
 209          end loop;
 210       end;
 211
 212       Res := Syscall_Connect (S, Name, Namelen);
 213
 214       if Res = Failure and then Errno = SOSC.EISCONN then
 215          return Thin_Common.Success;
 216       else
 217          return Res;
 218       end if;
 219    end C_Connect;
 220
 221    ------------------
 222    -- Socket_Ioctl --
 223    ------------------
 224
 225    function Socket_Ioctl
 226      (S   : C.int;
 227       Req : SOSC.IOCTL_Req_T;
 228       Arg : access C.int) return C.int
 229    is
 230    begin
 231       if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
 232          if Arg.all /= 0 then
 233             Set_Non_Blocking_Socket (S, True);
 234          end if;
 235       end if;
 236
 237       return C_Ioctl (S, Req, Arg);
 238    end Socket_Ioctl;
 239
 240    ------------
 241    -- C_Recv --
 242    ------------
 243
 244    function C_Recv
 245      (S     : C.int;
 246       Msg   : System.Address;
 247       Len   : C.int;
 248       Flags : C.int) return C.int
 249    is
 250       Res : C.int;
 251
 252    begin
 253       loop
 254          Res := Syscall_Recv (S, Msg, Len, Flags);
 255          exit when SOSC.Thread_Blocking_IO
 256            or else Res /= Failure
 257            or else Non_Blocking_Socket (S)
 258            or else Errno /= SOSC.EWOULDBLOCK;
 259          delay Quantum;
 260       end loop;
 261
 262       return Res;
 263    end C_Recv;
 264
 265    ----------------
 266    -- C_Recvfrom --
 267    ----------------
 268
 269    function C_Recvfrom
 270      (S       : C.int;
 271       Msg     : System.Address;
 272       Len     : C.int;
 273       Flags   : C.int;
 274       From    : System.Address;
 275       Fromlen : not null access C.int) return C.int
 276    is
 277       Res : C.int;
 278
 279    begin
 280       loop
 281          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 282          exit when SOSC.Thread_Blocking_IO
 283            or else Res /= Failure
 284            or else Non_Blocking_Socket (S)
 285            or else Errno /= SOSC.EWOULDBLOCK;
 286          delay Quantum;
 287       end loop;
 288
 289       return Res;
 290    end C_Recvfrom;
 291
 292    ---------------
 293    -- C_Recvmsg --
 294    ---------------
 295
 296    function C_Recvmsg
 297      (S     : C.int;
 298       Msg   : System.Address;
 299       Flags : C.int) return System.CRTL.ssize_t
 300    is
 301       Res : C.int;
 302
 303       Msg_Addr : System.Address;
 304
 305       GNAT_Msg : Msghdr;
 306       for GNAT_Msg'Address use Msg;
 307       pragma Import (Ada, GNAT_Msg);
 308
 309       VMS_Msg : aliased VMS_Msghdr;
 310
 311    begin
 312       if VMS_V7 then
 313          Msg_Addr := Msg;
 314       else
 315          VMS_Msg := VMS_Msghdr (GNAT_Msg);
 316          Msg_Addr := VMS_Msg'Address;
 317       end if;
 318
 319       loop
 320          Res := Syscall_Recvmsg (S, Msg_Addr, Flags);
 321          exit when SOSC.Thread_Blocking_IO
 322            or else Res /= Failure
 323            or else Non_Blocking_Socket (S)
 324            or else Errno /= SOSC.EWOULDBLOCK;
 325          delay Quantum;
 326       end loop;
 327
 328       if not VMS_V7 then
 329          GNAT_Msg := Msghdr (VMS_Msg);
 330       end if;
 331
 332       return System.CRTL.ssize_t (Res);
 333    end C_Recvmsg;
 334
 335    ---------------
 336    -- C_Sendmsg --
 337    ---------------
 338
 339    function C_Sendmsg
 340      (S     : C.int;
 341       Msg   : System.Address;
 342       Flags : C.int) return System.CRTL.ssize_t
 343    is
 344       Res : C.int;
 345
 346       Msg_Addr : System.Address;
 347
 348       GNAT_Msg : Msghdr;
 349       for GNAT_Msg'Address use Msg;
 350       pragma Import (Ada, GNAT_Msg);
 351
 352       VMS_Msg : aliased VMS_Msghdr;
 353
 354    begin
 355       if VMS_V7 then
 356          Msg_Addr := Msg;
 357       else
 358          VMS_Msg := VMS_Msghdr (GNAT_Msg);
 359          Msg_Addr := VMS_Msg'Address;
 360       end if;
 361
 362       loop
 363          Res := Syscall_Sendmsg (S, Msg_Addr, Flags);
 364          exit when SOSC.Thread_Blocking_IO
 365            or else Res /= Failure
 366            or else Non_Blocking_Socket (S)
 367            or else Errno /= SOSC.EWOULDBLOCK;
 368          delay Quantum;
 369       end loop;
 370
 371       if not VMS_V7 then
 372          GNAT_Msg := Msghdr (VMS_Msg);
 373       end if;
 374
 375       return System.CRTL.ssize_t (Res);
 376    end C_Sendmsg;
 377
 378    --------------
 379    -- C_Sendto --
 380    --------------
 381
 382    function C_Sendto
 383      (S     : C.int;
 384       Msg   : System.Address;
 385       Len   : C.int;
 386       Flags : C.int;
 387       To    : System.Address;
 388       Tolen : C.int) return C.int
 389    is
 390       Res : C.int;
 391
 392    begin
 393       loop
 394          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 395          exit when SOSC.Thread_Blocking_IO
 396            or else Res /= Failure
 397            or else Non_Blocking_Socket (S)
 398            or else Errno /= SOSC.EWOULDBLOCK;
 399          delay Quantum;
 400       end loop;
 401
 402       return Res;
 403    end C_Sendto;
 404
 405    --------------
 406    -- C_Socket --
 407    --------------
 408
 409    function C_Socket
 410      (Domain   : C.int;
 411       Typ      : C.int;
 412       Protocol : C.int) return C.int
 413    is
 414       R   : C.int;
 415       Val : aliased C.int := 1;
 416
 417       Discard : C.int;
 418       pragma Unreferenced (Discard);
 419
 420    begin
 421       R := Syscall_Socket (Domain, Typ, Protocol);
 422
 423       if not SOSC.Thread_Blocking_IO
 424         and then R /= Failure
 425       then
 426          --  Do not use Socket_Ioctl as this subprogram tracks sockets set
 427          --  in non-blocking mode by user.
 428
 429          Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 430          Set_Non_Blocking_Socket (R, False);
 431       end if;
 432
 433       return R;
 434    end C_Socket;
 435
 436    --------------
 437    -- Finalize --
 438    --------------
 439
 440    procedure Finalize is
 441    begin
 442       null;
 443    end Finalize;
 444
 445    -------------------------
 446    -- Host_Error_Messages --
 447    -------------------------
 448
 449    package body Host_Error_Messages is separate;
 450
 451    ----------------
 452    -- Initialize --
 453    ----------------
 454
 455    procedure Initialize is
 456    begin
 457       Reset_Socket_Set (Non_Blocking_Sockets'Access);
 458    end Initialize;
 459
 460    -------------------------
 461    -- Non_Blocking_Socket --
 462    -------------------------
 463
 464    function Non_Blocking_Socket (S : C.int) return Boolean is
 465       R : Boolean;
 466    begin
 467       Task_Lock.Lock;
 468       R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
 469       Task_Lock.Unlock;
 470       return R;
 471    end Non_Blocking_Socket;
 472
 473    -----------------------------
 474    -- Set_Non_Blocking_Socket --
 475    -----------------------------
 476
 477    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 478    begin
 479       Task_Lock.Lock;
 480
 481       if V then
 482          Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
 483       else
 484          Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
 485       end if;
 486
 487       Task_Lock.Unlock;
 488    end Set_Non_Blocking_Socket;
 489
 490    --------------------
 491    -- Signalling_Fds --
 492    --------------------
 493
 494    package body Signalling_Fds is separate;
 495
 496    --------------------------
 497    -- Socket_Error_Message --
 498    --------------------------
 499
 500    function Socket_Error_Message (Errno : Integer) return String is separate;
 501
 502 end GNAT.Sockets.Thin;