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-2012, 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   Unknown_System_Error : constant C.Strings.chars_ptr :=
61                            C.Strings.New_String ("Unknown system error");
62
63   --  Comments required for following functions ???
64
65   function Syscall_Accept
66     (S       : C.int;
67      Addr    : System.Address;
68      Addrlen : not null access C.int) return C.int;
69   pragma Import (C, Syscall_Accept, "accept");
70
71   function Syscall_Connect
72     (S       : C.int;
73      Name    : System.Address;
74      Namelen : C.int) return C.int;
75   pragma Import (C, Syscall_Connect, "connect");
76
77   function Syscall_Recv
78     (S     : C.int;
79      Msg   : System.Address;
80      Len   : C.int;
81      Flags : C.int) return C.int;
82   pragma Import (C, Syscall_Recv, "recv");
83
84   function Syscall_Recvfrom
85     (S       : C.int;
86      Msg     : System.Address;
87      Len     : C.int;
88      Flags   : C.int;
89      From    : System.Address;
90      Fromlen : not null access C.int) return C.int;
91   pragma Import (C, Syscall_Recvfrom, "recvfrom");
92
93   function Syscall_Recvmsg
94     (S     : C.int;
95      Msg   : System.Address;
96      Flags : C.int) return System.CRTL.ssize_t;
97   pragma Import (C, Syscall_Recvmsg, "recvmsg");
98
99   function Syscall_Sendmsg
100     (S     : C.int;
101      Msg   : System.Address;
102      Flags : C.int) return System.CRTL.ssize_t;
103   pragma Import (C, Syscall_Sendmsg, "sendmsg");
104
105   function Syscall_Sendto
106     (S     : C.int;
107      Msg   : System.Address;
108      Len   : C.int;
109      Flags : C.int;
110      To    : System.Address;
111      Tolen : C.int) return C.int;
112   pragma Import (C, Syscall_Sendto, "sendto");
113
114   function Syscall_Socket
115     (Domain   : C.int;
116      Typ      : C.int;
117      Protocol : C.int) return C.int;
118   pragma Import (C, Syscall_Socket, "socket");
119
120   procedure Disable_SIGPIPE (S : C.int);
121   pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
122
123   procedure Disable_All_SIGPIPEs;
124   pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
125   --  Sets the process to ignore all SIGPIPE signals on platforms that
126   --  don't support Disable_SIGPIPE for particular streams.
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      Discard : C.int;
144      pragma Warnings (Off, Discard);
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 ot 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         Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
165      end if;
166
167      Disable_SIGPIPE (R);
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
197      begin
198         Reset_Socket_Set (WSet'Access);
199         loop
200            Insert_Socket_In_Set (WSet'Access, S);
201            Now := Immediat;
202            Res := C_Select
203              (S + 1,
204               No_Fd_Set_Access,
205               WSet'Access,
206               No_Fd_Set_Access,
207               Now'Unchecked_Access);
208
209            exit when Res > 0;
210
211            if Res = Failure then
212               return Res;
213            end if;
214
215            delay Quantum;
216         end loop;
217      end;
218
219      Res := Syscall_Connect (S, Name, Namelen);
220
221      if Res = Failure
222        and then Errno = SOSC.EISCONN
223      then
224         return Thin_Common.Success;
225      else
226         return Res;
227      end if;
228   end C_Connect;
229
230   ------------------
231   -- Socket_Ioctl --
232   ------------------
233
234   function Socket_Ioctl
235     (S   : C.int;
236      Req : SOSC.IOCTL_Req_T;
237      Arg : access C.int) return C.int
238   is
239   begin
240      if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
241         if Arg.all /= 0 then
242            Set_Non_Blocking_Socket (S, True);
243         end if;
244      end if;
245
246      return C_Ioctl (S, Req, Arg);
247   end Socket_Ioctl;
248
249   ------------
250   -- C_Recv --
251   ------------
252
253   function C_Recv
254     (S     : C.int;
255      Msg   : System.Address;
256      Len   : C.int;
257      Flags : C.int) return C.int
258   is
259      Res : C.int;
260
261   begin
262      loop
263         Res := Syscall_Recv (S, Msg, Len, Flags);
264         exit when SOSC.Thread_Blocking_IO
265           or else Res /= Failure
266           or else Non_Blocking_Socket (S)
267           or else Errno /= SOSC.EWOULDBLOCK;
268         delay Quantum;
269      end loop;
270
271      return Res;
272   end C_Recv;
273
274   ----------------
275   -- C_Recvfrom --
276   ----------------
277
278   function C_Recvfrom
279     (S       : C.int;
280      Msg     : System.Address;
281      Len     : C.int;
282      Flags   : C.int;
283      From    : System.Address;
284      Fromlen : not null access C.int) return C.int
285   is
286      Res : C.int;
287
288   begin
289      loop
290         Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
291         exit when SOSC.Thread_Blocking_IO
292           or else Res /= Failure
293           or else Non_Blocking_Socket (S)
294           or else Errno /= SOSC.EWOULDBLOCK;
295         delay Quantum;
296      end loop;
297
298      return Res;
299   end C_Recvfrom;
300
301   ---------------
302   -- C_Recvmsg --
303   ---------------
304
305   function C_Recvmsg
306     (S     : C.int;
307      Msg   : System.Address;
308      Flags : C.int) return System.CRTL.ssize_t
309   is
310      Res : System.CRTL.ssize_t;
311
312   begin
313      loop
314         Res := Syscall_Recvmsg (S, Msg, Flags);
315         exit when SOSC.Thread_Blocking_IO
316           or else Res /= System.CRTL.ssize_t (Failure)
317           or else Non_Blocking_Socket (S)
318           or else Errno /= SOSC.EWOULDBLOCK;
319         delay Quantum;
320      end loop;
321
322      return Res;
323   end C_Recvmsg;
324
325   ---------------
326   -- C_Sendmsg --
327   ---------------
328
329   function C_Sendmsg
330     (S     : C.int;
331      Msg   : System.Address;
332      Flags : C.int) return System.CRTL.ssize_t
333   is
334      Res : System.CRTL.ssize_t;
335
336   begin
337      loop
338         Res := Syscall_Sendmsg (S, Msg, Flags);
339         exit when SOSC.Thread_Blocking_IO
340           or else Res /= System.CRTL.ssize_t (Failure)
341           or else Non_Blocking_Socket (S)
342           or else Errno /= SOSC.EWOULDBLOCK;
343         delay Quantum;
344      end loop;
345
346      return Res;
347   end C_Sendmsg;
348
349   --------------
350   -- C_Sendto --
351   --------------
352
353   function C_Sendto
354     (S     : C.int;
355      Msg   : System.Address;
356      Len   : C.int;
357      Flags : C.int;
358      To    : System.Address;
359      Tolen : C.int) return C.int
360   is
361      Res : C.int;
362
363   begin
364      loop
365         Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
366         exit when SOSC.Thread_Blocking_IO
367           or else Res /= Failure
368           or else Non_Blocking_Socket (S)
369           or else Errno /= SOSC.EWOULDBLOCK;
370         delay Quantum;
371      end loop;
372
373      return Res;
374   end C_Sendto;
375
376   --------------
377   -- C_Socket --
378   --------------
379
380   function C_Socket
381     (Domain   : C.int;
382      Typ      : C.int;
383      Protocol : C.int) return C.int
384   is
385      R   : C.int;
386      Val : aliased C.int := 1;
387
388      Discard : C.int;
389      pragma Unreferenced (Discard);
390
391   begin
392      R := Syscall_Socket (Domain, Typ, Protocol);
393
394      if not SOSC.Thread_Blocking_IO
395        and then R /= Failure
396      then
397         --  Do not use Socket_Ioctl as this subprogram tracks sockets set
398         --  in non-blocking mode by user.
399
400         Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
401         Set_Non_Blocking_Socket (R, False);
402      end if;
403      Disable_SIGPIPE (R);
404      return R;
405   end C_Socket;
406
407   --------------
408   -- Finalize --
409   --------------
410
411   procedure Finalize is
412   begin
413      null;
414   end Finalize;
415
416   -------------------------
417   -- Host_Error_Messages --
418   -------------------------
419
420   package body Host_Error_Messages is separate;
421
422   ----------------
423   -- Initialize --
424   ----------------
425
426   procedure Initialize is
427   begin
428      Disable_All_SIGPIPEs;
429      Reset_Socket_Set (Non_Blocking_Sockets'Access);
430   end Initialize;
431
432   -------------------------
433   -- Non_Blocking_Socket --
434   -------------------------
435
436   function Non_Blocking_Socket (S : C.int) return Boolean is
437      R : Boolean;
438   begin
439      Task_Lock.Lock;
440      R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
441      Task_Lock.Unlock;
442      return R;
443   end Non_Blocking_Socket;
444
445   -----------------------------
446   -- Set_Non_Blocking_Socket --
447   -----------------------------
448
449   procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
450   begin
451      Task_Lock.Lock;
452
453      if V then
454         Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
455      else
456         Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
457      end if;
458
459      Task_Lock.Unlock;
460   end Set_Non_Blocking_Socket;
461
462   --------------------
463   -- Signalling_Fds --
464   --------------------
465
466   package body Signalling_Fds is
467
468      --  In this default implementation, we use a C version of these
469      --  subprograms provided by socket.c.
470
471      function C_Create (Fds : not null access Fd_Pair) return C.int;
472      function C_Read (Rsig : C.int) return C.int;
473      function C_Write (Wsig : C.int) return C.int;
474      procedure C_Close (Sig : C.int);
475
476      pragma Import (C, C_Create, "__gnat_create_signalling_fds");
477      pragma Import (C, C_Read,   "__gnat_read_signalling_fd");
478      pragma Import (C, C_Write,  "__gnat_write_signalling_fd");
479      pragma Import (C, C_Close,  "__gnat_close_signalling_fd");
480
481      function Create
482        (Fds : not null access Fd_Pair) return C.int renames C_Create;
483      function Read (Rsig : C.int) return C.int renames C_Read;
484      function Write (Wsig : C.int) return C.int renames C_Write;
485      procedure Close (Sig : C.int) renames C_Close;
486
487   end Signalling_Fds;
488
489   --------------------------
490   -- Socket_Error_Message --
491   --------------------------
492
493   function Socket_Error_Message
494     (Errno : Integer) return C.Strings.chars_ptr
495   is separate;
496
497end GNAT.Sockets.Thin;
498