]>
Commit | Line | Data |
---|---|---|
fd0d7b4e DA |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- 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 -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 2001-2020, AdaCore -- |
fd0d7b4e DA |
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 3, 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. -- | |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
21 | -- -- | |
22 | -- You should have received a copy of the GNU General Public License and -- | |
23 | -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 | -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 | -- <http://www.gnu.org/licenses/>. -- | |
26 | -- -- | |
27 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 | -- -- | |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | -- Portable sockets-based implementation of the C_Socketpair used for | |
33 | -- platforms that do not support UNIX socketpair system call. | |
34 | ||
35 | -- Note: this code is only for non-UNIX platforms. | |
36 | ||
37 | separate (GNAT.Sockets.Thin) | |
38 | function C_Socketpair | |
39 | (Domain : C.int; | |
40 | Typ : C.int; | |
41 | Protocol : C.int; | |
42 | Fds : not null access Fd_Pair) return C.int | |
43 | is | |
44 | use type C.char_array; | |
45 | ||
46 | L_Sock, C_Sock, P_Sock : C.int := Failure; | |
47 | -- Listening socket, client socket and peer socket | |
48 | ||
49 | Family : constant Family_Type := | |
50 | (case Domain is | |
51 | when SOSC.AF_INET => Family_Inet, | |
52 | when SOSC.AF_INET6 => Family_Inet6, | |
53 | when others => Family_Unspec); | |
54 | ||
55 | Len : aliased C.int := C.int (Lengths (Family)); | |
56 | ||
57 | C_Sin : aliased Sockaddr; | |
58 | C_Bin : aliased C.char_array (1 .. C.size_t (Len)); | |
59 | for C_Bin'Address use C_Sin'Address; | |
60 | -- Address of listening and client socket and it's binary representation. | |
61 | -- We need binary representation because Ada does not allow to compare | |
62 | -- unchecked union if either of the operands lacks inferable discriminants. | |
63 | -- RM-B-3-3 23/2. | |
64 | ||
65 | P_Sin : aliased Sockaddr; | |
66 | P_Bin : aliased C.char_array (1 .. C.size_t (Len)); | |
67 | for P_Bin'Address use P_Sin'Address; | |
68 | -- Address of peer socket and it's binary representation | |
69 | ||
70 | T_Sin : aliased Sockaddr; | |
71 | T_Bin : aliased C.char_array (1 .. C.size_t (Len)); | |
72 | for T_Bin'Address use T_Sin'Address; | |
73 | -- Temporary address to compare and check that address and port of the | |
74 | -- socket equal to peer address and port of the opposite connected socket. | |
75 | ||
76 | Res : C.int with Warnings => Off; | |
77 | ||
78 | begin | |
79 | Set_Family (C_Sin.Sin_Family, Family); | |
80 | ||
81 | case Family is | |
82 | when Family_Inet => | |
83 | C_Sin.Sin_Addr.S_B1 := 127; | |
84 | C_Sin.Sin_Addr.S_B4 := 1; | |
85 | ||
86 | when Family_Inet6 => | |
87 | C_Sin.Sin6_Addr (C_Sin.Sin6_Addr'Last) := 1; | |
88 | ||
89 | when others => | |
90 | Set_Socket_Errno (SOSC.EAFNOSUPPORT); | |
91 | return Failure; | |
92 | end case; | |
93 | ||
94 | for J in 1 .. 10 loop | |
95 | -- Retry loop, in case the C_Connect below fails | |
96 | ||
97 | C_Sin.Sin_Port := 0; | |
98 | ||
99 | -- Create a listening socket | |
100 | ||
101 | L_Sock := C_Socket (Domain, Typ, Protocol); | |
102 | exit when L_Sock = Failure; | |
103 | ||
104 | -- Bind the socket to an available port on localhost | |
105 | ||
106 | Res := C_Bind (L_Sock, C_Sin'Address, Len); | |
107 | exit when Res = Failure; | |
108 | ||
109 | -- Get assigned port | |
110 | ||
111 | Res := C_Getsockname (L_Sock, C_Sin'Address, Len'Access); | |
112 | exit when Res = Failure; | |
113 | ||
114 | -- Set socket to listen mode, with a backlog of 1 to guarantee that | |
115 | -- exactly one call to connect(2) succeeds. | |
116 | ||
117 | Res := C_Listen (L_Sock, 1); | |
118 | exit when Res = Failure; | |
119 | ||
120 | -- Create read end (client) socket | |
121 | ||
122 | C_Sock := C_Socket (Domain, Typ, Protocol); | |
123 | exit when C_Sock = Failure; | |
124 | ||
125 | -- Connect listening socket | |
126 | ||
127 | Res := C_Connect (C_Sock, C_Sin'Address, Len); | |
128 | ||
129 | if Res = Failure then | |
130 | -- In rare cases, the above C_Bind chooses a port that is still | |
131 | -- marked "in use", even though it has been closed (perhaps by some | |
132 | -- other process that has already exited). This causes the above | |
133 | -- C_Connect to fail with EADDRINUSE. In this case, we close the | |
134 | -- ports, and loop back to try again. This mysterious Windows | |
135 | -- behavior is documented. See, for example: | |
136 | -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx | |
137 | -- In an experiment with 2000 calls, 21 required exactly one retry, 7 | |
138 | -- required two, and none required three or more. Note that no delay | |
139 | -- is needed between retries; retrying C_Bind will typically produce | |
140 | -- a different port. | |
141 | ||
142 | exit when Socket_Errno /= SOSC.EADDRINUSE; | |
143 | ||
144 | goto Repeat; | |
145 | end if; | |
146 | ||
147 | -- Since the call to connect(2) has succeeded and the backlog limit | |
148 | -- on the listening socket is 1, we know that there is now exactly | |
149 | -- one pending connection on L_Sock, which is the one from R_Sock. | |
150 | ||
151 | P_Sin.Sun_Path := (others => C.nul); | |
152 | ||
153 | P_Sock := C_Accept (L_Sock, P_Sin'Address, Len'Access); | |
154 | exit when P_Sock = Failure; | |
155 | ||
156 | -- Address and port of the socket equal to peer address and port of the | |
157 | -- opposite connected socket. | |
158 | ||
159 | Res := C_Getsockname (P_Sock, T_Sin'Address, Len'Access); | |
160 | exit when Res = Failure; | |
161 | ||
162 | if T_Bin /= C_Bin then | |
163 | goto Repeat; | |
164 | end if; | |
165 | ||
166 | -- Address and port of the socket equal to peer address and port of the | |
167 | -- opposite connected socket. | |
168 | ||
169 | Res := C_Getsockname (C_Sock, T_Sin'Address, Len'Access); | |
170 | exit when Res = Failure; | |
171 | ||
172 | if T_Bin /= P_Bin then | |
173 | goto Repeat; | |
174 | end if; | |
175 | ||
176 | -- Close listening socket (ignore exit status) | |
177 | ||
178 | Res := C_Close (L_Sock); | |
179 | ||
180 | Fds.all := (Read_End => C_Sock, Write_End => P_Sock); | |
181 | ||
182 | return Thin_Common.Success; | |
183 | ||
184 | <<Repeat>> | |
185 | Res := C_Close (C_Sock); | |
186 | C_Sock := Failure; | |
187 | Res := C_Close (P_Sock); | |
188 | P_Sock := Failure; | |
189 | Res := C_Close (L_Sock); | |
190 | L_Sock := Failure; | |
191 | end loop; | |
192 | ||
193 | declare | |
194 | Saved_Errno : constant Integer := Socket_Errno; | |
195 | ||
196 | begin | |
197 | if P_Sock /= Failure then | |
198 | Res := C_Close (P_Sock); | |
199 | end if; | |
200 | ||
201 | if C_Sock /= Failure then | |
202 | Res := C_Close (C_Sock); | |
203 | end if; | |
204 | ||
205 | if L_Sock /= Failure then | |
206 | Res := C_Close (L_Sock); | |
207 | end if; | |
208 | ||
209 | Set_Socket_Errno (Saved_Errno); | |
210 | end; | |
211 | ||
212 | return Failure; | |
213 | end C_Socketpair; |