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