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