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-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 --  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    --  Comment required for this ???
  65
  66    Unknown_System_Error : constant C.Strings.chars_ptr :=
  67                             C.Strings.New_String ("Unknown system error");
  68
  69    --  Comments required for following functions ???
  70
  71    function Syscall_Accept
  72      (S       : C.int;
  73       Addr    : System.Address;
  74       Addrlen : access C.int) return C.int;
  75    pragma Import (C, Syscall_Accept, "accept");
  76
  77    function Syscall_Connect
  78      (S       : C.int;
  79       Name    : System.Address;
  80       Namelen : C.int) return C.int;
  81    pragma Import (C, Syscall_Connect, "connect");
  82
  83    function Syscall_Ioctl
  84      (S    : C.int;
  85       Req  : C.int;
  86       Arg  : Int_Access) return C.int;
  87    pragma Import (C, Syscall_Ioctl, "ioctl");
  88
  89    function Syscall_Recv
  90      (S     : C.int;
  91       Msg   : System.Address;
  92       Len   : C.int;
  93       Flags : C.int) return C.int;
  94    pragma Import (C, Syscall_Recv, "recv");
  95
  96    function Syscall_Recvfrom
  97      (S       : C.int;
  98       Msg     : System.Address;
  99       Len     : C.int;
 100       Flags   : C.int;
 101       From    : Sockaddr_In_Access;
 102       Fromlen : access C.int) return C.int;
 103    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 104
 105    function Syscall_Send
 106      (S     : C.int;
 107       Msg   : System.Address;
 108       Len   : C.int;
 109       Flags : C.int) 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) return C.int;
 119    pragma Import (C, Syscall_Sendto, "sendto");
 120
 121    function Syscall_Socket
 122      (Domain   : C.int;
 123       Typ      : C.int;
 124       Protocol : C.int) return C.int;
 125    pragma Import (C, Syscall_Socket, "socket");
 126
 127    procedure Disable_SIGPIPE (S : C.int);
 128    pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
 129
 130    function  Non_Blocking_Socket (S : C.int) return Boolean;
 131    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 132
 133    --------------
 134    -- C_Accept --
 135    --------------
 136
 137    function C_Accept
 138      (S       : C.int;
 139       Addr    : System.Address;
 140       Addrlen : access C.int) return C.int
 141    is
 142       R   : C.int;
 143       Val : aliased C.int := 1;
 144
 145       Discard : C.int;
 146       pragma Warnings (Off, Discard);
 147
 148    begin
 149       loop
 150          R := Syscall_Accept (S, Addr, Addrlen);
 151          exit when Thread_Blocking_IO
 152            or else R /= Failure
 153            or else Non_Blocking_Socket (S)
 154            or else Errno /= Constants.EWOULDBLOCK;
 155          delay Quantum;
 156       end loop;
 157
 158       if not Thread_Blocking_IO
 159         and then R /= Failure
 160       then
 161          --  A socket inherits the properties ot its server especially
 162          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 163          --  tracks sockets set in non-blocking mode by user.
 164
 165          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 166          Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 167       end if;
 168
 169       Disable_SIGPIPE (R);
 170       return R;
 171    end C_Accept;
 172
 173    ---------------
 174    -- C_Connect --
 175    ---------------
 176
 177    function C_Connect
 178      (S       : C.int;
 179       Name    : System.Address;
 180       Namelen : C.int) return C.int
 181    is
 182       Res : C.int;
 183
 184    begin
 185       Res := Syscall_Connect (S, Name, Namelen);
 186
 187       if Thread_Blocking_IO
 188         or else Res /= Failure
 189         or else Non_Blocking_Socket (S)
 190         or else Errno /= Constants.EINPROGRESS
 191       then
 192          return Res;
 193       end if;
 194
 195       declare
 196          WSet : Fd_Set_Access;
 197          Now  : aliased Timeval;
 198
 199       begin
 200          WSet := New_Socket_Set (No_Socket_Set);
 201          loop
 202             Insert_Socket_In_Set (WSet, S);
 203             Now := Immediat;
 204             Res := C_Select
 205               (S + 1,
 206                No_Fd_Set,
 207                WSet,
 208                No_Fd_Set,
 209                Now'Unchecked_Access);
 210
 211             exit when Res > 0;
 212
 213             if Res = Failure then
 214                Free_Socket_Set (WSet);
 215                return Res;
 216             end if;
 217
 218             delay Quantum;
 219          end loop;
 220
 221          Free_Socket_Set (WSet);
 222       end;
 223
 224       Res := Syscall_Connect (S, Name, Namelen);
 225
 226       if Res = Failure
 227         and then Errno = Constants.EISCONN
 228       then
 229          return Thin.Success;
 230       else
 231          return Res;
 232       end if;
 233    end C_Connect;
 234
 235    -------------
 236    -- C_Ioctl --
 237    -------------
 238
 239    function C_Ioctl
 240      (S   : C.int;
 241       Req : C.int;
 242       Arg : Int_Access) return C.int
 243    is
 244    begin
 245       if not Thread_Blocking_IO
 246         and then Req = Constants.FIONBIO
 247       then
 248          if Arg.all /= 0 then
 249             Set_Non_Blocking_Socket (S, True);
 250          end if;
 251       end if;
 252
 253       return Syscall_Ioctl (S, Req, Arg);
 254    end C_Ioctl;
 255
 256    ------------
 257    -- C_Recv --
 258    ------------
 259
 260    function C_Recv
 261      (S     : C.int;
 262       Msg   : System.Address;
 263       Len   : C.int;
 264       Flags : C.int) 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) return C.int
 292    is
 293       Res : C.int;
 294
 295    begin
 296       loop
 297          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 298          exit when Thread_Blocking_IO
 299            or else Res /= Failure
 300            or else Non_Blocking_Socket (S)
 301            or else Errno /= Constants.EWOULDBLOCK;
 302          delay Quantum;
 303       end loop;
 304
 305       return Res;
 306    end C_Recvfrom;
 307
 308    ------------
 309    -- C_Send --
 310    ------------
 311
 312    function C_Send
 313      (S     : C.int;
 314       Msg   : System.Address;
 315       Len   : C.int;
 316       Flags : C.int) return C.int
 317    is
 318       Res : C.int;
 319
 320    begin
 321       loop
 322          Res := Syscall_Send (S, Msg, Len, Flags);
 323          exit when Thread_Blocking_IO
 324            or else Res /= Failure
 325            or else Non_Blocking_Socket (S)
 326            or else Errno /= Constants.EWOULDBLOCK;
 327          delay Quantum;
 328       end loop;
 329
 330       return Res;
 331    end C_Send;
 332
 333    --------------
 334    -- C_Sendto --
 335    --------------
 336
 337    function C_Sendto
 338      (S     : C.int;
 339       Msg   : System.Address;
 340       Len   : C.int;
 341       Flags : C.int;
 342       To    : Sockaddr_In_Access;
 343       Tolen : C.int) return C.int
 344    is
 345       Res : C.int;
 346
 347    begin
 348       loop
 349          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 350          exit when Thread_Blocking_IO
 351            or else Res /= Failure
 352            or else Non_Blocking_Socket (S)
 353            or else Errno /= Constants.EWOULDBLOCK;
 354          delay Quantum;
 355       end loop;
 356
 357       return Res;
 358    end C_Sendto;
 359
 360    --------------
 361    -- C_Socket --
 362    --------------
 363
 364    function C_Socket
 365      (Domain   : C.int;
 366       Typ      : C.int;
 367       Protocol : C.int) 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       Disable_SIGPIPE (R);
 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    begin
 416       Task_Lock.Lock;
 417       R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
 418       Task_Lock.Unlock;
 419       return R;
 420    end Non_Blocking_Socket;
 421
 422    -----------------
 423    -- Set_Address --
 424    -----------------
 425
 426    procedure Set_Address
 427      (Sin     : Sockaddr_In_Access;
 428       Address : In_Addr)
 429    is
 430    begin
 431       Sin.Sin_Addr := Address;
 432    end Set_Address;
 433
 434    ----------------
 435    -- Set_Family --
 436    ----------------
 437
 438    procedure Set_Family
 439      (Sin    : Sockaddr_In_Access;
 440       Family : C.int)
 441    is
 442    begin
 443       Sin.Sin_Family := C.unsigned_short (Family);
 444    end Set_Family;
 445
 446    ----------------
 447    -- Set_Length --
 448    ----------------
 449
 450    procedure Set_Length
 451      (Sin : Sockaddr_In_Access;
 452       Len : C.int)
 453    is
 454       pragma Unreferenced (Sin);
 455       pragma Unreferenced (Len);
 456
 457    begin
 458       null;
 459    end Set_Length;
 460
 461    -----------------------------
 462    -- Set_Non_Blocking_Socket --
 463    -----------------------------
 464
 465    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 466    begin
 467       Task_Lock.Lock;
 468
 469       if V then
 470          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 471       else
 472          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 473       end if;
 474
 475       Task_Lock.Unlock;
 476    end Set_Non_Blocking_Socket;
 477
 478    --------------
 479    -- Set_Port --
 480    --------------
 481
 482    procedure Set_Port
 483      (Sin  : Sockaddr_In_Access;
 484       Port : C.unsigned_short)
 485    is
 486    begin
 487       Sin.Sin_Port   := Port;
 488    end Set_Port;
 489
 490    --------------------------
 491    -- Socket_Error_Message --
 492    --------------------------
 493
 494    function Socket_Error_Message
 495      (Errno : Integer) return C.Strings.chars_ptr
 496    is
 497       use type Interfaces.C.Strings.chars_ptr;
 498
 499       C_Msg : C.Strings.chars_ptr;
 500
 501    begin
 502       C_Msg := C_Strerror (C.int (Errno));
 503
 504       if C_Msg = C.Strings.Null_Ptr then
 505          return Unknown_System_Error;
 506
 507       else
 508          return C_Msg;
 509       end if;
 510    end Socket_Error_Message;
 511
 512 end GNAT.Sockets.Thin;