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-2008, AdaCore                     --
  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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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.Sockets.Constants;
  42 with GNAT.Task_Lock;
  43
  44 with Interfaces.C; use Interfaces.C;
  45
  46 package body GNAT.Sockets.Thin is
  47
  48    Non_Blocking_Sockets : constant Fd_Set_Access :=
  49                             New_Socket_Set (No_Fd_Set_Access);
  50    --  When this package is initialized with Process_Blocking_IO set
  51    --  to True, sockets are set in non-blocking mode to avoid blocking
  52    --  the whole process when a thread wants to perform a blocking IO
  53    --  operation. But the user can also set a socket in non-blocking
  54    --  mode by purpose. In order to make a difference between these
  55    --  two situations, we track the origin of non-blocking mode in
  56    --  Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
  57    --  been set in non-blocking mode by the user.
  58
  59    Quantum : constant Duration := 0.2;
  60    --  When Constants.Thread_Blocking_IO is False, we set sockets in
  61    --  non-blocking mode and we spend a period of time Quantum between
  62    --  two attempts on a blocking operation.
  63
  64    Unknown_System_Error : constant C.Strings.chars_ptr :=
  65                             C.Strings.New_String ("Unknown system error");
  66
  67    --  Comments required for following functions ???
  68
  69    function Syscall_Accept
  70      (S       : C.int;
  71       Addr    : System.Address;
  72       Addrlen : not null access C.int) return C.int;
  73    pragma Import (C, Syscall_Accept, "accept");
  74
  75    function Syscall_Connect
  76      (S       : C.int;
  77       Name    : System.Address;
  78       Namelen : C.int) return C.int;
  79    pragma Import (C, Syscall_Connect, "connect");
  80
  81    function Syscall_Ioctl
  82      (S    : C.int;
  83       Req  : C.int;
  84       Arg  : Int_Access) return C.int;
  85    pragma Import (C, Syscall_Ioctl, "ioctl");
  86
  87    function Syscall_Recv
  88      (S     : C.int;
  89       Msg   : System.Address;
  90       Len   : C.int;
  91       Flags : C.int) return C.int;
  92    pragma Import (C, Syscall_Recv, "recv");
  93
  94    function Syscall_Recvfrom
  95      (S       : C.int;
  96       Msg     : System.Address;
  97       Len     : C.int;
  98       Flags   : C.int;
  99       From    : Sockaddr_In_Access;
 100       Fromlen : not null access C.int) 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) 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) return C.int;
 117    pragma Import (C, Syscall_Sendto, "sendto");
 118
 119    function Syscall_Socket
 120      (Domain   : C.int;
 121       Typ      : C.int;
 122       Protocol : C.int) return C.int;
 123    pragma Import (C, Syscall_Socket, "socket");
 124
 125    procedure Disable_SIGPIPE (S : C.int);
 126    pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
 127
 128    procedure Disable_All_SIGPIPEs;
 129    pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
 130    --  Sets the process to ignore all SIGPIPE signals on platforms that
 131    --  don't support Disable_SIGPIPE for particular streams.
 132
 133    function Non_Blocking_Socket (S : C.int) return Boolean;
 134    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 135
 136    --------------
 137    -- C_Accept --
 138    --------------
 139
 140    function C_Accept
 141      (S       : C.int;
 142       Addr    : System.Address;
 143       Addrlen : not null access C.int) return C.int
 144    is
 145       R   : C.int;
 146       Val : aliased C.int := 1;
 147
 148       Discard : C.int;
 149       pragma Warnings (Off, Discard);
 150
 151    begin
 152       loop
 153          R := Syscall_Accept (S, Addr, Addrlen);
 154          exit when Constants.Thread_Blocking_IO
 155            or else R /= Failure
 156            or else Non_Blocking_Socket (S)
 157            or else Errno /= Constants.EWOULDBLOCK;
 158          delay Quantum;
 159       end loop;
 160
 161       if not Constants.Thread_Blocking_IO
 162         and then R /= Failure
 163       then
 164          --  A socket inherits the properties ot its server especially
 165          --  the FIONBIO flag. Do not use C_Ioctl as this subprogram
 166          --  tracks sockets set in non-blocking mode by user.
 167
 168          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 169          Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 170       end if;
 171
 172       Disable_SIGPIPE (R);
 173       return R;
 174    end C_Accept;
 175
 176    ---------------
 177    -- C_Connect --
 178    ---------------
 179
 180    function C_Connect
 181      (S       : C.int;
 182       Name    : System.Address;
 183       Namelen : C.int) return C.int
 184    is
 185       Res : C.int;
 186
 187    begin
 188       Res := Syscall_Connect (S, Name, Namelen);
 189
 190       if Constants.Thread_Blocking_IO
 191         or else Res /= Failure
 192         or else Non_Blocking_Socket (S)
 193         or else Errno /= Constants.EINPROGRESS
 194       then
 195          return Res;
 196       end if;
 197
 198       declare
 199          WSet : Fd_Set_Access;
 200          Now  : aliased Timeval;
 201
 202       begin
 203          WSet := New_Socket_Set (No_Fd_Set_Access);
 204          loop
 205             Insert_Socket_In_Set (WSet, S);
 206             Now := Immediat;
 207             Res := C_Select
 208               (S + 1,
 209                No_Fd_Set_Access,
 210                WSet,
 211                No_Fd_Set_Access,
 212                Now'Unchecked_Access);
 213
 214             exit when Res > 0;
 215
 216             if Res = Failure then
 217                Free_Socket_Set (WSet);
 218                return Res;
 219             end if;
 220
 221             delay Quantum;
 222          end loop;
 223
 224          Free_Socket_Set (WSet);
 225       end;
 226
 227       Res := Syscall_Connect (S, Name, Namelen);
 228
 229       if Res = Failure
 230         and then Errno = Constants.EISCONN
 231       then
 232          return Thin_Common.Success;
 233       else
 234          return Res;
 235       end if;
 236    end C_Connect;
 237
 238    -------------
 239    -- C_Ioctl --
 240    -------------
 241
 242    function C_Ioctl
 243      (S   : C.int;
 244       Req : C.int;
 245       Arg : Int_Access) return C.int
 246    is
 247    begin
 248       if not Constants.Thread_Blocking_IO
 249         and then Req = Constants.FIONBIO
 250       then
 251          if Arg.all /= 0 then
 252             Set_Non_Blocking_Socket (S, True);
 253          end if;
 254       end if;
 255
 256       return Syscall_Ioctl (S, Req, Arg);
 257    end C_Ioctl;
 258
 259    ------------
 260    -- C_Recv --
 261    ------------
 262
 263    function C_Recv
 264      (S     : C.int;
 265       Msg   : System.Address;
 266       Len   : C.int;
 267       Flags : C.int) return C.int
 268    is
 269       Res : C.int;
 270
 271    begin
 272       loop
 273          Res := Syscall_Recv (S, Msg, Len, Flags);
 274          exit when Constants.Thread_Blocking_IO
 275            or else Res /= Failure
 276            or else Non_Blocking_Socket (S)
 277            or else Errno /= Constants.EWOULDBLOCK;
 278          delay Quantum;
 279       end loop;
 280
 281       return Res;
 282    end C_Recv;
 283
 284    ----------------
 285    -- C_Recvfrom --
 286    ----------------
 287
 288    function C_Recvfrom
 289      (S       : C.int;
 290       Msg     : System.Address;
 291       Len     : C.int;
 292       Flags   : C.int;
 293       From    : Sockaddr_In_Access;
 294       Fromlen : not null access C.int) return C.int
 295    is
 296       Res : C.int;
 297
 298    begin
 299       loop
 300          Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
 301          exit when Constants.Thread_Blocking_IO
 302            or else Res /= Failure
 303            or else Non_Blocking_Socket (S)
 304            or else Errno /= Constants.EWOULDBLOCK;
 305          delay Quantum;
 306       end loop;
 307
 308       return Res;
 309    end C_Recvfrom;
 310
 311    ------------
 312    -- C_Send --
 313    ------------
 314
 315    function C_Send
 316      (S     : C.int;
 317       Msg   : System.Address;
 318       Len   : C.int;
 319       Flags : C.int) return C.int
 320    is
 321       Res : C.int;
 322
 323    begin
 324       loop
 325          Res := Syscall_Send (S, Msg, Len, Flags);
 326          exit when Constants.Thread_Blocking_IO
 327            or else Res /= Failure
 328            or else Non_Blocking_Socket (S)
 329            or else Errno /= Constants.EWOULDBLOCK;
 330          delay Quantum;
 331       end loop;
 332
 333       return Res;
 334    end C_Send;
 335
 336    --------------
 337    -- C_Sendto --
 338    --------------
 339
 340    function C_Sendto
 341      (S     : C.int;
 342       Msg   : System.Address;
 343       Len   : C.int;
 344       Flags : C.int;
 345       To    : Sockaddr_In_Access;
 346       Tolen : C.int) return C.int
 347    is
 348       Res : C.int;
 349
 350    begin
 351       loop
 352          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 353          exit when Constants.Thread_Blocking_IO
 354            or else Res /= Failure
 355            or else Non_Blocking_Socket (S)
 356            or else Errno /= Constants.EWOULDBLOCK;
 357          delay Quantum;
 358       end loop;
 359
 360       return Res;
 361    end C_Sendto;
 362
 363    --------------
 364    -- C_Socket --
 365    --------------
 366
 367    function C_Socket
 368      (Domain   : C.int;
 369       Typ      : C.int;
 370       Protocol : C.int) return C.int
 371    is
 372       R   : C.int;
 373       Val : aliased C.int := 1;
 374
 375       Discard : C.int;
 376       pragma Unreferenced (Discard);
 377
 378    begin
 379       R := Syscall_Socket (Domain, Typ, Protocol);
 380
 381       if not Constants.Thread_Blocking_IO
 382         and then R /= Failure
 383       then
 384          --  Do not use C_Ioctl as this subprogram tracks sockets set
 385          --  in non-blocking mode by user.
 386
 387          Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
 388          Set_Non_Blocking_Socket (R, False);
 389       end if;
 390       Disable_SIGPIPE (R);
 391       return R;
 392    end C_Socket;
 393
 394    --------------
 395    -- Finalize --
 396    --------------
 397
 398    procedure Finalize is
 399    begin
 400       null;
 401    end Finalize;
 402
 403    -------------------------
 404    -- Host_Error_Messages --
 405    -------------------------
 406
 407    package body Host_Error_Messages is separate;
 408
 409    ----------------
 410    -- Initialize --
 411    ----------------
 412
 413    procedure Initialize is
 414    begin
 415       Disable_All_SIGPIPEs;
 416    end Initialize;
 417
 418    -------------------------
 419    -- Non_Blocking_Socket --
 420    -------------------------
 421
 422    function Non_Blocking_Socket (S : C.int) return Boolean is
 423       R : Boolean;
 424    begin
 425       Task_Lock.Lock;
 426       R := (Is_Socket_In_Set (Non_Blocking_Sockets, S) /= 0);
 427       Task_Lock.Unlock;
 428       return R;
 429    end Non_Blocking_Socket;
 430
 431    -----------------------------
 432    -- Set_Non_Blocking_Socket --
 433    -----------------------------
 434
 435    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 436    begin
 437       Task_Lock.Lock;
 438
 439       if V then
 440          Insert_Socket_In_Set (Non_Blocking_Sockets, S);
 441       else
 442          Remove_Socket_From_Set (Non_Blocking_Sockets, S);
 443       end if;
 444
 445       Task_Lock.Unlock;
 446    end Set_Non_Blocking_Socket;
 447
 448    --------------------
 449    -- Signalling_Fds --
 450    --------------------
 451
 452    package body Signalling_Fds is
 453
 454       --  In this default implementation, we use a C version of these
 455       --  subprograms provided by socket.c.
 456
 457       function C_Create (Fds : not null access Fd_Pair) return C.int;
 458       function C_Read (Rsig : C.int) return C.int;
 459       function C_Write (Wsig : C.int) return C.int;
 460       procedure C_Close (Sig : C.int);
 461
 462       pragma Import (C, C_Create, "__gnat_create_signalling_fds");
 463       pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
 464       pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
 465       pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
 466
 467       function Create
 468         (Fds : not null access Fd_Pair) return C.int renames C_Create;
 469       function Read (Rsig : C.int) return C.int renames C_Read;
 470       function Write (Wsig : C.int) return C.int renames C_Write;
 471       procedure Close (Sig : C.int) renames C_Close;
 472
 473    end Signalling_Fds;
 474
 475    --------------------------
 476    -- Socket_Error_Message --
 477    --------------------------
 478
 479    function Socket_Error_Message
 480      (Errno : Integer) return C.Strings.chars_ptr
 481    is
 482       use type Interfaces.C.Strings.chars_ptr;
 483
 484       C_Msg : C.Strings.chars_ptr;
 485
 486    begin
 487       C_Msg := C_Strerror (C.int (Errno));
 488
 489       if C_Msg = C.Strings.Null_Ptr then
 490          return Unknown_System_Error;
 491       else
 492          return C_Msg;
 493       end if;
 494    end Socket_Error_Message;
 495
 496 end GNAT.Sockets.Thin;