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) 2002-2018, 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-- 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
38with GNAT.OS_Lib;  use GNAT.OS_Lib;
39with GNAT.Task_Lock;
40
41with Interfaces.C; use Interfaces.C;
42
43package 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
487end GNAT.Sockets.Thin;
488