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