------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- G N A T . S O C K E T S . T H I N . C _ S O C K E T P A I R -- -- -- -- B o d y -- -- -- -- Copyright (C) 2001-2024, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ -- Portable sockets-based implementation of the C_Socketpair used for -- platforms that do not support UNIX socketpair system call. -- Note: this code is only for non-UNIX platforms. separate (GNAT.Sockets.Thin) function C_Socketpair (Domain : C.int; Typ : C.int; Protocol : C.int; Fds : not null access Fd_Pair) return C.int is -- This use type clause is not required on all platforms -- using this implementation. So we suppress the warning -- for the platforms that already use this type. pragma Warnings (Off, "use clause for type *"); use type C.char_array; pragma Warnings (On, "use clause for type *"); L_Sock, C_Sock, P_Sock : C.int := Failure; -- Listening socket, client socket and peer socket Family : constant Family_Type := (case Domain is when SOSC.AF_INET => Family_Inet, when SOSC.AF_INET6 => Family_Inet6, when others => Family_Unspec); Len : aliased C.int := C.int (Lengths (Family)); C_Sin : aliased Sockaddr; C_Bin : aliased C.char_array (1 .. C.size_t (Len)); for C_Bin'Address use C_Sin'Address; -- Address of listening and client socket and it's binary representation. -- We need binary representation because Ada does not allow to compare -- unchecked union if either of the operands lacks inferable discriminants. -- RM-B-3-3 23/2. P_Sin : aliased Sockaddr; P_Bin : aliased C.char_array (1 .. C.size_t (Len)); for P_Bin'Address use P_Sin'Address; -- Address of peer socket and it's binary representation T_Sin : aliased Sockaddr; T_Bin : aliased C.char_array (1 .. C.size_t (Len)); for T_Bin'Address use T_Sin'Address; -- Temporary address to compare and check that address and port of the -- socket equal to peer address and port of the opposite connected socket. Res : C.int with Warnings => Off; begin Set_Family (C_Sin.Sin_Family, Family); case Family is when Family_Inet => C_Sin.Sin_Addr.S_B1 := 127; C_Sin.Sin_Addr.S_B4 := 1; when Family_Inet6 => C_Sin.Sin6_Addr (C_Sin.Sin6_Addr'Last) := 1; when others => Set_Socket_Errno (SOSC.EAFNOSUPPORT); return Failure; end case; for J in 1 .. 10 loop -- Retry loop, in case the C_Connect below fails C_Sin.Sin_Port := 0; -- Create a listening socket L_Sock := C_Socket (Domain, Typ, Protocol); exit when L_Sock = Failure; -- Bind the socket to an available port on localhost Res := C_Bind (L_Sock, C_Sin'Address, Len); exit when Res = Failure; -- Get assigned port Res := C_Getsockname (L_Sock, C_Sin'Address, Len'Access); exit when Res = Failure; -- Set socket to listen mode, with a backlog of 1 to guarantee that -- exactly one call to connect(2) succeeds. Res := C_Listen (L_Sock, 1); exit when Res = Failure; -- Create read end (client) socket C_Sock := C_Socket (Domain, Typ, Protocol); exit when C_Sock = Failure; -- Connect listening socket Res := C_Connect (C_Sock, C_Sin'Address, Len); if Res = Failure then -- In rare cases, the above C_Bind chooses a port that is still -- marked "in use", even though it has been closed (perhaps by some -- other process that has already exited). This causes the above -- C_Connect to fail with EADDRINUSE. In this case, we close the -- ports, and loop back to try again. This mysterious Windows -- behavior is documented. See, for example: -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx -- In an experiment with 2000 calls, 21 required exactly one retry, 7 -- required two, and none required three or more. Note that no delay -- is needed between retries; retrying C_Bind will typically produce -- a different port. exit when Socket_Errno /= SOSC.EADDRINUSE; goto Repeat; end if; -- Since the call to connect(2) has succeeded and the backlog limit -- on the listening socket is 1, we know that there is now exactly -- one pending connection on L_Sock, which is the one from R_Sock. P_Sin.Sun_Path := (others => C.nul); P_Sock := C_Accept (L_Sock, P_Sin'Address, Len'Access); exit when P_Sock = Failure; -- Address and port of the socket equal to peer address and port of the -- opposite connected socket. Res := C_Getsockname (P_Sock, T_Sin'Address, Len'Access); exit when Res = Failure; if T_Bin /= C_Bin then goto Repeat; end if; -- Address and port of the socket equal to peer address and port of the -- opposite connected socket. Res := C_Getsockname (C_Sock, T_Sin'Address, Len'Access); exit when Res = Failure; if T_Bin /= P_Bin then goto Repeat; end if; -- Close listening socket (ignore exit status) Res := C_Close (L_Sock); Fds.all := (Read_End => C_Sock, Write_End => P_Sock); return Thin_Common.Success; <> Res := C_Close (C_Sock); C_Sock := Failure; Res := C_Close (P_Sock); P_Sock := Failure; Res := C_Close (L_Sock); L_Sock := Failure; end loop; declare Saved_Errno : constant Integer := Socket_Errno; begin if P_Sock /= Failure then Res := C_Close (P_Sock); end if; if C_Sock /= Failure then Res := C_Close (C_Sock); end if; if L_Sock /= Failure then Res := C_Close (L_Sock); end if; Set_Socket_Errno (Saved_Errno); end; return Failure; end C_Socketpair;