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-2013, 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 is the default version
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   --  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      pragma Unreferenced (Discard);
387
388   begin
389      R := Syscall_Socket (Domain, Typ, Protocol);
390
391      if not SOSC.Thread_Blocking_IO
392        and then R /= Failure
393      then
394         --  Do not use Socket_Ioctl as this subprogram tracks sockets set
395         --  in non-blocking mode by user.
396
397         Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
398         Set_Non_Blocking_Socket (R, False);
399      end if;
400      Disable_SIGPIPE (R);
401      return R;
402   end C_Socket;
403
404   --------------
405   -- Finalize --
406   --------------
407
408   procedure Finalize is
409   begin
410      null;
411   end Finalize;
412
413   -------------------------
414   -- Host_Error_Messages --
415   -------------------------
416
417   package body Host_Error_Messages is separate;
418
419   ----------------
420   -- Initialize --
421   ----------------
422
423   procedure Initialize is
424   begin
425      Disable_All_SIGPIPEs;
426      Reset_Socket_Set (Non_Blocking_Sockets'Access);
427   end Initialize;
428
429   -------------------------
430   -- Non_Blocking_Socket --
431   -------------------------
432
433   function Non_Blocking_Socket (S : C.int) return Boolean is
434      R : Boolean;
435   begin
436      Task_Lock.Lock;
437      R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
438      Task_Lock.Unlock;
439      return R;
440   end Non_Blocking_Socket;
441
442   -----------------------------
443   -- Set_Non_Blocking_Socket --
444   -----------------------------
445
446   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
447   begin
448      Task_Lock.Lock;
449
450      if V then
451         Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
452      else
453         Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
454      end if;
455
456      Task_Lock.Unlock;
457   end Set_Non_Blocking_Socket;
458
459   --------------------
460   -- Signalling_Fds --
461   --------------------
462
463   package body Signalling_Fds is
464
465      --  In this default implementation, we use a C version of these
466      --  subprograms provided by socket.c.
467
468      function C_Create (Fds : not null access Fd_Pair) return C.int;
469      function C_Read (Rsig : C.int) return C.int;
470      function C_Write (Wsig : C.int) return C.int;
471      procedure C_Close (Sig : C.int);
472
473      pragma Import (C, C_Create, "__gnat_create_signalling_fds");
474      pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
475      pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
476      pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
477
478      function Create
479        (Fds : not null access Fd_Pair) return C.int renames C_Create;
480      function Read (Rsig : C.int) return C.int renames C_Read;
481      function Write (Wsig : C.int) return C.int renames C_Write;
482      procedure Close (Sig : C.int) renames C_Close;
483
484   end Signalling_Fds;
485
486   --------------------------
487   -- Socket_Error_Message --
488   --------------------------
489
490   function Socket_Error_Message (Errno : Integer) return String is separate;
491
492end GNAT.Sockets.Thin;
493