File : g-socthi.adb
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 -- --
9 -- Copyright (C) 2001-2014, 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 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 -- --
19 -- --
20 -- --
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;