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