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