|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . S O C K E T S . T H I N --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 2001-2019, AdaCore --
|
|
111
|
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 -- This package provides a target dependent thin interface to the sockets
|
|
|
33 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
|
|
|
34 -- should not be directly with'ed by an applications program.
|
|
|
35
|
|
|
36 -- This is the default version
|
|
|
37
|
|
|
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
|
39 with GNAT.Task_Lock;
|
|
|
40
|
|
|
41 with Interfaces.C; use Interfaces.C;
|
|
|
42
|
|
|
43 package body GNAT.Sockets.Thin is
|
|
|
44
|
|
|
45 Non_Blocking_Sockets : aliased Fd_Set;
|
|
|
46 -- When this package is initialized with Process_Blocking_IO set
|
|
|
47 -- to True, sockets are set in non-blocking mode to avoid blocking
|
|
|
48 -- the whole process when a thread wants to perform a blocking IO
|
|
|
49 -- operation. But the user can also set a socket in non-blocking
|
|
|
50 -- mode by purpose. In order to make a difference between these
|
|
|
51 -- two situations, we track the origin of non-blocking mode in
|
|
|
52 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
|
|
|
53 -- been set in non-blocking mode by the user.
|
|
|
54
|
|
|
55 Quantum : constant Duration := 0.2;
|
|
|
56 -- When SOSC.Thread_Blocking_IO is False, we set sockets in
|
|
|
57 -- non-blocking mode and we spend a period of time Quantum between
|
|
|
58 -- two attempts on a blocking operation.
|
|
|
59
|
|
|
60 -- Comments required for following functions ???
|
|
|
61
|
|
|
62 function Syscall_Accept
|
|
|
63 (S : C.int;
|
|
|
64 Addr : System.Address;
|
|
|
65 Addrlen : not null access C.int) return C.int;
|
|
|
66 pragma Import (C, Syscall_Accept, "accept");
|
|
|
67
|
|
|
68 function Syscall_Connect
|
|
|
69 (S : C.int;
|
|
|
70 Name : System.Address;
|
|
|
71 Namelen : C.int) return C.int;
|
|
|
72 pragma Import (C, Syscall_Connect, "connect");
|
|
|
73
|
|
|
74 function Syscall_Recv
|
|
|
75 (S : C.int;
|
|
|
76 Msg : System.Address;
|
|
|
77 Len : C.int;
|
|
|
78 Flags : C.int) return C.int;
|
|
|
79 pragma Import (C, Syscall_Recv, "recv");
|
|
|
80
|
|
|
81 function Syscall_Recvfrom
|
|
|
82 (S : C.int;
|
|
|
83 Msg : System.Address;
|
|
|
84 Len : C.int;
|
|
|
85 Flags : C.int;
|
|
|
86 From : System.Address;
|
|
|
87 Fromlen : not null access C.int) return C.int;
|
|
|
88 pragma Import (C, Syscall_Recvfrom, "recvfrom");
|
|
|
89
|
|
|
90 function Syscall_Recvmsg
|
|
|
91 (S : C.int;
|
|
|
92 Msg : System.Address;
|
|
|
93 Flags : C.int) return System.CRTL.ssize_t;
|
|
|
94 pragma Import (C, Syscall_Recvmsg, "recvmsg");
|
|
|
95
|
|
|
96 function Syscall_Sendmsg
|
|
|
97 (S : C.int;
|
|
|
98 Msg : System.Address;
|
|
|
99 Flags : C.int) return System.CRTL.ssize_t;
|
|
|
100 pragma Import (C, Syscall_Sendmsg, "sendmsg");
|
|
|
101
|
|
|
102 function Syscall_Sendto
|
|
|
103 (S : C.int;
|
|
|
104 Msg : System.Address;
|
|
|
105 Len : C.int;
|
|
|
106 Flags : C.int;
|
|
|
107 To : System.Address;
|
|
|
108 Tolen : C.int) return C.int;
|
|
|
109 pragma Import (C, Syscall_Sendto, "sendto");
|
|
|
110
|
|
|
111 function Syscall_Socket
|
|
|
112 (Domain : C.int;
|
|
|
113 Typ : C.int;
|
|
|
114 Protocol : C.int) return C.int;
|
|
|
115 pragma Import (C, Syscall_Socket, "socket");
|
|
|
116
|
|
|
117 procedure Disable_SIGPIPE (S : C.int);
|
|
|
118 pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
|
|
|
119
|
|
|
120 procedure Disable_All_SIGPIPEs;
|
|
|
121 pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
|
|
|
122 -- Sets the process to ignore all SIGPIPE signals on platforms that
|
|
|
123 -- don't support Disable_SIGPIPE for particular streams.
|
|
|
124
|
|
|
125 function Non_Blocking_Socket (S : C.int) return Boolean;
|
|
|
126 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
|
|
|
127
|
|
|
128 --------------
|
|
|
129 -- C_Accept --
|
|
|
130 --------------
|
|
|
131
|
|
|
132 function C_Accept
|
|
|
133 (S : C.int;
|
|
|
134 Addr : System.Address;
|
|
|
135 Addrlen : not null access C.int) return C.int
|
|
|
136 is
|
|
|
137 R : C.int;
|
|
|
138 Val : aliased C.int := 1;
|
|
|
139
|
|
|
140 Discard : C.int;
|
|
|
141 pragma Warnings (Off, Discard);
|
|
|
142
|
|
|
143 begin
|
|
|
144 loop
|
|
|
145 R := Syscall_Accept (S, Addr, Addrlen);
|
|
|
146 exit when SOSC.Thread_Blocking_IO
|
|
|
147 or else R /= Failure
|
|
|
148 or else Non_Blocking_Socket (S)
|
|
|
149 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
150 delay Quantum;
|
|
|
151 end loop;
|
|
|
152
|
|
|
153 if not SOSC.Thread_Blocking_IO
|
|
|
154 and then R /= Failure
|
|
|
155 then
|
|
|
156 -- A socket inherits the properties ot its server especially
|
|
|
157 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
|
|
|
158 -- tracks sockets set in non-blocking mode by user.
|
|
|
159
|
|
|
160 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
|
|
|
161 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
|
|
|
162 end if;
|
|
|
163
|
|
|
164 Disable_SIGPIPE (R);
|
|
|
165 return R;
|
|
|
166 end C_Accept;
|
|
|
167
|
|
|
168 ---------------
|
|
|
169 -- C_Connect --
|
|
|
170 ---------------
|
|
|
171
|
|
|
172 function C_Connect
|
|
|
173 (S : C.int;
|
|
|
174 Name : System.Address;
|
|
|
175 Namelen : C.int) return C.int
|
|
|
176 is
|
|
|
177 Res : C.int;
|
|
|
178
|
|
|
179 begin
|
|
|
180 Res := Syscall_Connect (S, Name, Namelen);
|
|
|
181
|
|
|
182 if SOSC.Thread_Blocking_IO
|
|
|
183 or else Res /= Failure
|
|
|
184 or else Non_Blocking_Socket (S)
|
|
|
185 or else Errno /= SOSC.EINPROGRESS
|
|
|
186 then
|
|
|
187 return Res;
|
|
|
188 end if;
|
|
|
189
|
|
|
190 declare
|
|
|
191 WSet : aliased Fd_Set;
|
|
|
192 Now : aliased Timeval;
|
|
|
193
|
|
|
194 begin
|
|
|
195 Reset_Socket_Set (WSet'Access);
|
|
|
196 loop
|
|
|
197 Insert_Socket_In_Set (WSet'Access, S);
|
|
|
198 Now := Immediat;
|
|
|
199 Res := C_Select
|
|
|
200 (S + 1,
|
|
|
201 No_Fd_Set_Access,
|
|
|
202 WSet'Access,
|
|
|
203 No_Fd_Set_Access,
|
|
|
204 Now'Unchecked_Access);
|
|
|
205
|
|
|
206 exit when Res > 0;
|
|
|
207
|
|
|
208 if Res = Failure then
|
|
|
209 return Res;
|
|
|
210 end if;
|
|
|
211
|
|
|
212 delay Quantum;
|
|
|
213 end loop;
|
|
|
214 end;
|
|
|
215
|
|
|
216 Res := Syscall_Connect (S, Name, Namelen);
|
|
|
217
|
|
|
218 if Res = Failure
|
|
|
219 and then Errno = SOSC.EISCONN
|
|
|
220 then
|
|
|
221 return Thin_Common.Success;
|
|
|
222 else
|
|
|
223 return Res;
|
|
|
224 end if;
|
|
|
225 end C_Connect;
|
|
|
226
|
|
|
227 ------------------
|
|
|
228 -- Socket_Ioctl --
|
|
|
229 ------------------
|
|
|
230
|
|
|
231 function Socket_Ioctl
|
|
|
232 (S : C.int;
|
|
|
233 Req : SOSC.IOCTL_Req_T;
|
|
|
234 Arg : access C.int) return C.int
|
|
|
235 is
|
|
|
236 begin
|
|
|
237 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
|
|
|
238 if Arg.all /= 0 then
|
|
|
239 Set_Non_Blocking_Socket (S, True);
|
|
|
240 end if;
|
|
|
241 end if;
|
|
|
242
|
|
|
243 return C_Ioctl (S, Req, Arg);
|
|
|
244 end Socket_Ioctl;
|
|
|
245
|
|
|
246 ------------
|
|
|
247 -- C_Recv --
|
|
|
248 ------------
|
|
|
249
|
|
|
250 function C_Recv
|
|
|
251 (S : C.int;
|
|
|
252 Msg : System.Address;
|
|
|
253 Len : C.int;
|
|
|
254 Flags : C.int) return C.int
|
|
|
255 is
|
|
|
256 Res : C.int;
|
|
|
257
|
|
|
258 begin
|
|
|
259 loop
|
|
|
260 Res := Syscall_Recv (S, Msg, Len, Flags);
|
|
|
261 exit when SOSC.Thread_Blocking_IO
|
|
|
262 or else Res /= Failure
|
|
|
263 or else Non_Blocking_Socket (S)
|
|
|
264 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
265 delay Quantum;
|
|
|
266 end loop;
|
|
|
267
|
|
|
268 return Res;
|
|
|
269 end C_Recv;
|
|
|
270
|
|
|
271 ----------------
|
|
|
272 -- C_Recvfrom --
|
|
|
273 ----------------
|
|
|
274
|
|
|
275 function C_Recvfrom
|
|
|
276 (S : C.int;
|
|
|
277 Msg : System.Address;
|
|
|
278 Len : C.int;
|
|
|
279 Flags : C.int;
|
|
|
280 From : System.Address;
|
|
|
281 Fromlen : not null access C.int) return C.int
|
|
|
282 is
|
|
|
283 Res : C.int;
|
|
|
284
|
|
|
285 begin
|
|
|
286 loop
|
|
|
287 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
|
|
|
288 exit when SOSC.Thread_Blocking_IO
|
|
|
289 or else Res /= Failure
|
|
|
290 or else Non_Blocking_Socket (S)
|
|
|
291 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
292 delay Quantum;
|
|
|
293 end loop;
|
|
|
294
|
|
|
295 return Res;
|
|
|
296 end C_Recvfrom;
|
|
|
297
|
|
|
298 ---------------
|
|
|
299 -- C_Recvmsg --
|
|
|
300 ---------------
|
|
|
301
|
|
|
302 function C_Recvmsg
|
|
|
303 (S : C.int;
|
|
|
304 Msg : System.Address;
|
|
|
305 Flags : C.int) return System.CRTL.ssize_t
|
|
|
306 is
|
|
|
307 Res : System.CRTL.ssize_t;
|
|
|
308
|
|
|
309 begin
|
|
|
310 loop
|
|
|
311 Res := Syscall_Recvmsg (S, Msg, Flags);
|
|
|
312 exit when SOSC.Thread_Blocking_IO
|
|
|
313 or else Res /= System.CRTL.ssize_t (Failure)
|
|
|
314 or else Non_Blocking_Socket (S)
|
|
|
315 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
316 delay Quantum;
|
|
|
317 end loop;
|
|
|
318
|
|
|
319 return Res;
|
|
|
320 end C_Recvmsg;
|
|
|
321
|
|
|
322 ---------------
|
|
|
323 -- C_Sendmsg --
|
|
|
324 ---------------
|
|
|
325
|
|
|
326 function C_Sendmsg
|
|
|
327 (S : C.int;
|
|
|
328 Msg : System.Address;
|
|
|
329 Flags : C.int) return System.CRTL.ssize_t
|
|
|
330 is
|
|
|
331 Res : System.CRTL.ssize_t;
|
|
|
332
|
|
|
333 begin
|
|
|
334 loop
|
|
|
335 Res := Syscall_Sendmsg (S, Msg, Flags);
|
|
|
336 exit when SOSC.Thread_Blocking_IO
|
|
|
337 or else Res /= System.CRTL.ssize_t (Failure)
|
|
|
338 or else Non_Blocking_Socket (S)
|
|
|
339 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
340 delay Quantum;
|
|
|
341 end loop;
|
|
|
342
|
|
|
343 return Res;
|
|
|
344 end C_Sendmsg;
|
|
|
345
|
|
|
346 --------------
|
|
|
347 -- C_Sendto --
|
|
|
348 --------------
|
|
|
349
|
|
|
350 function C_Sendto
|
|
|
351 (S : C.int;
|
|
|
352 Msg : System.Address;
|
|
|
353 Len : C.int;
|
|
|
354 Flags : C.int;
|
|
|
355 To : System.Address;
|
|
|
356 Tolen : C.int) return C.int
|
|
|
357 is
|
|
|
358 Res : C.int;
|
|
|
359
|
|
|
360 begin
|
|
|
361 loop
|
|
|
362 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
|
|
|
363 exit when SOSC.Thread_Blocking_IO
|
|
|
364 or else Res /= Failure
|
|
|
365 or else Non_Blocking_Socket (S)
|
|
|
366 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
367 delay Quantum;
|
|
|
368 end loop;
|
|
|
369
|
|
|
370 return Res;
|
|
|
371 end C_Sendto;
|
|
|
372
|
|
|
373 --------------
|
|
|
374 -- C_Socket --
|
|
|
375 --------------
|
|
|
376
|
|
|
377 function C_Socket
|
|
|
378 (Domain : C.int;
|
|
|
379 Typ : C.int;
|
|
|
380 Protocol : C.int) return C.int
|
|
|
381 is
|
|
|
382 R : C.int;
|
|
|
383 Val : aliased C.int := 1;
|
|
|
384
|
|
|
385 Discard : C.int;
|
|
|
386
|
|
|
387 begin
|
|
|
388 R := Syscall_Socket (Domain, Typ, Protocol);
|
|
|
389
|
|
|
390 if not SOSC.Thread_Blocking_IO
|
|
|
391 and then R /= Failure
|
|
|
392 then
|
|
|
393 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
|
|
|
394 -- in non-blocking mode by user.
|
|
|
395
|
|
|
396 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
|
|
|
397 Set_Non_Blocking_Socket (R, False);
|
|
|
398 end if;
|
|
|
399 Disable_SIGPIPE (R);
|
|
|
400 return R;
|
|
|
401 end C_Socket;
|
|
|
402
|
|
|
403 --------------
|
|
|
404 -- Finalize --
|
|
|
405 --------------
|
|
|
406
|
|
|
407 procedure Finalize is
|
|
|
408 begin
|
|
|
409 null;
|
|
|
410 end Finalize;
|
|
|
411
|
|
|
412 -------------------------
|
|
|
413 -- Host_Error_Messages --
|
|
|
414 -------------------------
|
|
|
415
|
|
|
416 package body Host_Error_Messages is separate;
|
|
|
417
|
|
|
418 ----------------
|
|
|
419 -- Initialize --
|
|
|
420 ----------------
|
|
|
421
|
|
|
422 procedure Initialize is
|
|
|
423 begin
|
|
|
424 Disable_All_SIGPIPEs;
|
|
|
425 Reset_Socket_Set (Non_Blocking_Sockets'Access);
|
|
|
426 end Initialize;
|
|
|
427
|
|
|
428 -------------------------
|
|
|
429 -- Non_Blocking_Socket --
|
|
|
430 -------------------------
|
|
|
431
|
|
|
432 function Non_Blocking_Socket (S : C.int) return Boolean is
|
|
|
433 R : Boolean;
|
|
|
434 begin
|
|
|
435 Task_Lock.Lock;
|
|
|
436 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
|
|
|
437 Task_Lock.Unlock;
|
|
|
438 return R;
|
|
|
439 end Non_Blocking_Socket;
|
|
|
440
|
|
|
441 -----------------------------
|
|
|
442 -- Set_Non_Blocking_Socket --
|
|
|
443 -----------------------------
|
|
|
444
|
|
|
445 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
|
|
|
446 begin
|
|
|
447 Task_Lock.Lock;
|
|
|
448
|
|
|
449 if V then
|
|
|
450 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
|
|
|
451 else
|
|
|
452 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
|
|
|
453 end if;
|
|
|
454
|
|
|
455 Task_Lock.Unlock;
|
|
|
456 end Set_Non_Blocking_Socket;
|
|
|
457
|
|
|
458 --------------------
|
|
|
459 -- Signalling_Fds --
|
|
|
460 --------------------
|
|
|
461
|
|
|
462 package body Signalling_Fds is
|
|
|
463
|
|
|
464 -- In this default implementation, we use a C version of these
|
|
|
465 -- subprograms provided by socket.c.
|
|
|
466
|
|
|
467 function C_Create (Fds : not null access Fd_Pair) return C.int;
|
|
|
468 function C_Read (Rsig : C.int) return C.int;
|
|
|
469 function C_Write (Wsig : C.int) return C.int;
|
|
|
470 procedure C_Close (Sig : C.int);
|
|
|
471
|
|
|
472 pragma Import (C, C_Create, "__gnat_create_signalling_fds");
|
|
|
473 pragma Import (C, C_Read, "__gnat_read_signalling_fd");
|
|
|
474 pragma Import (C, C_Write, "__gnat_write_signalling_fd");
|
|
|
475 pragma Import (C, C_Close, "__gnat_close_signalling_fd");
|
|
|
476
|
|
|
477 function Create
|
|
|
478 (Fds : not null access Fd_Pair) return C.int renames C_Create;
|
|
|
479 function Read (Rsig : C.int) return C.int renames C_Read;
|
|
|
480 function Write (Wsig : C.int) return C.int renames C_Write;
|
|
|
481 procedure Close (Sig : C.int) renames C_Close;
|
|
|
482
|
|
|
483 end Signalling_Fds;
|
|
|
484
|
|
|
485 --------------------------
|
|
|
486 -- Socket_Error_Message --
|
|
|
487 --------------------------
|
|
|
488
|
|
|
489 function Socket_Error_Message (Errno : Integer) return String is separate;
|
|
|
490
|
|
|
491 end GNAT.Sockets.Thin;
|
