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