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-2007, 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          Len := Sin'Size / 8;
  94          Set_Length (Sin'Unchecked_Access, Len);
  95          Sin.Sin_Family    := Constants.AF_INET;
  96          Sin.Sin_Addr.S_B1 := 127;
  97          Sin.Sin_Addr.S_B2 := 0;
  98          Sin.Sin_Addr.S_B3 := 0;
  99          Sin.Sin_Addr.S_B4 := 1;
 100          Sin.Sin_Port      := 0;
 101
 102          Res := C_Bind (L_Sock, Sin'Address, Len);
 103
 104          if Res = Failure then
 105             goto Fail;
 106          end if;
 107
 108          --  Get assigned port
 109
 110          Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
 111          if Res = Failure then
 112             goto Fail;
 113          end if;
 114
 115          --  Set socket to listen mode, with a backlog of 1 to guarantee that
 116          --  exactly one call to connect(2) succeeds.
 117
 118          Res := C_Listen (L_Sock, 1);
 119
 120          if Res = Failure then
 121             goto Fail;
 122          end if;
 123
 124          --  Create read end (client) socket
 125
 126          R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 127
 128          if R_Sock = Failure then
 129             goto Fail;
 130          end if;
 131
 132          --  Connect listening socket
 133
 134          Res := C_Connect (R_Sock, Sin'Address, Len);
 135
 136          exit when Res /= Failure;
 137
 138          if Socket_Errno /= Constants.EADDRINUSE then
 139             goto Fail;
 140          end if;
 141
 142          --  In rare cases, the above C_Bind chooses a port that is still
 143          --  marked "in use", even though it has been closed (perhaps by some
 144          --  other process that has already exited). This causes the above
 145          --  C_Connect to fail with EADDRINUSE. In this case, we close the
 146          --  ports, and loop back to try again. This mysterious windows
 147          --  behavior is documented. See, for example:
 148          --    http://msdn2.microsoft.com/en-us/library/ms737625.aspx
 149          --  In an experiment with 2000 calls, 21 required exactly one retry, 7
 150          --  required two, and none required three or more. Note that no delay
 151          --  is needed between retries; retrying C_Bind will typically produce
 152          --  a different port.
 153
 154          pragma Assert (Res = Failure
 155                           and then
 156                         Socket_Errno = Constants.EADDRINUSE);
 157          pragma Warnings (Off); -- useless assignment to "Res"
 158          Res := C_Close (W_Sock);
 159          pragma Warnings (On);
 160          W_Sock := Failure;
 161          Res := C_Close (R_Sock);
 162          R_Sock := Failure;
 163       end loop;
 164
 165       --  Since the call to connect(2) has suceeded and the backlog limit on
 166       --  the listening socket is 1, we know that there is now exactly one
 167       --  pending connection on L_Sock, which is the one from R_Sock.
 168
 169       W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
 170
 171       if W_Sock = Failure then
 172          goto Fail;
 173       end if;
 174
 175       --  Set TCP_NODELAY on W_Sock, since we always want to send the data out
 176       --  immediately.
 177
 178       Set_Socket_Option
 179         (Socket => Socket_Type (W_Sock),
 180          Level  => IP_Protocol_For_TCP_Level,
 181          Option => (Name => No_Delay, Enabled => True));
 182
 183       --  Close listening socket (ignore exit status)
 184
 185       Res := C_Close (L_Sock);
 186
 187       Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
 188
 189       return Success;
 190
 191    <<Fail>>
 192       declare
 193          Saved_Errno : constant Integer := Socket_Errno;
 194
 195       begin
 196          if W_Sock /= Failure then
 197             Res := C_Close (W_Sock);
 198          end if;
 199
 200          if R_Sock /= Failure then
 201             Res := C_Close (R_Sock);
 202          end if;
 203
 204          if L_Sock /= Failure then
 205             Res := C_Close (L_Sock);
 206          end if;
 207
 208          Set_Socket_Errno (Saved_Errno);
 209       end;
 210
 211       return Failure;
 212    end Create;
 213
 214    ----------
 215    -- Read --
 216    ----------
 217
 218    function Read (Rsig : C.int) return C.int is
 219       Buf : aliased Character;
 220    begin
 221       return C_Recv (Rsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
 222    end Read;
 223
 224    -----------
 225    -- Write --
 226    -----------
 227
 228    function Write (Wsig : C.int) return C.int is
 229       Buf : aliased Character := ASCII.NUL;
 230    begin
 231       return C_Send (Wsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
 232    end Write;
 233
 234 end Signalling_Fds;