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