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