gcc/ada/g-stsifd-sockets.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --     G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S      --
   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 --  Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds
  33 --  used for platforms that do not support UNIX pipes.
  34
  35 --  Note: this code used to be in GNAT.Sockets, but has been moved to a
  36 --  platform-specific file. It is now used only for non-UNIX platforms.
  37
  38 separate (GNAT.Sockets.Thin)
  39 package body Signalling_Fds is
  40
  41    -----------
  42    -- Close --
  43    -----------
  44
  45    procedure Close (Sig : C.int) is
  46       Res : C.int;
  47       pragma Unreferenced (Res);
  48       --  Res is assigned but never read, because we purposefully ignore
  49       --  any error returned by the C_Close system call, as per the spec
  50       --  of this procedure.
  51    begin
  52       Res := C_Close (Sig);
  53    end Close;
  54
  55    ------------
  56    -- Create --
  57    ------------
  58
  59    function Create (Fds : not null access Fd_Pair) return C.int is
  60       L_Sock, R_Sock, W_Sock : C.int := Failure;
  61       --  Listening socket, read socket and write socket
  62
  63       Sin : aliased Sockaddr_In;
  64       Len : aliased C.int;
  65       --  Address of listening socket
  66
  67       Res : C.int;
  68       pragma Warnings (Off, Res);
  69       --  Return status of system calls (usually ignored, hence warnings off)
  70
  71    begin
  72       Fds.all := (Read_End | Write_End => Failure);
  73
  74       --  We open two signalling sockets. One of them is used to send data
  75       --  to the other, which is included in a C_Select socket set. The
  76       --  communication is used to force the call to C_Select to complete,
  77       --  and the waiting task to resume its execution.
  78
  79       loop
  80          --  Retry loop, in case the C_Connect below fails
  81
  82          --  Create a listening socket
  83
  84          L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
  85
  86          if L_Sock = Failure then
  87             goto Fail;
  88          end if;
  89
  90          --  Bind the socket to an available port on localhost
  91
  92          Set_Family (Sin.Sin_Family, Family_Inet);
  93          Sin.Sin_Addr.S_B1 := 127;
  94          Sin.Sin_Addr.S_B2 := 0;
  95          Sin.Sin_Addr.S_B3 := 0;
  96          Sin.Sin_Addr.S_B4 := 1;
  97          Sin.Sin_Port      := 0;
  98
  99          Len := C.int (Lengths (Family_Inet));
 100          Res := C_Bind (L_Sock, Sin'Address, Len);
 101
 102          if Res = Failure then
 103             goto Fail;
 104          end if;
 105
 106          --  Get assigned port
 107
 108          Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
 109          if Res = Failure then
 110             goto Fail;
 111          end if;
 112
 113          --  Set socket to listen mode, with a backlog of 1 to guarantee that
 114          --  exactly one call to connect(2) succeeds.
 115
 116          Res := C_Listen (L_Sock, 1);
 117
 118          if Res = Failure then
 119             goto Fail;
 120          end if;
 121
 122          --  Create read end (client) socket
 123
 124          R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
 125
 126          if R_Sock = Failure then
 127             goto Fail;
 128          end if;
 129
 130          --  Connect listening socket
 131
 132          Res := C_Connect (R_Sock, Sin'Address, Len);
 133
 134          exit when Res /= Failure;
 135
 136          if Socket_Errno /= SOSC.EADDRINUSE then
 137             goto Fail;
 138          end if;
 139
 140          --  In rare cases, the above C_Bind chooses a port that is still
 141          --  marked "in use", even though it has been closed (perhaps by some
 142          --  other process that has already exited). This causes the above
 143          --  C_Connect to fail with EADDRINUSE. In this case, we close the
 144          --  ports, and loop back to try again. This mysterious Windows
 145          --  behavior is documented. See, for example:
 146          --    http://msdn2.microsoft.com/en-us/library/ms737625.aspx
 147          --  In an experiment with 2000 calls, 21 required exactly one retry, 7
 148          --  required two, and none required three or more. Note that no delay
 149          --  is needed between retries; retrying C_Bind will typically produce
 150          --  a different port.
 151
 152          pragma Assert (Res = Failure
 153                           and then
 154                         Socket_Errno = SOSC.EADDRINUSE);
 155          Res := C_Close (W_Sock);
 156          W_Sock := Failure;
 157          Res := C_Close (R_Sock);
 158          R_Sock := Failure;
 159       end loop;
 160
 161       --  Since the call to connect(2) has succeeded and the backlog limit on
 162       --  the listening socket is 1, we know that there is now exactly one
 163       --  pending connection on L_Sock, which is the one from R_Sock.
 164
 165       W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
 166
 167       if W_Sock = Failure then
 168          goto Fail;
 169       end if;
 170
 171       --  Set TCP_NODELAY on W_Sock, since we always want to send the data out
 172       --  immediately.
 173
 174       Set_Socket_Option
 175         (Socket => Socket_Type (W_Sock),
 176          Level  => IP_Protocol_For_TCP_Level,
 177          Option => (Name => No_Delay, Enabled => True));
 178
 179       --  Close listening socket (ignore exit status)
 180
 181       Res := C_Close (L_Sock);
 182
 183       Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
 184
 185       return Thin_Common.Success;
 186
 187    <<Fail>>
 188       declare
 189          Saved_Errno : constant Integer := Socket_Errno;
 190
 191       begin
 192          if W_Sock /= Failure then
 193             Res := C_Close (W_Sock);
 194          end if;
 195
 196          if R_Sock /= Failure then
 197             Res := C_Close (R_Sock);
 198          end if;
 199
 200          if L_Sock /= Failure then
 201             Res := C_Close (L_Sock);
 202          end if;
 203
 204          Set_Socket_Errno (Saved_Errno);
 205       end;
 206
 207       return Failure;
 208    end Create;
 209
 210    ----------
 211    -- Read --
 212    ----------
 213
 214    function Read (Rsig : C.int) return C.int is
 215       Buf : aliased Character;
 216    begin
 217       return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags);
 218    end Read;
 219
 220    -----------
 221    -- Write --
 222    -----------
 223
 224    function Write (Wsig : C.int) return C.int is
 225       Buf : aliased Character := ASCII.NUL;
 226    begin
 227       return C_Sendto
 228         (Wsig, Buf'Address, 1,
 229          Flags => SOSC.MSG_Forced_Flags,
 230          To    => System.Null_Address,
 231          Tolen => 0);
 232    end Write;
 233
 234 end Signalling_Fds;