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       pragma Warnings (Off, Res);
  71       --  Return status of system calls (usually ignored, hence warnings off)
  72
  73    begin
  74       Fds.all := (Read_End | Write_End => Failure);
  75
  76       --  We open two signalling sockets. One of them is used to send data
  77       --  to the other, which is included in a C_Select socket set. The
  78       --  communication is used to force the call to C_Select to complete,
  79       --  and the waiting task to resume its execution.
  80
  81       loop
  82          --  Retry loop, in case the C_Connect below fails
  83
  84          --  Create a listening socket
  85
  86          L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
  87
  88          if L_Sock = Failure then
  89             goto Fail;
  90          end if;
  91
  92          --  Bind the socket to an available port on localhost
  93
  94          Set_Family (Sin.Sin_Family, Family_Inet);
  95          Sin.Sin_Addr.S_B1 := 127;
  96          Sin.Sin_Addr.S_B2 := 0;
  97          Sin.Sin_Addr.S_B3 := 0;
  98          Sin.Sin_Addr.S_B4 := 1;
  99          Sin.Sin_Port      := 0;
 100
 101          Len := C.int (Lengths (Family_Inet));
 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 (SOSC.AF_INET, SOSC.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 /= SOSC.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 = SOSC.EADDRINUSE);
 157          Res := C_Close (W_Sock);
 158          W_Sock := Failure;
 159          Res := C_Close (R_Sock);
 160          R_Sock := Failure;
 161       end loop;
 162
 163       --  Since the call to connect(2) has succeeded and the backlog limit on
 164       --  the listening socket is 1, we know that there is now exactly one
 165       --  pending connection on L_Sock, which is the one from R_Sock.
 166
 167       W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
 168
 169       if W_Sock = Failure then
 170          goto Fail;
 171       end if;
 172
 173       --  Set TCP_NODELAY on W_Sock, since we always want to send the data out
 174       --  immediately.
 175
 176       Set_Socket_Option
 177         (Socket => Socket_Type (W_Sock),
 178          Level  => IP_Protocol_For_TCP_Level,
 179          Option => (Name => No_Delay, Enabled => True));
 180
 181       --  Close listening socket (ignore exit status)
 182
 183       Res := C_Close (L_Sock);
 184
 185       Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
 186
 187       return Thin_Common.Success;
 188
 189    <<Fail>>
 190       declare
 191          Saved_Errno : constant Integer := Socket_Errno;
 192
 193       begin
 194          if W_Sock /= Failure then
 195             Res := C_Close (W_Sock);
 196          end if;
 197
 198          if R_Sock /= Failure then
 199             Res := C_Close (R_Sock);
 200          end if;
 201
 202          if L_Sock /= Failure then
 203             Res := C_Close (L_Sock);
 204          end if;
 205
 206          Set_Socket_Errno (Saved_Errno);
 207       end;
 208
 209       return Failure;
 210    end Create;
 211
 212    ----------
 213    -- Read --
 214    ----------
 215
 216    function Read (Rsig : C.int) return C.int is
 217       Buf : aliased Character;
 218    begin
 219       return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags);
 220    end Read;
 221
 222    -----------
 223    -- Write --
 224    -----------
 225
 226    function Write (Wsig : C.int) return C.int is
 227       Buf : aliased Character := ASCII.NUL;
 228    begin
 229       return C_Send (Wsig, Buf'Address, 1, SOSC.MSG_Forced_Flags);
 230    end Write;
 231
 232 end Signalling_Fds;