|
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 -- --
|
|
131
|
9 -- Copyright (C) 2002-2018, 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 version is for VxWorks
|
|
|
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 -----------------------
|
|
|
61 -- Local Subprograms --
|
|
|
62 -----------------------
|
|
|
63
|
|
|
64 -- All these require comments ???
|
|
|
65
|
|
|
66 function Syscall_Accept
|
|
|
67 (S : C.int;
|
|
|
68 Addr : System.Address;
|
|
|
69 Addrlen : not null access C.int) return C.int;
|
|
|
70 pragma Import (C, Syscall_Accept, "accept");
|
|
|
71
|
|
|
72 function Syscall_Connect
|
|
|
73 (S : C.int;
|
|
|
74 Name : System.Address;
|
|
|
75 Namelen : C.int) return C.int;
|
|
|
76 pragma Import (C, Syscall_Connect, "connect");
|
|
|
77
|
|
|
78 function Syscall_Recv
|
|
|
79 (S : C.int;
|
|
|
80 Msg : System.Address;
|
|
|
81 Len : C.int;
|
|
|
82 Flags : C.int) return C.int;
|
|
|
83 pragma Import (C, Syscall_Recv, "recv");
|
|
|
84
|
|
|
85 function Syscall_Recvfrom
|
|
|
86 (S : C.int;
|
|
|
87 Msg : System.Address;
|
|
|
88 Len : C.int;
|
|
|
89 Flags : C.int;
|
|
|
90 From : System.Address;
|
|
|
91 Fromlen : not null access C.int) return C.int;
|
|
|
92 pragma Import (C, Syscall_Recvfrom, "recvfrom");
|
|
|
93
|
|
|
94 function Syscall_Recvmsg
|
|
|
95 (S : C.int;
|
|
|
96 Msg : System.Address;
|
|
|
97 Flags : C.int) return C.int;
|
|
|
98 pragma Import (C, Syscall_Recvmsg, "recvmsg");
|
|
|
99
|
|
|
100 function Syscall_Sendmsg
|
|
|
101 (S : C.int;
|
|
|
102 Msg : System.Address;
|
|
|
103 Flags : C.int) return C.int;
|
|
|
104 pragma Import (C, Syscall_Sendmsg, "sendmsg");
|
|
|
105
|
|
|
106 function Syscall_Send
|
|
|
107 (S : C.int;
|
|
|
108 Msg : System.Address;
|
|
|
109 Len : C.int;
|
|
|
110 Flags : C.int) return C.int;
|
|
|
111 pragma Import (C, Syscall_Send, "send");
|
|
|
112
|
|
|
113 function Syscall_Sendto
|
|
|
114 (S : C.int;
|
|
|
115 Msg : System.Address;
|
|
|
116 Len : C.int;
|
|
|
117 Flags : C.int;
|
|
|
118 To : System.Address;
|
|
|
119 Tolen : C.int) return C.int;
|
|
|
120 pragma Import (C, Syscall_Sendto, "sendto");
|
|
|
121
|
|
|
122 function Syscall_Socket
|
|
|
123 (Domain : C.int;
|
|
|
124 Typ : C.int;
|
|
|
125 Protocol : C.int) return C.int;
|
|
|
126 pragma Import (C, Syscall_Socket, "socket");
|
|
|
127
|
|
|
128 function Non_Blocking_Socket (S : C.int) return Boolean;
|
|
|
129 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
|
|
|
130
|
|
|
131 --------------
|
|
|
132 -- C_Accept --
|
|
|
133 --------------
|
|
|
134
|
|
|
135 function C_Accept
|
|
|
136 (S : C.int;
|
|
|
137 Addr : System.Address;
|
|
|
138 Addrlen : not null access C.int) return C.int
|
|
|
139 is
|
|
|
140 R : C.int;
|
|
|
141 Val : aliased C.int := 1;
|
|
|
142
|
|
|
143 Res : C.int;
|
|
|
144 pragma Unreferenced (Res);
|
|
|
145
|
|
|
146 begin
|
|
|
147 loop
|
|
|
148 R := Syscall_Accept (S, Addr, Addrlen);
|
|
|
149 exit when SOSC.Thread_Blocking_IO
|
|
|
150 or else R /= Failure
|
|
|
151 or else Non_Blocking_Socket (S)
|
|
|
152 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
153 delay Quantum;
|
|
|
154 end loop;
|
|
|
155
|
|
|
156 if not SOSC.Thread_Blocking_IO
|
|
|
157 and then R /= Failure
|
|
|
158 then
|
|
|
159 -- A socket inherits the properties of its server especially
|
|
|
160 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
|
|
|
161 -- tracks sockets set in non-blocking mode by user.
|
|
|
162
|
|
|
163 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
|
|
|
164 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
|
|
|
165 -- Is it OK to ignore result ???
|
|
|
166 end if;
|
|
|
167
|
|
|
168 return R;
|
|
|
169 end C_Accept;
|
|
|
170
|
|
|
171 ---------------
|
|
|
172 -- C_Connect --
|
|
|
173 ---------------
|
|
|
174
|
|
|
175 function C_Connect
|
|
|
176 (S : C.int;
|
|
|
177 Name : System.Address;
|
|
|
178 Namelen : C.int) return C.int
|
|
|
179 is
|
|
|
180 Res : C.int;
|
|
|
181
|
|
|
182 begin
|
|
|
183 Res := Syscall_Connect (S, Name, Namelen);
|
|
|
184
|
|
|
185 if SOSC.Thread_Blocking_IO
|
|
|
186 or else Res /= Failure
|
|
|
187 or else Non_Blocking_Socket (S)
|
|
|
188 or else Errno /= SOSC.EINPROGRESS
|
|
|
189 then
|
|
|
190 return Res;
|
|
|
191 end if;
|
|
|
192
|
|
|
193 declare
|
|
|
194 WSet : aliased Fd_Set;
|
|
|
195 Now : aliased Timeval;
|
|
|
196 begin
|
|
|
197 Reset_Socket_Set (WSet'Access);
|
|
|
198 loop
|
|
|
199 Insert_Socket_In_Set (WSet'Access, S);
|
|
|
200 Now := Immediat;
|
|
|
201 Res := C_Select
|
|
|
202 (S + 1,
|
|
|
203 No_Fd_Set_Access,
|
|
|
204 WSet'Access,
|
|
|
205 No_Fd_Set_Access,
|
|
|
206 Now'Unchecked_Access);
|
|
|
207
|
|
|
208 exit when Res > 0;
|
|
|
209
|
|
|
210 if Res = Failure then
|
|
|
211 return Res;
|
|
|
212 end if;
|
|
|
213
|
|
|
214 delay Quantum;
|
|
|
215 end loop;
|
|
|
216 end;
|
|
|
217
|
|
|
218 Res := Syscall_Connect (S, Name, Namelen);
|
|
|
219
|
|
|
220 if Res = Failure
|
|
|
221 and then Errno = SOSC.EISCONN
|
|
|
222 then
|
|
|
223 return Thin_Common.Success;
|
|
|
224 else
|
|
|
225 return Res;
|
|
|
226 end if;
|
|
|
227 end C_Connect;
|
|
|
228
|
|
|
229 ------------------
|
|
|
230 -- Socket_Ioctl --
|
|
|
231 ------------------
|
|
|
232
|
|
|
233 function Socket_Ioctl
|
|
|
234 (S : C.int;
|
|
|
235 Req : SOSC.IOCTL_Req_T;
|
|
|
236 Arg : access C.int) return C.int
|
|
|
237 is
|
|
|
238 begin
|
|
|
239 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
|
|
|
240 if Arg.all /= 0 then
|
|
|
241 Set_Non_Blocking_Socket (S, True);
|
|
|
242 end if;
|
|
|
243 end if;
|
|
|
244
|
|
|
245 return C_Ioctl (S, Req, Arg);
|
|
|
246 end Socket_Ioctl;
|
|
|
247
|
|
|
248 ------------
|
|
|
249 -- C_Recv --
|
|
|
250 ------------
|
|
|
251
|
|
|
252 function C_Recv
|
|
|
253 (S : C.int;
|
|
|
254 Msg : System.Address;
|
|
|
255 Len : C.int;
|
|
|
256 Flags : C.int) return C.int
|
|
|
257 is
|
|
|
258 Res : C.int;
|
|
|
259
|
|
|
260 begin
|
|
|
261 loop
|
|
|
262 Res := Syscall_Recv (S, Msg, Len, Flags);
|
|
|
263 exit when SOSC.Thread_Blocking_IO
|
|
|
264 or else Res /= Failure
|
|
|
265 or else Non_Blocking_Socket (S)
|
|
|
266 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
267 delay Quantum;
|
|
|
268 end loop;
|
|
|
269
|
|
|
270 return Res;
|
|
|
271 end C_Recv;
|
|
|
272
|
|
|
273 ----------------
|
|
|
274 -- C_Recvfrom --
|
|
|
275 ----------------
|
|
|
276
|
|
|
277 function C_Recvfrom
|
|
|
278 (S : C.int;
|
|
|
279 Msg : System.Address;
|
|
|
280 Len : C.int;
|
|
|
281 Flags : C.int;
|
|
|
282 From : System.Address;
|
|
|
283 Fromlen : not null access C.int) return C.int
|
|
|
284 is
|
|
|
285 Res : C.int;
|
|
|
286
|
|
|
287 begin
|
|
|
288 loop
|
|
|
289 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
|
|
|
290 exit when SOSC.Thread_Blocking_IO
|
|
|
291 or else Res /= Failure
|
|
|
292 or else Non_Blocking_Socket (S)
|
|
|
293 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
294 delay Quantum;
|
|
|
295 end loop;
|
|
|
296
|
|
|
297 return Res;
|
|
|
298 end C_Recvfrom;
|
|
|
299
|
|
|
300 ---------------
|
|
|
301 -- C_Recvmsg --
|
|
|
302 ---------------
|
|
|
303
|
|
|
304 function C_Recvmsg
|
|
|
305 (S : C.int;
|
|
|
306 Msg : System.Address;
|
|
|
307 Flags : C.int) return System.CRTL.ssize_t
|
|
|
308 is
|
|
|
309 Res : C.int;
|
|
|
310
|
|
|
311 begin
|
|
|
312 loop
|
|
|
313 Res := Syscall_Recvmsg (S, Msg, Flags);
|
|
|
314 exit when SOSC.Thread_Blocking_IO
|
|
|
315 or else Res /= Failure
|
|
|
316 or else Non_Blocking_Socket (S)
|
|
|
317 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
318 delay Quantum;
|
|
|
319 end loop;
|
|
|
320
|
|
|
321 return System.CRTL.ssize_t (Res);
|
|
|
322 end C_Recvmsg;
|
|
|
323
|
|
|
324 ---------------
|
|
|
325 -- C_Sendmsg --
|
|
|
326 ---------------
|
|
|
327
|
|
|
328 function C_Sendmsg
|
|
|
329 (S : C.int;
|
|
|
330 Msg : System.Address;
|
|
|
331 Flags : C.int) return System.CRTL.ssize_t
|
|
|
332 is
|
|
|
333 Res : C.int;
|
|
|
334
|
|
|
335 begin
|
|
|
336 loop
|
|
|
337 Res := Syscall_Sendmsg (S, Msg, Flags);
|
|
|
338 exit when SOSC.Thread_Blocking_IO
|
|
|
339 or else Res /= Failure
|
|
|
340 or else Non_Blocking_Socket (S)
|
|
|
341 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
342 delay Quantum;
|
|
|
343 end loop;
|
|
|
344
|
|
|
345 return System.CRTL.ssize_t (Res);
|
|
|
346 end C_Sendmsg;
|
|
|
347
|
|
|
348 --------------
|
|
|
349 -- C_Sendto --
|
|
|
350 --------------
|
|
|
351
|
|
|
352 function C_Sendto
|
|
|
353 (S : C.int;
|
|
|
354 Msg : System.Address;
|
|
|
355 Len : C.int;
|
|
|
356 Flags : C.int;
|
|
|
357 To : System.Address;
|
|
|
358 Tolen : C.int) return C.int
|
|
|
359 is
|
|
|
360 use System;
|
|
|
361
|
|
|
362 Res : C.int;
|
|
|
363
|
|
|
364 begin
|
|
|
365 loop
|
|
|
366 if To = Null_Address then
|
|
|
367
|
|
|
368 -- In violation of the standard sockets API, VxWorks does not
|
|
|
369 -- support sendto(2) calls on connected sockets with a null
|
|
|
370 -- destination address, so use send(2) instead in that case.
|
|
|
371
|
|
|
372 Res := Syscall_Send (S, Msg, Len, Flags);
|
|
|
373
|
|
|
374 -- Normal case where destination address is non-null
|
|
|
375
|
|
|
376 else
|
|
|
377 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
|
|
|
378 end if;
|
|
|
379
|
|
|
380 exit when SOSC.Thread_Blocking_IO
|
|
|
381 or else Res /= Failure
|
|
|
382 or else Non_Blocking_Socket (S)
|
|
|
383 or else Errno /= SOSC.EWOULDBLOCK;
|
|
|
384 delay Quantum;
|
|
|
385 end loop;
|
|
|
386
|
|
|
387 return Res;
|
|
|
388 end C_Sendto;
|
|
|
389
|
|
|
390 --------------
|
|
|
391 -- C_Socket --
|
|
|
392 --------------
|
|
|
393
|
|
|
394 function C_Socket
|
|
|
395 (Domain : C.int;
|
|
|
396 Typ : C.int;
|
|
|
397 Protocol : C.int) return C.int
|
|
|
398 is
|
|
|
399 R : C.int;
|
|
|
400 Val : aliased C.int := 1;
|
|
|
401
|
|
|
402 Res : C.int;
|
|
|
403 pragma Unreferenced (Res);
|
|
|
404
|
|
|
405 begin
|
|
|
406 R := Syscall_Socket (Domain, Typ, Protocol);
|
|
|
407
|
|
|
408 if not SOSC.Thread_Blocking_IO
|
|
|
409 and then R /= Failure
|
|
|
410 then
|
|
|
411 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
|
|
|
412 -- in non-blocking mode by user.
|
|
|
413
|
|
|
414 Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
|
|
|
415 -- Is it OK to ignore result ???
|
|
|
416 Set_Non_Blocking_Socket (R, False);
|
|
|
417 end if;
|
|
|
418
|
|
|
419 return R;
|
|
|
420 end C_Socket;
|
|
|
421
|
|
|
422 --------------
|
|
|
423 -- Finalize --
|
|
|
424 --------------
|
|
|
425
|
|
|
426 procedure Finalize is
|
|
|
427 begin
|
|
|
428 null;
|
|
|
429 end Finalize;
|
|
|
430
|
|
|
431 -------------------------
|
|
|
432 -- Host_Error_Messages --
|
|
|
433 -------------------------
|
|
|
434
|
|
|
435 package body Host_Error_Messages is separate;
|
|
|
436
|
|
|
437 ----------------
|
|
|
438 -- Initialize --
|
|
|
439 ----------------
|
|
|
440
|
|
|
441 procedure Initialize is
|
|
|
442 begin
|
|
|
443 Reset_Socket_Set (Non_Blocking_Sockets'Access);
|
|
|
444 end Initialize;
|
|
|
445
|
|
|
446 -------------------------
|
|
|
447 -- Non_Blocking_Socket --
|
|
|
448 -------------------------
|
|
|
449
|
|
|
450 function Non_Blocking_Socket (S : C.int) return Boolean is
|
|
|
451 R : Boolean;
|
|
|
452 begin
|
|
|
453 Task_Lock.Lock;
|
|
|
454 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
|
|
|
455 Task_Lock.Unlock;
|
|
|
456 return R;
|
|
|
457 end Non_Blocking_Socket;
|
|
|
458
|
|
|
459 -----------------------------
|
|
|
460 -- Set_Non_Blocking_Socket --
|
|
|
461 -----------------------------
|
|
|
462
|
|
|
463 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
|
|
|
464 begin
|
|
|
465 Task_Lock.Lock;
|
|
|
466 if V then
|
|
|
467 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
|
|
|
468 else
|
|
|
469 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
|
|
|
470 end if;
|
|
|
471
|
|
|
472 Task_Lock.Unlock;
|
|
|
473 end Set_Non_Blocking_Socket;
|
|
|
474
|
|
|
475 --------------------
|
|
|
476 -- Signalling_Fds --
|
|
|
477 --------------------
|
|
|
478
|
|
|
479 package body Signalling_Fds is separate;
|
|
|
480
|
|
|
481 --------------------------
|
|
|
482 -- Socket_Error_Message --
|
|
|
483 --------------------------
|
|
|
484
|
|
|
485 function Socket_Error_Message (Errno : Integer) return String is separate;
|
|
|
486
|
|
|
487 end GNAT.Sockets.Thin;
|
