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