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