+2019-09-19 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * libgnat/g-socket.ads, libgnat/g-socket.adb
+ (Create_Socket_Pair): New routine.
+ * libgnat/g-socthi.ads (OS_Has_Socketpair): Boolean constant.
+ (C_Socketpair): New imported routine.
+ * libgnat/g-socthi__mingw.ads, libgnat/g-socthi__vxworks.ads
+ (Default_Socket_Pair_Family): New constant.
+ (C_Socketpair): New routine.
+ * libgnat/g-socthi__mingw.adb, libgnat/g-socthi__vxworks.adb
+ (C_Socketpair): Is separated in anouther file.
+ * libgnat/g-sthcso.adb (C_Socketpair): Non UNIX implementation.
+ * libgnat/g-stsifd__sockets.adb: Reuse C_Socketpair.
+
2019-09-19 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Analyze_Depends_In_Decl_Part): Simplify previous
Socket := Socket_Type (Res);
end Create_Socket;
+ ------------------------
+ -- Create_Socket_Pair --
+ ------------------------
+
+ procedure Create_Socket_Pair
+ (Left : out Socket_Type;
+ Right : out Socket_Type;
+ Family : Family_Type := Family_Unspec;
+ Mode : Mode_Type := Socket_Stream;
+ Level : Level_Type := IP_Protocol_For_IP_Level)
+ is
+ Res : C.int;
+ Pair : aliased Thin_Common.Fd_Pair;
+
+ begin
+ Res := C_Socketpair
+ ((if Family = Family_Unspec then Default_Socket_Pair_Family
+ else Families (Family)),
+ Modes (Mode), Levels (Level), Pair'Access);
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Left := Socket_Type (Pair (Pair'First));
+ Right := Socket_Type (Pair (Pair'Last));
+ end Create_Socket_Pair;
+
-----------
-- Empty --
-----------
Family : Family_Type := Family_Inet;
Mode : Mode_Type := Socket_Stream;
Level : Level_Type := IP_Protocol_For_IP_Level);
- -- Create an endpoint for communication. Raises Socket_Error on error
+ -- Create an endpoint for communication. Raises Socket_Error on error.
+
+ procedure Create_Socket_Pair
+ (Left : out Socket_Type;
+ Right : out Socket_Type;
+ Family : Family_Type := Family_Unspec;
+ Mode : Mode_Type := Socket_Stream;
+ Level : Level_Type := IP_Protocol_For_IP_Level);
+ -- Create two connected sockets. Raises Socket_Error on error.
+ -- If Family is unspecified, it creates Family_Unix sockets on UNIX and
+ -- Family_Inet sockets on non UNIX platforms.
procedure Accept_Socket
(Server : Socket_Type;
function C_System
(Command : System.Address) return C.int;
+ Default_Socket_Pair_Family : constant := SOSC.AF_UNIX;
+ -- UNIX has socketpair system call and AF_UNIX family is widely supported
+
+ function C_Socketpair
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int;
+ Fds : not null access Fd_Pair) return C.int;
+ -- Creates pair of connected sockets
+
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
pragma Import (C, C_Select, "select");
pragma Import (C, C_Setsockopt, "setsockopt");
pragma Import (C, C_Shutdown, "shutdown");
+ pragma Import (C, C_Socketpair, "socketpair");
pragma Import (C, C_System, "system");
pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname");
return System.CRTL.ssize_t (Count);
end C_Sendmsg;
+ ------------------
+ -- C_Socketpair --
+ ------------------
+
+ function C_Socketpair
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int;
+ Fds : not null access Fd_Pair) return C.int is separate;
+
--------------
-- Finalize --
--------------
Typ : C.int;
Protocol : C.int) return C.int;
+ Default_Socket_Pair_Family : constant := SOSC.AF_INET;
+ -- Windows has not socketpair system call, and C_Socketpair below is
+ -- implemented on loopback connected network sockets.
+
+ function C_Socketpair
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int;
+ Fds : not null access Fd_Pair) return C.int;
+ -- Creates pair of connected sockets
+
function C_System
(Command : System.Address) return C.int;
return R;
end C_Socket;
+ ------------------
+ -- C_Socketpair --
+ ------------------
+
+ function C_Socketpair
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int;
+ Fds : not null access Fd_Pair) return C.int is separate;
+
--------------
-- Finalize --
--------------
Typ : C.int;
Protocol : C.int) return C.int;
+ Default_Socket_Pair_Family : constant := SOSC.AF_INET;
+ -- VxWorks has not socketpair system call, and C_Socketpair below is
+ -- implemented on loopback connected network sockets.
+
+ function C_Socketpair
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int;
+ Fds : not null access Fd_Pair) return C.int;
+ -- Creates pair of connected sockets
+
function C_System
(Command : System.Address) return C.int;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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-2019, 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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
+ use type C.char_array;
+
+ 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;
+
+ <<Repeat>>
+ 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;
------------
function Create (Fds : not null access Fd_Pair) return C.int is
- L_Sock, R_Sock, W_Sock : C.int := Failure;
- -- Listening socket, read socket and write socket
-
- Sin : aliased Sockaddr;
- Len : aliased C.int;
- -- Address of listening socket
-
- Res : C.int;
- pragma Warnings (Off, Res);
- -- Return status of system calls (usually ignored, hence warnings off)
-
+ Res : constant C.int :=
+ C_Socketpair (SOSC.AF_INET, SOSC.SOCK_STREAM, 0, Fds);
begin
- Fds.all := (Read_End | Write_End => Failure);
-
- -- We open two signalling sockets. One of them is used to send data
- -- to the other, which is included in a C_Select socket set. The
- -- communication is used to force the call to C_Select to complete,
- -- and the waiting task to resume its execution.
-
- loop
- -- Retry loop, in case the C_Connect below fails
-
- -- Create a listening socket
-
- L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
-
- if L_Sock = Failure then
- goto Fail;
- end if;
-
- -- Bind the socket to an available port on localhost
-
- Set_Family (Sin.Sin_Family, Family_Inet);
- Sin.Sin_Addr.S_B1 := 127;
- Sin.Sin_Addr.S_B2 := 0;
- Sin.Sin_Addr.S_B3 := 0;
- Sin.Sin_Addr.S_B4 := 1;
- Sin.Sin_Port := 0;
-
- Len := C.int (Lengths (Family_Inet));
- Res := C_Bind (L_Sock, Sin'Address, Len);
-
- if Res = Failure then
- goto Fail;
- end if;
-
- -- Get assigned port
-
- Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
- if Res = Failure then
- goto Fail;
- end if;
-
- -- 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);
-
- if Res = Failure then
- goto Fail;
- end if;
-
- -- Create read end (client) socket
-
- R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
-
- if R_Sock = Failure then
- goto Fail;
- end if;
-
- -- Connect listening socket
-
- Res := C_Connect (R_Sock, Sin'Address, Len);
-
- exit when Res /= Failure;
-
- if Socket_Errno /= SOSC.EADDRINUSE then
- goto Fail;
- end if;
-
- -- 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.
-
- pragma Assert (Res = Failure
- and then
- Socket_Errno = SOSC.EADDRINUSE);
- Res := C_Close (W_Sock);
- W_Sock := Failure;
- Res := C_Close (R_Sock);
- R_Sock := Failure;
- end loop;
-
- -- 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.
-
- W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
-
- if W_Sock = Failure then
- goto Fail;
+ if Res /= Failure then
+ -- Set TCP_NODELAY on Fds (Write_End), since we always want to send
+ -- the data out immediately.
+
+ Set_Socket_Option
+ (Socket => Socket_Type (Fds (Write_End)),
+ Level => IP_Protocol_For_TCP_Level,
+ Option => (Name => No_Delay, Enabled => True));
end if;
- -- Set TCP_NODELAY on W_Sock, since we always want to send the data out
- -- immediately.
-
- Set_Socket_Option
- (Socket => Socket_Type (W_Sock),
- Level => IP_Protocol_For_TCP_Level,
- Option => (Name => No_Delay, Enabled => True));
-
- -- Close listening socket (ignore exit status)
-
- Res := C_Close (L_Sock);
-
- Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
-
- return Thin_Common.Success;
-
- <<Fail>>
- declare
- Saved_Errno : constant Integer := Socket_Errno;
-
- begin
- if W_Sock /= Failure then
- Res := C_Close (W_Sock);
- end if;
-
- if R_Sock /= Failure then
- Res := C_Close (R_Sock);
- end if;
-
- if L_Sock /= Failure then
- Res := C_Close (L_Sock);
- end if;
-
- Set_Socket_Errno (Saved_Errno);
- end;
-
- return Failure;
+ return Res;
end Create;
----------
projects / gcc.git / commitdiff