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-2010, 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    Unknown_System_Error : constant C.Strings.chars_ptr :=
  61                             C.Strings.New_String ("Unknown system error");
  62
  63    --  Comments required for following functions ???
  64
  65    function Syscall_Accept
  66      (S       : C.int;
  67       Addr    : System.Address;
  68       Addrlen : not null access C.int) 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) return C.int;
  75    pragma Import (C, Syscall_Connect, "connect");
  76
  77    function Syscall_Recv
  78      (S     : C.int;
  79       Msg   : System.Address;
  80       Len   : C.int;
  81       Flags : C.int) return C.int;
  82    pragma Import (C, Syscall_Recv, "recv");
  83
  84    function Syscall_Recvfrom
  85      (S       : C.int;
  86       Msg     : System.Address;
  87       Len     : C.int;
  88       Flags   : C.int;
  89       From    : System.Address;
  90       Fromlen : not null access C.int) return C.int;
  91    pragma Import (C, Syscall_Recvfrom, "recvfrom");
  92
  93    function Syscall_Recvmsg
  94      (S     : C.int;
  95       Msg   : System.Address;
  96       Flags : C.int) return System.CRTL.ssize_t;
  97    pragma Import (C, Syscall_Recvmsg, "recvmsg");
  98
  99    function Syscall_Sendmsg
 100      (S     : C.int;
 101       Msg   : System.Address;
 102       Flags : C.int) return System.CRTL.ssize_t;
 103    pragma Import (C, Syscall_Sendmsg, "sendmsg");
 104
 105    function Syscall_Sendto
 106      (S     : C.int;
 107       Msg   : System.Address;
 108       Len   : C.int;
 109       Flags : C.int;
 110       To    : System.Address;
 111       Tolen : C.int) return C.int;
 112    pragma Import (C, Syscall_Sendto, "sendto");
 113
 114    function Syscall_Socket
 115      (Domain   : C.int;
 116       Typ      : C.int;
 117       Protocol : C.int) return C.int;
 118    pragma Import (C, Syscall_Socket, "socket");
 119
 120    procedure Disable_SIGPIPE (S : C.int);
 121    pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
 122
 123    procedure Disable_All_SIGPIPEs;
 124    pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
 125    --  Sets the process to ignore all SIGPIPE signals on platforms that
 126    --  don't support Disable_SIGPIPE for particular streams.
 127
 128    function Non_Blocking_Socket (S : C.int) return Boolean;
 129    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
 130
 131    --------------
 132    -- C_Accept --
 133    --------------
 134
 135    function C_Accept
 136      (S       : C.int;
 137       Addr    : System.Address;
 138       Addrlen : not null access C.int) return C.int
 139    is
 140       R   : C.int;
 141       Val : aliased C.int := 1;
 142
 143       Discard : C.int;
 144       pragma Warnings (Off, Discard);
 145
 146    begin
 147       loop
 148          R := Syscall_Accept (S, Addr, Addrlen);
 149          exit when SOSC.Thread_Blocking_IO
 150            or else R /= Failure
 151            or else Non_Blocking_Socket (S)
 152            or else Errno /= SOSC.EWOULDBLOCK;
 153          delay Quantum;
 154       end loop;
 155
 156       if not SOSC.Thread_Blocking_IO
 157         and then R /= Failure
 158       then
 159          --  A socket inherits the properties ot its server especially
 160          --  the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
 161          --  tracks sockets set in non-blocking mode by user.
 162
 163          Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
 164          Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 165       end if;
 166
 167       Disable_SIGPIPE (R);
 168       return R;
 169    end C_Accept;
 170
 171    ---------------
 172    -- C_Connect --
 173    ---------------
 174
 175    function C_Connect
 176      (S       : C.int;
 177       Name    : System.Address;
 178       Namelen : C.int) return C.int
 179    is
 180       Res : C.int;
 181
 182    begin
 183       Res := Syscall_Connect (S, Name, Namelen);
 184
 185       if SOSC.Thread_Blocking_IO
 186         or else Res /= Failure
 187         or else Non_Blocking_Socket (S)
 188         or else Errno /= SOSC.EINPROGRESS
 189       then
 190          return Res;
 191       end if;
 192
 193       declare
 194          WSet : aliased Fd_Set;
 195          Now  : aliased Timeval;
 196
 197       begin
 198          Reset_Socket_Set (WSet'Access);
 199          loop
 200             Insert_Socket_In_Set (WSet'Access, S);
 201             Now := Immediat;
 202             Res := C_Select
 203               (S + 1,
 204                No_Fd_Set_Access,
 205                WSet'Access,
 206                No_Fd_Set_Access,
 207                Now'Unchecked_Access);
 208
 209             exit when Res > 0;
 210
 211             if Res = Failure then
 212                return Res;
 213             end if;
 214
 215             delay Quantum;
 216          end loop;
 217       end;
 218
 219       Res := Syscall_Connect (S, Name, Namelen);
 220
 221       if Res = Failure
 222         and then Errno = SOSC.EISCONN
 223       then
 224          return Thin_Common.Success;
 225       else
 226          return Res;
 227       end if;
 228    end C_Connect;
 229
 230    ------------------
 231    -- Socket_Ioctl --
 232    ------------------
 233
 234    function Socket_Ioctl
 235      (S   : C.int;
 236       Req : C.int;
 237       Arg : access C.int) return C.int
 238    is
 239    begin
 240       if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
 241          if Arg.all /= 0 then
 242             Set_Non_Blocking_Socket (S, True);
 243          end if;
 244       end if;
 245
 246       return C_Ioctl (S, Req, Arg);
 247    end Socket_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 SOSC.Thread_Blocking_IO
 265            or else Res /= Failure
 266            or else Non_Blocking_Socket (S)
 267            or else Errno /= SOSC.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    : System.Address;
 284       Fromlen : not null 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 SOSC.Thread_Blocking_IO
 292            or else Res /= Failure
 293            or else Non_Blocking_Socket (S)
 294            or else Errno /= SOSC.EWOULDBLOCK;
 295          delay Quantum;
 296       end loop;
 297
 298       return Res;
 299    end C_Recvfrom;
 300
 301    ---------------
 302    -- C_Recvmsg --
 303    ---------------
 304
 305    function C_Recvmsg
 306      (S     : C.int;
 307       Msg   : System.Address;
 308       Flags : C.int) return System.CRTL.ssize_t
 309    is
 310       Res : System.CRTL.ssize_t;
 311
 312    begin
 313       loop
 314          Res := Syscall_Recvmsg (S, Msg, Flags);
 315          exit when SOSC.Thread_Blocking_IO
 316            or else Res /= System.CRTL.ssize_t (Failure)
 317            or else Non_Blocking_Socket (S)
 318            or else Errno /= SOSC.EWOULDBLOCK;
 319          delay Quantum;
 320       end loop;
 321
 322       return Res;
 323    end C_Recvmsg;
 324
 325    ---------------
 326    -- C_Sendmsg --
 327    ---------------
 328
 329    function C_Sendmsg
 330      (S     : C.int;
 331       Msg   : System.Address;
 332       Flags : C.int) return System.CRTL.ssize_t
 333    is
 334       Res : System.CRTL.ssize_t;
 335
 336    begin
 337       loop
 338          Res := Syscall_Sendmsg (S, Msg, Flags);
 339          exit when SOSC.Thread_Blocking_IO
 340            or else Res /= System.CRTL.ssize_t (Failure)
 341            or else Non_Blocking_Socket (S)
 342            or else Errno /= SOSC.EWOULDBLOCK;
 343          delay Quantum;
 344       end loop;
 345
 346       return Res;
 347    end C_Sendmsg;
 348
 349    --------------
 350    -- C_Sendto --
 351    --------------
 352
 353    function C_Sendto
 354      (S     : C.int;
 355       Msg   : System.Address;
 356       Len   : C.int;
 357       Flags : C.int;
 358       To    : System.Address;
 359       Tolen : C.int) return C.int
 360    is
 361       Res : C.int;
 362
 363    begin
 364       loop
 365          Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
 366          exit when SOSC.Thread_Blocking_IO
 367            or else Res /= Failure
 368            or else Non_Blocking_Socket (S)
 369            or else Errno /= SOSC.EWOULDBLOCK;
 370          delay Quantum;
 371       end loop;
 372
 373       return Res;
 374    end C_Sendto;
 375
 376    --------------
 377    -- C_Socket --
 378    --------------
 379
 380    function C_Socket
 381      (Domain   : C.int;
 382       Typ      : C.int;
 383       Protocol : C.int) return C.int
 384    is
 385       R   : C.int;
 386       Val : aliased C.int := 1;
 387
 388       Discard : C.int;
 389       pragma Unreferenced (Discard);
 390
 391    begin
 392       R := Syscall_Socket (Domain, Typ, Protocol);
 393
 394       if not SOSC.Thread_Blocking_IO
 395         and then R /= Failure
 396       then
 397          --  Do not use Socket_Ioctl as this subprogram tracks sockets set
 398          --  in non-blocking mode by user.
 399
 400          Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
 401          Set_Non_Blocking_Socket (R, False);
 402       end if;
 403       Disable_SIGPIPE (R);
 404       return R;
 405    end C_Socket;
 406
 407    --------------
 408    -- Finalize --
 409    --------------
 410
 411    procedure Finalize is
 412    begin
 413       null;
 414    end Finalize;
 415
 416    -------------------------
 417    -- Host_Error_Messages --
 418    -------------------------
 419
 420    package body Host_Error_Messages is separate;
 421
 422    ----------------
 423    -- Initialize --
 424    ----------------
 425
 426    procedure Initialize is
 427    begin
 428       Disable_All_SIGPIPEs;
 429       Reset_Socket_Set (Non_Blocking_Sockets'Access);
 430    end Initialize;
 431
 432    -------------------------
 433    -- Non_Blocking_Socket --
 434    -------------------------
 435
 436    function Non_Blocking_Socket (S : C.int) return Boolean is
 437       R : Boolean;
 438    begin
 439       Task_Lock.Lock;
 440       R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
 441       Task_Lock.Unlock;
 442       return R;
 443    end Non_Blocking_Socket;
 444
 445    -----------------------------
 446    -- Set_Non_Blocking_Socket --
 447    -----------------------------
 448
 449    procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
 450    begin
 451       Task_Lock.Lock;
 452
 453       if V then
 454          Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
 455       else
 456          Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
 457       end if;
 458
 459       Task_Lock.Unlock;
 460    end Set_Non_Blocking_Socket;
 461
 462    --------------------
 463    -- Signalling_Fds --
 464    --------------------
 465
 466    package body Signalling_Fds is
 467
 468       --  In this default implementation, we use a C version of these
 469       --  subprograms provided by socket.c.
 470
 471       function C_Create (Fds : not null access Fd_Pair) return C.int;
 472       function C_Read (Rsig : C.int) return C.int;
 473       function C_Write (Wsig : C.int) return C.int;
 474       procedure C_Close (Sig : C.int);
 475
 476       pragma Import (C, C_Create, "__gnat_create_signalling_fds");
 477       pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
 478       pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
 479       pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
 480
 481       function Create
 482         (Fds : not null access Fd_Pair) return C.int renames C_Create;
 483       function Read (Rsig : C.int) return C.int renames C_Read;
 484       function Write (Wsig : C.int) return C.int renames C_Write;
 485       procedure Close (Sig : C.int) renames C_Close;
 486
 487    end Signalling_Fds;
 488
 489    --------------------------
 490    -- Socket_Error_Message --
 491    --------------------------
 492
 493    function Socket_Error_Message
 494      (Errno : Integer) return C.Strings.chars_ptr
 495    is separate;
 496
 497 end GNAT.Sockets.Thin;