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