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 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  30 --                                                                          --
  31 ------------------------------------------------------------------------------
  32
  33 with GNAT.OS_Lib; use GNAT.OS_Lib;
  34
  35 with Interfaces.C; use Interfaces.C;
  36
  37 package body GNAT.Sockets.Thin is
  38
  39    --  When this package is initialized with Process_Blocking_IO set
  40    --  to True, sockets are set in non-blocking mode to avoid blocking
  41    --  the whole process when a thread wants to perform a blocking IO
  42    --  operation. But the user can set a socket in non-blocking mode
  43    --  by purpose. We track the socket in such a mode by redefining
  44    --  C_Ioctl. In blocking IO operations, we exit normally when the
  45    --  non-blocking flag is set by user, we poll and try later when
  46    --  this flag is set automatically by this package.
  47
  48    type Socket_Info is record
  49       Non_Blocking : Boolean := False;
  50    end record;
  51
  52    Table : array (C.int range 0 .. 31) of Socket_Info;
  53    --  Get info on blocking flag. This array is limited to 32 sockets
  54    --  because the select operation allows socket set of less then 32
  55    --  sockets.
  56
  57    Quantum : constant Duration := 0.2;
  58    --  comment needed ???
  59
  60    Thread_Blocking_IO : Boolean := True;
  61
  62    function Syscall_Accept
  63      (S       : C.int;
  64       Addr    : System.Address;
  65       Addrlen : access C.int)
  66       return    C.int;
  67    pragma Import (C, Syscall_Accept, "accept");
  68
  69    function Syscall_Connect
  70      (S       : C.int;
  71       Name    : System.Address;
  72       Namelen : C.int)
  73       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)
  80       return C.int;
  81    pragma Import (C, Syscall_Ioctl, "ioctl");
  82
  83    function Syscall_Recv
  84      (S     : C.int;
  85       Msg   : System.Address;
  86       Len   : C.int;
  87       Flags : C.int)
  88       return  C.int;
  89    pragma Import (C, Syscall_Recv, "recv");
  90
  91    function Syscall_Recvfrom
  92      (S       : C.int;
  93       Msg     : System.Address;
  94       Len     : C.int;
  95       Flags   : C.int;
  96       From    : Sockaddr_In_Access;
  97       Fromlen : access C.int)
  98       return    C.int;
  99    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 100
 101    function Syscall_Send
 102      (S     : C.int;
 103       Msg   : System.Address;
 104       Len   : C.int;
 105       Flags : C.int)
 106       return  C.int;
 107    pragma Import (C, Syscall_Send, "send");
 108
 109    function Syscall_Sendto
 110      (S     : C.int;
 111       Msg   : System.Address;
 112       Len   : C.int;
 113       Flags : C.int;
 114       To    : Sockaddr_In_Access;
 115       Tolen : C.int)
 116       return  C.int;
 117    pragma Import (C, Syscall_Sendto, "sendto");
 118
 119    function Syscall_Socket
 120      (Domain, Typ, Protocol : C.int)
 121       return C.int;
 122    pragma Import (C, Syscall_Socket, "socket");
 123
 124    procedure Set_Non_Blocking (S : C.int);
 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       Res : C.int;
 137
 138    begin
 139       loop
 140          Res := Syscall_Accept (S, Addr, Addrlen);
 141          exit when Thread_Blocking_IO
 142            or else Res /= Failure
 143            or else Table (S).Non_Blocking
 144            or else Errno /= Constants.EWOULDBLOCK;
 145          delay Quantum;
 146       end loop;
 147
 148       if not Thread_Blocking_IO
 149         and then Res /= Failure
 150       then
 151          --  A socket inherits the properties ot its server especially
 152          --  the FNDELAY flag.
 153
 154          Table (Res).Non_Blocking := Table (S).Non_Blocking;
 155          Set_Non_Blocking (Res);
 156       end if;
 157
 158       return Res;
 159    end C_Accept;
 160
 161    ---------------
 162    -- C_Connect --
 163    ---------------
 164
 165    function C_Connect
 166      (S       : C.int;
 167       Name    : System.Address;
 168       Namelen : C.int)
 169       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 Table (S).Non_Blocking
 179         or else Errno /= Constants.EINPROGRESS
 180       then
 181          return Res;
 182       end if;
 183
 184       declare
 185          Set : aliased Fd_Set;
 186          Now : aliased Timeval;
 187
 188       begin
 189          loop
 190             Set := 2 ** Natural (S);
 191             Now := Immediat;
 192             Res := C_Select
 193               (S + 1,
 194                null, Set'Unchecked_Access,
 195                null, Now'Unchecked_Access);
 196
 197             exit when Res > 0;
 198
 199             if Res = Failure then
 200                return Res;
 201             end if;
 202
 203             delay Quantum;
 204          end loop;
 205       end;
 206
 207       Res := Syscall_Connect (S, Name, Namelen);
 208
 209       if Res = Failure
 210         and then Errno = Constants.EISCONN
 211       then
 212          return Thin.Success;
 213       else
 214          return Res;
 215       end if;
 216    end C_Connect;
 217
 218    -------------
 219    -- C_Ioctl --
 220    -------------
 221
 222    function C_Ioctl
 223      (S    : C.int;
 224       Req  : C.int;
 225       Arg  : Int_Access)
 226       return C.int
 227    is
 228    begin
 229       if not Thread_Blocking_IO
 230         and then Req = Constants.FIONBIO
 231       then
 232          Table (S).Non_Blocking := (Arg.all /= 0);
 233       end if;
 234
 235       return Syscall_Ioctl (S, Req, Arg);
 236    end C_Ioctl;
 237
 238    ------------
 239    -- C_Recv --
 240    ------------
 241
 242    function C_Recv
 243      (S     : C.int;
 244       Msg   : System.Address;
 245       Len   : C.int;
 246       Flags : C.int)
 247       return  C.int
 248    is
 249       Res : C.int;
 250
 251    begin
 252       loop
 253          Res := Syscall_Recv (S, Msg, Len, Flags);
 254          exit when Thread_Blocking_IO
 255            or else Res /= Failure
 256            or else Table (S).Non_Blocking
 257            or else Errno /= Constants.EWOULDBLOCK;
 258          delay Quantum;
 259       end loop;
 260
 261       return Res;
 262    end C_Recv;
 263
 264    ----------------
 265    -- C_Recvfrom --
 266    ----------------
 267
 268    function C_Recvfrom
 269      (S       : C.int;
 270       Msg     : System.Address;
 271       Len     : C.int;
 272       Flags   : C.int;
 273       From    : Sockaddr_In_Access;
 274       Fromlen : access C.int)
 275       return    C.int
 276    is
 277       Res : C.int;
 278
 279    begin
 280       loop
 281          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 282          exit when Thread_Blocking_IO
 283            or else Res /= Failure
 284            or else Table (S).Non_Blocking
 285            or else Errno /= Constants.EWOULDBLOCK;
 286          delay Quantum;
 287       end loop;
 288
 289       return Res;
 290    end C_Recvfrom;
 291
 292    ------------
 293    -- C_Send --
 294    ------------
 295
 296    function C_Send
 297      (S     : C.int;
 298       Msg   : System.Address;
 299       Len   : C.int;
 300       Flags : C.int)
 301       return  C.int
 302    is
 303       Res : C.int;
 304
 305    begin
 306       loop
 307          Res := Syscall_Send (S, Msg, Len, Flags);
 308          exit when Thread_Blocking_IO
 309            or else Res /= Failure
 310            or else Table (S).Non_Blocking
 311            or else Errno /= Constants.EWOULDBLOCK;
 312          delay Quantum;
 313       end loop;
 314
 315       return Res;
 316    end C_Send;
 317
 318    --------------
 319    -- C_Sendto --
 320    --------------
 321
 322    function C_Sendto
 323      (S     : C.int;
 324       Msg   : System.Address;
 325       Len   : C.int;
 326       Flags : C.int;
 327       To    : Sockaddr_In_Access;
 328       Tolen : C.int)
 329       return  C.int
 330    is
 331       Res : C.int;
 332
 333    begin
 334       loop
 335          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 336          exit when Thread_Blocking_IO
 337            or else Res /= Failure
 338            or else Table (S).Non_Blocking
 339            or else Errno /= Constants.EWOULDBLOCK;
 340          delay Quantum;
 341       end loop;
 342
 343       return Res;
 344    end C_Sendto;
 345
 346    --------------
 347    -- C_Socket --
 348    --------------
 349
 350    function C_Socket
 351      (Domain   : C.int;
 352       Typ      : C.int;
 353       Protocol : C.int)
 354       return     C.int
 355    is
 356       Res : C.int;
 357
 358    begin
 359       Res := Syscall_Socket (Domain, Typ, Protocol);
 360
 361       if not Thread_Blocking_IO
 362         and then Res /= Failure
 363       then
 364          Set_Non_Blocking (Res);
 365       end if;
 366
 367       return Res;
 368    end C_Socket;
 369
 370    -----------
 371    -- Clear --
 372    -----------
 373
 374    procedure Clear
 375      (Item   : in out Fd_Set;
 376       Socket : in C.int)
 377    is
 378       Mask : constant Fd_Set := 2 ** Natural (Socket);
 379
 380    begin
 381       if (Item and Mask) /= 0 then
 382          Item := Item xor Mask;
 383       end if;
 384    end Clear;
 385
 386    -----------
 387    -- Empty --
 388    -----------
 389
 390    procedure Empty  (Item : in out Fd_Set) is
 391    begin
 392       Item := 0;
 393    end Empty;
 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    -- Is_Empty --
 415    --------------
 416
 417    function Is_Empty (Item : Fd_Set) return Boolean is
 418    begin
 419       return Item = 0;
 420    end Is_Empty;
 421
 422    ------------
 423    -- Is_Set --
 424    ------------
 425
 426    function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
 427    begin
 428       return (Item and 2 ** Natural (Socket)) /= 0;
 429    end Is_Set;
 430
 431    ---------
 432    -- Max --
 433    ---------
 434
 435    function Max (Item : Fd_Set) return C.int
 436    is
 437       L : C.int  := -1;
 438       C : Fd_Set := Item;
 439
 440    begin
 441       while C /= 0 loop
 442          L := L + 1;
 443          C := C / 2;
 444       end loop;
 445       return L;
 446    end Max;
 447
 448    ---------
 449    -- Set --
 450    ---------
 451
 452    procedure Set (Item : in out Fd_Set; Socket : in C.int) is
 453    begin
 454       Item := Item or 2 ** Natural (Socket);
 455    end Set;
 456
 457    ----------------------
 458    -- Set_Non_Blocking --
 459    ----------------------
 460
 461    procedure Set_Non_Blocking (S : C.int) is
 462       Res : C.int;
 463       Val : aliased C.int := 1;
 464
 465    begin
 466
 467       --  Do not use C_Fcntl because this subprogram tracks the
 468       --  sockets set by user in non-blocking mode.
 469
 470       Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
 471    end Set_Non_Blocking;
 472
 473    --------------------------
 474    -- Socket_Error_Message --
 475    --------------------------
 476
 477    function Socket_Error_Message (Errno : Integer) return String is
 478       use type Interfaces.C.Strings.chars_ptr;
 479
 480       C_Msg : C.Strings.chars_ptr;
 481
 482    begin
 483       C_Msg := C_Strerror (C.int (Errno));
 484
 485       if C_Msg = C.Strings.Null_Ptr then
 486          return "Unknown system error";
 487
 488       else
 489          return C.Strings.Value (C_Msg);
 490       end if;
 491    end Socket_Error_Message;
 492
 493 end GNAT.Sockets.Thin;