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 --                            $Revision: 1.5 $
  10 --                                                                          --
  11 --              Copyright (C) 2001 Ada Core Technologies, Inc.              --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with GNAT.OS_Lib; use GNAT.OS_Lib;
  36
  37 with Interfaces.C; use Interfaces.C;
  38
  39 package body GNAT.Sockets.Thin is
  40
  41    --  When this package is initialized with Process_Blocking_IO set
  42    --  to True, sockets are set in non-blocking mode to avoid blocking
  43    --  the whole process when a thread wants to perform a blocking IO
  44    --  operation. But the user can set a socket in non-blocking mode
  45    --  by purpose. We track the socket in such a mode by redefining
  46    --  C_Ioctl. In blocking IO operations, we exit normally when the
  47    --  non-blocking flag is set by user, we poll and try later when
  48    --  this flag is set automatically by this package.
  49
  50    type Socket_Info is record
  51       Non_Blocking : Boolean := False;
  52    end record;
  53
  54    Table : array (C.int range 0 .. 31) of Socket_Info;
  55    --  Get info on blocking flag. This array is limited to 32 sockets
  56    --  because the select operation allows socket set of less then 32
  57    --  sockets.
  58
  59    Quantum : constant Duration := 0.2;
  60    --  comment needed ???
  61
  62    Thread_Blocking_IO : Boolean := True;
  63
  64    function Syscall_Accept
  65      (S       : C.int;
  66       Addr    : System.Address;
  67       Addrlen : access C.int)
  68       return    C.int;
  69    pragma Import (C, Syscall_Accept, "accept");
  70
  71    function Syscall_Connect
  72      (S       : C.int;
  73       Name    : System.Address;
  74       Namelen : C.int)
  75       return    C.int;
  76    pragma Import (C, Syscall_Connect, "connect");
  77
  78    function Syscall_Ioctl
  79      (S    : C.int;
  80       Req  : C.int;
  81       Arg  : Int_Access)
  82       return C.int;
  83    pragma Import (C, Syscall_Ioctl, "ioctl");
  84
  85    function Syscall_Recv
  86      (S     : C.int;
  87       Msg   : System.Address;
  88       Len   : C.int;
  89       Flags : C.int)
  90       return  C.int;
  91    pragma Import (C, Syscall_Recv, "recv");
  92
  93    function Syscall_Recvfrom
  94      (S       : C.int;
  95       Msg     : System.Address;
  96       Len     : C.int;
  97       Flags   : C.int;
  98       From    : Sockaddr_In_Access;
  99       Fromlen : access C.int)
 100       return    C.int;
 101    pragma Import (C, Syscall_Recvfrom, "recvfrom");
 102
 103    function Syscall_Send
 104      (S     : C.int;
 105       Msg   : System.Address;
 106       Len   : C.int;
 107       Flags : C.int)
 108       return  C.int;
 109    pragma Import (C, Syscall_Send, "send");
 110
 111    function Syscall_Sendto
 112      (S     : C.int;
 113       Msg   : System.Address;
 114       Len   : C.int;
 115       Flags : C.int;
 116       To    : Sockaddr_In_Access;
 117       Tolen : C.int)
 118       return  C.int;
 119    pragma Import (C, Syscall_Sendto, "sendto");
 120
 121    function Syscall_Socket
 122      (Domain, Typ, Protocol : C.int)
 123       return C.int;
 124    pragma Import (C, Syscall_Socket, "socket");
 125
 126    procedure Set_Non_Blocking (S : C.int);
 127
 128    --------------
 129    -- C_Accept --
 130    --------------
 131
 132    function C_Accept
 133      (S       : C.int;
 134       Addr    : System.Address;
 135       Addrlen : access C.int)
 136       return    C.int
 137    is
 138       Res : C.int;
 139
 140    begin
 141       loop
 142          Res := Syscall_Accept (S, Addr, Addrlen);
 143          exit when Thread_Blocking_IO
 144            or else Res /= Failure
 145            or else Table (S).Non_Blocking
 146            or else Errno /= Constants.EWOULDBLOCK;
 147          delay Quantum;
 148       end loop;
 149
 150       if not Thread_Blocking_IO
 151         and then Res /= Failure
 152       then
 153          --  A socket inherits the properties ot its server especially
 154          --  the FNDELAY flag.
 155
 156          Table (Res).Non_Blocking := Table (S).Non_Blocking;
 157          Set_Non_Blocking (Res);
 158       end if;
 159
 160       return Res;
 161    end C_Accept;
 162
 163    ---------------
 164    -- C_Connect --
 165    ---------------
 166
 167    function C_Connect
 168      (S       : C.int;
 169       Name    : System.Address;
 170       Namelen : C.int)
 171       return    C.int
 172    is
 173       Res : C.int;
 174
 175    begin
 176       Res := Syscall_Connect (S, Name, Namelen);
 177
 178       if Thread_Blocking_IO
 179         or else Res /= Failure
 180         or else Table (S).Non_Blocking
 181         or else Errno /= Constants.EINPROGRESS
 182       then
 183          return Res;
 184       end if;
 185
 186       declare
 187          Set : aliased Fd_Set;
 188          Now : aliased Timeval;
 189
 190       begin
 191          loop
 192             Set := 2 ** Natural (S);
 193             Now := Immediat;
 194             Res := C_Select
 195               (S + 1,
 196                null, Set'Unchecked_Access,
 197                null, Now'Unchecked_Access);
 198
 199             exit when Res > 0;
 200
 201             if Res = Failure then
 202                return Res;
 203             end if;
 204
 205             delay Quantum;
 206          end loop;
 207       end;
 208
 209       Res := Syscall_Connect (S, Name, Namelen);
 210
 211       if Res = Failure
 212         and then Errno = Constants.EISCONN
 213       then
 214          return Thin.Success;
 215       else
 216          return Res;
 217       end if;
 218    end C_Connect;
 219
 220    -------------
 221    -- C_Ioctl --
 222    -------------
 223
 224    function C_Ioctl
 225      (S    : C.int;
 226       Req  : C.int;
 227       Arg  : Int_Access)
 228       return C.int
 229    is
 230    begin
 231       if not Thread_Blocking_IO
 232         and then Req = Constants.FIONBIO
 233       then
 234          Table (S).Non_Blocking := (Arg.all /= 0);
 235       end if;
 236
 237       return Syscall_Ioctl (S, Req, Arg);
 238    end C_Ioctl;
 239
 240    ------------
 241    -- C_Recv --
 242    ------------
 243
 244    function C_Recv
 245      (S     : C.int;
 246       Msg   : System.Address;
 247       Len   : C.int;
 248       Flags : C.int)
 249       return  C.int
 250    is
 251       Res : C.int;
 252
 253    begin
 254       loop
 255          Res := Syscall_Recv (S, Msg, Len, Flags);
 256          exit when Thread_Blocking_IO
 257            or else Res /= Failure
 258            or else Table (S).Non_Blocking
 259            or else Errno /= Constants.EWOULDBLOCK;
 260          delay Quantum;
 261       end loop;
 262
 263       return Res;
 264    end C_Recv;
 265
 266    ----------------
 267    -- C_Recvfrom --
 268    ----------------
 269
 270    function C_Recvfrom
 271      (S       : C.int;
 272       Msg     : System.Address;
 273       Len     : C.int;
 274       Flags   : C.int;
 275       From    : Sockaddr_In_Access;
 276       Fromlen : access C.int)
 277       return    C.int
 278    is
 279       Res : C.int;
 280
 281    begin
 282       loop
 283          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 284          exit when Thread_Blocking_IO
 285            or else Res /= Failure
 286            or else Table (S).Non_Blocking
 287            or else Errno /= Constants.EWOULDBLOCK;
 288          delay Quantum;
 289       end loop;
 290
 291       return Res;
 292    end C_Recvfrom;
 293
 294    ------------
 295    -- C_Send --
 296    ------------
 297
 298    function C_Send
 299      (S     : C.int;
 300       Msg   : System.Address;
 301       Len   : C.int;
 302       Flags : C.int)
 303       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 Table (S).Non_Blocking
 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)
 331       return  C.int
 332    is
 333       Res : C.int;
 334
 335    begin
 336       loop
 337          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 338          exit when Thread_Blocking_IO
 339            or else Res /= Failure
 340            or else Table (S).Non_Blocking
 341            or else Errno /= Constants.EWOULDBLOCK;
 342          delay Quantum;
 343       end loop;
 344
 345       return Res;
 346    end C_Sendto;
 347
 348    --------------
 349    -- C_Socket --
 350    --------------
 351
 352    function C_Socket
 353      (Domain   : C.int;
 354       Typ      : C.int;
 355       Protocol : C.int)
 356       return     C.int
 357    is
 358       Res : C.int;
 359
 360    begin
 361       Res := Syscall_Socket (Domain, Typ, Protocol);
 362
 363       if not Thread_Blocking_IO
 364         and then Res /= Failure
 365       then
 366          Set_Non_Blocking (Res);
 367       end if;
 368
 369       return Res;
 370    end C_Socket;
 371
 372    -----------
 373    -- Clear --
 374    -----------
 375
 376    procedure Clear
 377      (Item   : in out Fd_Set;
 378       Socket : in C.int)
 379    is
 380       Mask : constant Fd_Set := 2 ** Natural (Socket);
 381
 382    begin
 383       if (Item and Mask) /= 0 then
 384          Item := Item xor Mask;
 385       end if;
 386    end Clear;
 387
 388    -----------
 389    -- Empty --
 390    -----------
 391
 392    procedure Empty  (Item : in out Fd_Set) is
 393    begin
 394       Item := 0;
 395    end Empty;
 396
 397    --------------
 398    -- Finalize --
 399    --------------
 400
 401    procedure Finalize is
 402    begin
 403       null;
 404    end Finalize;
 405
 406    ----------------
 407    -- Initialize --
 408    ----------------
 409
 410    procedure Initialize (Process_Blocking_IO : Boolean) is
 411    begin
 412       Thread_Blocking_IO := not Process_Blocking_IO;
 413    end Initialize;
 414
 415    --------------
 416    -- Is_Empty --
 417    --------------
 418
 419    function Is_Empty (Item : Fd_Set) return Boolean is
 420    begin
 421       return Item = 0;
 422    end Is_Empty;
 423
 424    ------------
 425    -- Is_Set --
 426    ------------
 427
 428    function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
 429    begin
 430       return (Item and 2 ** Natural (Socket)) /= 0;
 431    end Is_Set;
 432
 433    ---------
 434    -- Max --
 435    ---------
 436
 437    function Max (Item : Fd_Set) return C.int
 438    is
 439       L : C.int  := -1;
 440       C : Fd_Set := Item;
 441
 442    begin
 443       while C /= 0 loop
 444          L := L + 1;
 445          C := C / 2;
 446       end loop;
 447       return L;
 448    end Max;
 449
 450    ---------
 451    -- Set --
 452    ---------
 453
 454    procedure Set (Item : in out Fd_Set; Socket : in C.int) is
 455    begin
 456       Item := Item or 2 ** Natural (Socket);
 457    end Set;
 458
 459    ----------------------
 460    -- Set_Non_Blocking --
 461    ----------------------
 462
 463    procedure Set_Non_Blocking (S : C.int) is
 464       Res : C.int;
 465       Val : aliased C.int := 1;
 466
 467    begin
 468
 469       --  Do not use C_Fcntl because this subprogram tracks the
 470       --  sockets set by user in non-blocking mode.
 471
 472       Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
 473    end Set_Non_Blocking;
 474
 475    --------------------------
 476    -- Socket_Error_Message --
 477    --------------------------
 478
 479    function Socket_Error_Message (Errno : Integer) return String is
 480       use type Interfaces.C.Strings.chars_ptr;
 481
 482       C_Msg : C.Strings.chars_ptr;
 483
 484    begin
 485       C_Msg := C_Strerror (C.int (Errno));
 486
 487       if C_Msg = C.Strings.Null_Ptr then
 488          return "Unknown system error";
 489
 490       else
 491          return C.Strings.Value (C_Msg);
 492       end if;
 493    end Socket_Error_Message;
 494
 495 end GNAT.Sockets.Thin;