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