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-2006, 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
  41   (GNAT.Sockets.Thin)
  42 package body Signalling_Fds is
  43
  44    ------------
  45    -- Create --
  46    ------------
  47
  48    function Create (Fds : not null access Fd_Pair) return C.int is
  49       L_Sock, R_Sock, W_Sock : C.int := Failure;
  50       --  Listening socket, read socket and write socket
  51
  52       Sin : aliased Sockaddr_In;
  53       Len : aliased C.int := Sin'Size / 8;
  54       --  Address of listening socket
  55
  56       Res : C.int;
  57       --  Return status of system calls
  58
  59       Err : Integer;
  60       --  Saved errno value
  61
  62    begin
  63       Fds (Read_End)  := Failure;
  64       Fds (Write_End) := Failure;
  65
  66       --  We open two signalling sockets. One of them is used to send data
  67       --  to the other, which is included in a C_Select socket set. The
  68       --  communication is used to force the call to C_Select to complete,
  69       --  and the waiting task to resume its execution.
  70
  71       --  Create a listening socket
  72
  73       L_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
  74
  75       if L_Sock = Failure then
  76          goto Fail;
  77       end if;
  78
  79       --  Bind the socket to an available port on localhost
  80
  81       Sin.Sin_Addr.S_B1 := 127;
  82       Sin.Sin_Addr.S_B2 := 0;
  83       Sin.Sin_Addr.S_B3 := 0;
  84       Sin.Sin_Addr.S_B4 := 1;
  85       Sin.Sin_Port := 0;
  86
  87       Res := C_Bind (L_Sock, Sin'Address, Len);
  88
  89       if Res = Failure then
  90          goto Fail;
  91       end if;
  92
  93       --  Get assigned port
  94
  95       Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
  96       if Res = Failure then
  97          goto Fail;
  98       end if;
  99
 100       --  Set socket to listen mode, with a backlog of 1 to guarantee that
 101       --  exactly one call to connect(2) succeeds.
 102
 103       Res := C_Listen (L_Sock, 1);
 104
 105       if Res = Failure then
 106          goto Fail;
 107       end if;
 108
 109       --  Create read end (client) socket
 110
 111       R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
 112
 113       if R_Sock = Failure then
 114          goto Fail;
 115       end if;
 116
 117       --  Connect listening socket
 118
 119       Res := C_Connect (R_Sock, Sin'Address, Len);
 120
 121       if Res = Failure then
 122          goto Fail;
 123       end if;
 124
 125       --  Since the call to connect(2) has suceeded and the backlog limit on
 126       --  the listening socket is 1, we know that there is now exactly one
 127       --  pending connection on L_Sock, which is the one from R_Sock.
 128
 129       W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
 130       if W_Sock = Failure then
 131          goto Fail;
 132       end if;
 133
 134       --  Set TCP_NODELAY on W_Sock, since we always want to send the data out
 135       --  immediately.
 136
 137       Set_Socket_Option
 138         (Socket => Socket_Type (W_Sock),
 139          Level  => IP_Protocol_For_TCP_Level,
 140          Option => (Name => No_Delay, Enabled => True));
 141
 142       --  Close listening socket (ignore exit status)
 143
 144       Res := C_Close (L_Sock);
 145
 146       Fds (Read_End)  := R_Sock;
 147       Fds (Write_End) := W_Sock;
 148
 149       return Success;
 150
 151    <<Fail>>
 152       Err := Socket_Errno;
 153
 154       if W_Sock /= Failure then
 155          Res := C_Close (W_Sock);
 156       end if;
 157
 158       if R_Sock /= Failure then
 159          Res := C_Close (R_Sock);
 160       end if;
 161
 162       if L_Sock /= Failure then
 163          Res := C_Close (L_Sock);
 164       end if;
 165
 166       Set_Socket_Errno (Err);
 167
 168       return Failure;
 169    end Create;
 170
 171    ----------
 172    -- Read --
 173    ----------
 174
 175    function Read (Rsig : C.int) return C.int is
 176       Buf : aliased Character;
 177    begin
 178       return C_Recv (Rsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
 179    end Read;
 180
 181    -----------
 182    -- Write --
 183    -----------
 184
 185    function Write (Wsig : C.int) return C.int is
 186       Buf : aliased Character := ASCII.NUL;
 187    begin
 188       return C_Send (Wsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
 189    end Write;
 190
 191 end Signalling_Fds;