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-2008, 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 --  Temporary version for Alpha/VMS
  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 with System.Address_To_Access_Conversions;
  42
  43 package body GNAT.Sockets.Thin is
  44
  45    Non_Blocking_Sockets : aliased Fd_Set;
  46    --  When this package is initialized with Process_Blocking_IO set
  47    --  to True, sockets are set in non-blocking mode to avoid blocking
  48    --  the whole process when a thread wants to perform a blocking IO
  49    --  operation. But the user can also set a socket in non-blocking
  50    --  mode by purpose. In order to make a difference between these
  51    --  two situations, we track the origin of non-blocking mode in
  52    --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
  53    --  been set in non-blocking mode by the user.
  54
  55    Quantum : constant Duration := 0.2;
  56    --  When SOSC.Thread_Blocking_IO is False, we set sockets in
  57    --  non-blocking mode and we spend a period of time Quantum between
  58    --  two attempts on a blocking operation.
  59
  60    Unknown_System_Error : constant C.Strings.chars_ptr :=
  61                             C.Strings.New_String ("Unknown system error");
  62
  63    function Syscall_Accept
  64      (S       : C.int;
  65       Addr    : System.Address;
  66       Addrlen : not null access C.int) return C.int;
  67    pragma Import (C, Syscall_Accept, "accept");
  68
  69    function Syscall_Connect
  70      (S       : C.int;
  71       Name    : System.Address;
  72       Namelen : C.int) return C.int;
  73    pragma Import (C, Syscall_Connect, "connect");
  74
  75    function Syscall_Ioctl
  76      (S    : C.int;
  77       Req  : C.int;
  78       Arg  : access C.int) return C.int;
  79    pragma Import (C, Syscall_Ioctl, "ioctl");
  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    : Sockaddr_In_Access;
  94       Fromlen : not null access C.int) return C.int;
  95    pragma Import (C, Syscall_Recvfrom, "recvfrom");
  96
  97    function Syscall_Sendto
  98      (S     : C.int;
  99       Msg   : System.Address;
 100       Len   : C.int;
 101       Flags : C.int;
 102       To    : Sockaddr_In_Access;
 103       Tolen : C.int) return C.int;
 104    pragma Import (C, Syscall_Sendto, "sendto");
 105
 106    function Syscall_Socket
 107      (Domain, Typ, Protocol : C.int) return C.int;
 108    pragma Import (C, Syscall_Socket, "socket");
 109
 110    function Non_Blocking_Socket (S : C.int) return Boolean;
 111    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 112
 113    --------------
 114    -- C_Accept --
 115    --------------
 116
 117    function C_Accept
 118      (S       : C.int;
 119       Addr    : System.Address;
 120       Addrlen : not null access C.int) return C.int
 121    is
 122       R   : C.int;
 123       Val : aliased C.int := 1;
 124
 125       Discard : C.int;
 126       pragma Warnings (Off, Discard);
 127
 128    begin
 129       loop
 130          R := Syscall_Accept (S, Addr, Addrlen);
 131          exit when SOSC.Thread_Blocking_IO
 132            or else R /= Failure
 133            or else Non_Blocking_Socket (S)
 134            or else Errno /= SOSC.EWOULDBLOCK;
 135          delay Quantum;
 136       end loop;
 137
 138       if not SOSC.Thread_Blocking_IO
 139         and then R /= Failure
 140       then
 141          --  A socket inherits the properties of its server, especially
 142          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 143          --  tracks sockets set in non-blocking mode by user.
 144
 145          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 146          Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
 147       end if;
 148
 149       return R;
 150    end C_Accept;
 151
 152    ---------------
 153    -- C_Connect --
 154    ---------------
 155
 156    function C_Connect
 157      (S       : C.int;
 158       Name    : System.Address;
 159       Namelen : C.int) return C.int
 160    is
 161       Res : C.int;
 162
 163    begin
 164       Res := Syscall_Connect (S, Name, Namelen);
 165
 166       if SOSC.Thread_Blocking_IO
 167         or else Res /= Failure
 168         or else Non_Blocking_Socket (S)
 169         or else Errno /= SOSC.EINPROGRESS
 170       then
 171          return Res;
 172       end if;
 173
 174       declare
 175          WSet : aliased Fd_Set;
 176          Now  : aliased Timeval;
 177
 178       begin
 179          Reset_Socket_Set (WSet'Access);
 180          loop
 181             Insert_Socket_In_Set (WSet'Access, S);
 182             Now := Immediat;
 183             Res := C_Select
 184               (S + 1,
 185                No_Fd_Set_Access,
 186                WSet'Access,
 187                No_Fd_Set_Access,
 188                Now'Unchecked_Access);
 189
 190             exit when Res > 0;
 191
 192             if Res = Failure then
 193                return Res;
 194             end if;
 195
 196             delay Quantum;
 197          end loop;
 198       end;
 199
 200       Res := Syscall_Connect (S, Name, Namelen);
 201
 202       if Res = Failure and then Errno = SOSC.EISCONN then
 203          return Thin_Common.Success;
 204
 205       else
 206          return Res;
 207       end if;
 208    end C_Connect;
 209
 210    -------------
 211    -- C_Ioctl --
 212    -------------
 213
 214    function C_Ioctl
 215      (S   : C.int;
 216       Req : C.int;
 217       Arg : access C.int) return C.int
 218    is
 219    begin
 220       if not SOSC.Thread_Blocking_IO
 221         and then Req = SOSC.FIONBIO
 222       then
 223          if Arg.all /= 0 then
 224             Set_Non_Blocking_Socket (S, True);
 225          end if;
 226       end if;
 227
 228       return Syscall_Ioctl (S, Req, Arg);
 229    end C_Ioctl;
 230
 231    ------------
 232    -- C_Recv --
 233    ------------
 234
 235    function C_Recv
 236      (S     : C.int;
 237       Msg   : System.Address;
 238       Len   : C.int;
 239       Flags : C.int) return C.int
 240    is
 241       Res : C.int;
 242
 243    begin
 244       loop
 245          Res := Syscall_Recv (S, Msg, Len, Flags);
 246          exit when SOSC.Thread_Blocking_IO
 247            or else Res /= Failure
 248            or else Non_Blocking_Socket (S)
 249            or else Errno /= SOSC.EWOULDBLOCK;
 250          delay Quantum;
 251       end loop;
 252
 253       return Res;
 254    end C_Recv;
 255
 256    ----------------
 257    -- C_Recvfrom --
 258    ----------------
 259
 260    function C_Recvfrom
 261      (S       : C.int;
 262       Msg     : System.Address;
 263       Len     : C.int;
 264       Flags   : C.int;
 265       From    : Sockaddr_In_Access;
 266       Fromlen : not null access C.int) return C.int
 267    is
 268       Res : C.int;
 269
 270    begin
 271       loop
 272          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 273          exit when SOSC.Thread_Blocking_IO
 274            or else Res /= Failure
 275            or else Non_Blocking_Socket (S)
 276            or else Errno /= SOSC.EWOULDBLOCK;
 277          delay Quantum;
 278       end loop;
 279
 280       return Res;
 281    end C_Recvfrom;
 282
 283    --------------
 284    -- C_Sendto --
 285    --------------
 286
 287    function C_Sendto
 288      (S     : C.int;
 289       Msg   : System.Address;
 290       Len   : C.int;
 291       Flags : C.int;
 292       To    : Sockaddr_In_Access;
 293       Tolen : C.int) return C.int
 294    is
 295       Res : C.int;
 296
 297    begin
 298       loop
 299          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 300          exit when SOSC.Thread_Blocking_IO
 301            or else Res /= Failure
 302            or else Non_Blocking_Socket (S)
 303            or else Errno /= SOSC.EWOULDBLOCK;
 304          delay Quantum;
 305       end loop;
 306
 307       return Res;
 308    end C_Sendto;
 309
 310    --------------
 311    -- C_Socket --
 312    --------------
 313
 314    function C_Socket
 315      (Domain   : C.int;
 316       Typ      : C.int;
 317       Protocol : C.int) return C.int
 318    is
 319       R   : C.int;
 320       Val : aliased C.int := 1;
 321
 322       Discard : C.int;
 323       pragma Unreferenced (Discard);
 324
 325    begin
 326       R := Syscall_Socket (Domain, Typ, Protocol);
 327
 328       if not SOSC.Thread_Blocking_IO
 329         and then R /= Failure
 330       then
 331          --  Do not use C_Ioctl as this subprogram tracks sockets set
 332          --  in non-blocking mode by user.
 333
 334          Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
 335          Set_Non_Blocking_Socket (R, False);
 336       end if;
 337
 338       return R;
 339    end C_Socket;
 340
 341    --------------
 342    -- Finalize --
 343    --------------
 344
 345    procedure Finalize is
 346    begin
 347       null;
 348    end Finalize;
 349
 350    -------------------------
 351    -- Host_Error_Messages --
 352    -------------------------
 353
 354    package body Host_Error_Messages is separate;
 355
 356    ---------------
 357    -- Inet_Pton --
 358    ---------------
 359
 360    --  VMS does not support inet_pton(3), so emulate it here in terms of
 361    --  inet_addr(3).
 362
 363    function Inet_Pton
 364      (Af  : C.int;
 365       Cp  : C.Strings.chars_ptr;
 366       Inp : System.Address) return C.int
 367    is
 368       use C.Strings;
 369       use System;
 370
 371       Res : aliased C.int;
 372       package Conv is new System.Address_To_Access_Conversions (C.int);
 373       function C_Inet_Addr (Cp : C.Strings.chars_ptr) return C.int;
 374       pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR");
 375    begin
 376       if Af /= SOSC.AF_INET then
 377          Set_Socket_Errno (SOSC.EAFNOSUPPORT);
 378          return -1;
 379       end if;
 380
 381       if Cp = Null_Ptr or else Inp = Null_Address then
 382          return 0;
 383       end if;
 384
 385       --  Special case for the all-ones broadcast address: this address has the
 386       --  same in_addr_t value as Failure, and thus cannot be properly returned
 387       --  by inet_addr(3).
 388
 389       if String'(Value (Cp)) = "255.255.255.255" then
 390          Conv.To_Pointer (Inp).all := -1;
 391          return 1;
 392       end if;
 393
 394       Res := C_Inet_Addr (Cp);
 395
 396       --  String is not a valid dotted quad
 397
 398       if Res = -1 then
 399          return 0;
 400       end if;
 401
 402       --  Success
 403
 404       Conv.To_Pointer (Inp).all := Res;
 405       return 1;
 406    end Inet_Pton;
 407
 408    ----------------
 409    -- Initialize --
 410    ----------------
 411
 412    procedure Initialize is
 413    begin
 414       Reset_Socket_Set (Non_Blocking_Sockets'Access);
 415    end Initialize;
 416
 417    -------------------------
 418    -- Non_Blocking_Socket --
 419    -------------------------
 420
 421    function Non_Blocking_Socket (S : C.int) return Boolean is
 422       R : Boolean;
 423    begin
 424       Task_Lock.Lock;
 425       R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
 426       Task_Lock.Unlock;
 427       return R;
 428    end Non_Blocking_Socket;
 429
 430    -----------------------------
 431    -- Set_Non_Blocking_Socket --
 432    -----------------------------
 433
 434    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 435    begin
 436       Task_Lock.Lock;
 437
 438       if V then
 439          Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
 440       else
 441          Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
 442       end if;
 443
 444       Task_Lock.Unlock;
 445    end Set_Non_Blocking_Socket;
 446
 447    --------------------
 448    -- Signalling_Fds --
 449    --------------------
 450
 451    package body Signalling_Fds is separate;
 452
 453    --------------------------
 454    -- Socket_Error_Message --
 455    --------------------------
 456
 457    function Socket_Error_Message
 458      (Errno : Integer) return C.Strings.chars_ptr
 459    is
 460       use type Interfaces.C.Strings.chars_ptr;
 461
 462       C_Msg : C.Strings.chars_ptr;
 463
 464    begin
 465       C_Msg := C_Strerror (C.int (Errno));
 466
 467       if C_Msg = C.Strings.Null_Ptr then
 468          return Unknown_System_Error;
 469       else
 470          return C_Msg;
 471       end if;
 472    end Socket_Error_Message;
 473
 474    -------------
 475    -- C_Readv --
 476    -------------
 477
 478    function C_Readv
 479      (Fd     : C.int;
 480       Iov    : System.Address;
 481       Iovcnt : C.int) return C.int
 482    is
 483       Res : C.int;
 484       Count : C.int := 0;
 485
 486       Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
 487       for Iovec'Address use Iov;
 488       pragma Import (Ada, Iovec);
 489
 490    begin
 491       for J in Iovec'Range loop
 492          Res := C_Recv
 493            (Fd,
 494             Iovec (J).Base.all'Address,
 495             Interfaces.C.int (Iovec (J).Length),
 496             0);
 497
 498          if Res < 0 then
 499             return Res;
 500          else
 501             Count := Count + Res;
 502          end if;
 503       end loop;
 504       return Count;
 505    end C_Readv;
 506
 507    --------------
 508    -- C_Writev --
 509    --------------
 510
 511    function C_Writev
 512      (Fd     : C.int;
 513       Iov    : System.Address;
 514       Iovcnt : C.int) return C.int
 515    is
 516       Res : C.int;
 517       Count : C.int := 0;
 518
 519       Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
 520       for Iovec'Address use Iov;
 521       pragma Import (Ada, Iovec);
 522
 523    begin
 524       for J in Iovec'Range loop
 525          Res := C_Sendto
 526            (Fd,
 527             Iovec (J).Base.all'Address,
 528             Interfaces.C.int (Iovec (J).Length),
 529             SOSC.MSG_Forced_Flags,
 530             To    => null,
 531             Tolen => 0);
 532
 533          if Res < 0 then
 534             return Res;
 535          else
 536             Count := Count + Res;
 537          end if;
 538       end loop;
 539       return Count;
 540    end C_Writev;
 541
 542 end GNAT.Sockets.Thin;