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    Non_Blocking_Sockets : aliased Fd_Set;
  44    --  When this package is initialized with Process_Blocking_IO set to True,
  45    --  sockets are set in non-blocking mode to avoid blocking the whole process
  46    --  when a thread wants to perform a blocking IO operation. But the user can
  47    --  also set a socket in non-blocking mode by purpose. In order to make a
  48    --  difference between these two situations, we track the origin of
  49    --  non-blocking mode in Non_Blocking_Sockets. If S is in
  50    --  Non_Blocking_Sockets, it has been set in non-blocking mode by the user.
  51
  52    Quantum : constant Duration := 0.2;
  53    --  When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking
  54    --  mode and we spend a period of time Quantum between two attempts on a
  55    --  blocking operation.
  56
  57    Unknown_System_Error : constant C.Strings.chars_ptr :=
  58                             C.Strings.New_String ("Unknown system error");
  59
  60    function Syscall_Accept
  61      (S       : C.int;
  62       Addr    : System.Address;
  63       Addrlen : not null access C.int) return C.int;
  64    pragma Import (C, Syscall_Accept, "accept");
  65
  66    function Syscall_Connect
  67      (S       : C.int;
  68       Name    : System.Address;
  69       Namelen : C.int) return C.int;
  70    pragma Import (C, Syscall_Connect, "connect");
  71
  72    function Syscall_Ioctl
  73      (S    : C.int;
  74       Req  : C.int;
  75       Arg  : access C.int) return C.int;
  76    pragma Import (C, Syscall_Ioctl, "ioctl");
  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    : Sockaddr_In_Access;
  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_Sendto
 107      (S     : C.int;
 108       Msg   : System.Address;
 109       Len   : C.int;
 110       Flags : C.int;
 111       To    : Sockaddr_In_Access;
 112       Tolen : C.int) return C.int;
 113    pragma Import (C, Syscall_Sendto, "sendto");
 114
 115    function Syscall_Socket
 116      (Domain, Typ, Protocol : C.int) return C.int;
 117    pragma Import (C, Syscall_Socket, "socket");
 118
 119    function Non_Blocking_Socket (S : C.int) return Boolean;
 120    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 121
 122    --------------
 123    -- C_Accept --
 124    --------------
 125
 126    function C_Accept
 127      (S       : C.int;
 128       Addr    : System.Address;
 129       Addrlen : not null access C.int) return C.int
 130    is
 131       R   : C.int;
 132       Val : aliased C.int := 1;
 133
 134       Discard : C.int;
 135       pragma Warnings (Off, Discard);
 136
 137    begin
 138       loop
 139          R := Syscall_Accept (S, Addr, Addrlen);
 140          exit when SOSC.Thread_Blocking_IO
 141            or else R /= Failure
 142            or else Non_Blocking_Socket (S)
 143            or else Errno /= SOSC.EWOULDBLOCK;
 144          delay Quantum;
 145       end loop;
 146
 147       if not SOSC.Thread_Blocking_IO
 148         and then R /= Failure
 149       then
 150          --  A socket inherits the properties of its server, especially
 151          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 152          --  tracks sockets set in non-blocking mode by user.
 153
 154          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 155          Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
 156       end if;
 157
 158       return R;
 159    end C_Accept;
 160
 161    ---------------
 162    -- C_Connect --
 163    ---------------
 164
 165    function C_Connect
 166      (S       : C.int;
 167       Name    : System.Address;
 168       Namelen : C.int) return C.int
 169    is
 170       Res : C.int;
 171
 172    begin
 173       Res := Syscall_Connect (S, Name, Namelen);
 174
 175       if SOSC.Thread_Blocking_IO
 176         or else Res /= Failure
 177         or else Non_Blocking_Socket (S)
 178         or else Errno /= SOSC.EINPROGRESS
 179       then
 180          return Res;
 181       end if;
 182
 183       declare
 184          WSet : aliased Fd_Set;
 185          Now  : aliased Timeval;
 186
 187       begin
 188          Reset_Socket_Set (WSet'Access);
 189          loop
 190             Insert_Socket_In_Set (WSet'Access, S);
 191             Now := Immediat;
 192             Res := C_Select
 193               (S + 1,
 194                No_Fd_Set_Access,
 195                WSet'Access,
 196                No_Fd_Set_Access,
 197                Now'Unchecked_Access);
 198
 199             exit when Res > 0;
 200
 201             if Res = Failure then
 202                return Res;
 203             end if;
 204
 205             delay Quantum;
 206          end loop;
 207       end;
 208
 209       Res := Syscall_Connect (S, Name, Namelen);
 210
 211       if Res = Failure and then Errno = SOSC.EISCONN then
 212          return Thin_Common.Success;
 213
 214       else
 215          return Res;
 216       end if;
 217    end C_Connect;
 218
 219    -------------
 220    -- C_Ioctl --
 221    -------------
 222
 223    function C_Ioctl
 224      (S   : C.int;
 225       Req : C.int;
 226       Arg : access C.int) return C.int
 227    is
 228    begin
 229       if not SOSC.Thread_Blocking_IO
 230         and then Req = SOSC.FIONBIO
 231       then
 232          if Arg.all /= 0 then
 233             Set_Non_Blocking_Socket (S, True);
 234          end if;
 235       end if;
 236
 237       return Syscall_Ioctl (S, Req, Arg);
 238    end C_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    : Sockaddr_In_Access;
 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 ssize_t
 300    is
 301       Res : C.int;
 302
 303    begin
 304       loop
 305          Res := Syscall_Recvmsg (S, Msg, Flags);
 306          exit when SOSC.Thread_Blocking_IO
 307            or else Res /= Failure
 308            or else Non_Blocking_Socket (S)
 309            or else Errno /= SOSC.EWOULDBLOCK;
 310          delay Quantum;
 311       end loop;
 312
 313       return ssize_t (Res);
 314    end C_Recvmsg;
 315
 316    ---------------
 317    -- C_Sendmsg --
 318    ---------------
 319
 320    function C_Sendmsg
 321      (S     : C.int;
 322       Msg   : System.Address;
 323       Flags : C.int) return ssize_t
 324    is
 325       Res : C.int;
 326
 327    begin
 328       loop
 329          Res := Syscall_Sendmsg (S, Msg, Flags);
 330          exit when SOSC.Thread_Blocking_IO
 331            or else Res /= Failure
 332            or else Non_Blocking_Socket (S)
 333            or else Errno /= SOSC.EWOULDBLOCK;
 334          delay Quantum;
 335       end loop;
 336
 337       return ssize_t (Res);
 338    end C_Sendmsg;
 339
 340    --------------
 341    -- C_Sendto --
 342    --------------
 343
 344    function C_Sendto
 345      (S     : C.int;
 346       Msg   : System.Address;
 347       Len   : C.int;
 348       Flags : C.int;
 349       To    : Sockaddr_In_Access;
 350       Tolen : C.int) return C.int
 351    is
 352       Res : C.int;
 353
 354    begin
 355       loop
 356          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 357          exit when SOSC.Thread_Blocking_IO
 358            or else Res /= Failure
 359            or else Non_Blocking_Socket (S)
 360            or else Errno /= SOSC.EWOULDBLOCK;
 361          delay Quantum;
 362       end loop;
 363
 364       return Res;
 365    end C_Sendto;
 366
 367    --------------
 368    -- C_Socket --
 369    --------------
 370
 371    function C_Socket
 372      (Domain   : C.int;
 373       Typ      : C.int;
 374       Protocol : C.int) return C.int
 375    is
 376       R   : C.int;
 377       Val : aliased C.int := 1;
 378
 379       Discard : C.int;
 380       pragma Unreferenced (Discard);
 381
 382    begin
 383       R := Syscall_Socket (Domain, Typ, Protocol);
 384
 385       if not SOSC.Thread_Blocking_IO
 386         and then R /= Failure
 387       then
 388          --  Do not use C_Ioctl as this subprogram tracks sockets set
 389          --  in non-blocking mode by user.
 390
 391          Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
 392          Set_Non_Blocking_Socket (R, False);
 393       end if;
 394
 395       return R;
 396    end C_Socket;
 397
 398    --------------
 399    -- Finalize --
 400    --------------
 401
 402    procedure Finalize is
 403    begin
 404       null;
 405    end Finalize;
 406
 407    -------------------------
 408    -- Host_Error_Messages --
 409    -------------------------
 410
 411    package body Host_Error_Messages is separate;
 412
 413    ----------------
 414    -- Initialize --
 415    ----------------
 416
 417    procedure Initialize is
 418    begin
 419       Reset_Socket_Set (Non_Blocking_Sockets'Access);
 420    end Initialize;
 421
 422    -------------------------
 423    -- Non_Blocking_Socket --
 424    -------------------------
 425
 426    function Non_Blocking_Socket (S : C.int) return Boolean is
 427       R : Boolean;
 428    begin
 429       Task_Lock.Lock;
 430       R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
 431       Task_Lock.Unlock;
 432       return R;
 433    end Non_Blocking_Socket;
 434
 435    -----------------------------
 436    -- Set_Non_Blocking_Socket --
 437    -----------------------------
 438
 439    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 440    begin
 441       Task_Lock.Lock;
 442
 443       if V then
 444          Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
 445       else
 446          Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
 447       end if;
 448
 449       Task_Lock.Unlock;
 450    end Set_Non_Blocking_Socket;
 451
 452    --------------------
 453    -- Signalling_Fds --
 454    --------------------
 455
 456    package body Signalling_Fds is separate;
 457
 458    --------------------------
 459    -- Socket_Error_Message --
 460    --------------------------
 461
 462    function Socket_Error_Message
 463      (Errno : Integer) return C.Strings.chars_ptr
 464    is
 465       use type Interfaces.C.Strings.chars_ptr;
 466
 467       C_Msg : C.Strings.chars_ptr;
 468
 469    begin
 470       C_Msg := C_Strerror (C.int (Errno));
 471
 472       if C_Msg = C.Strings.Null_Ptr then
 473          return Unknown_System_Error;
 474       else
 475          return C_Msg;
 476       end if;
 477    end Socket_Error_Message;
 478
 479 end GNAT.Sockets.Thin;