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