1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . T H I N --
9 -- Copyright (C) 2001-2009, AdaCore --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This package provides a target dependent thin interface to the sockets
35 -- layer for use by the GNAT.Sockets package (g-socket.ads). This package
36 -- should not be directly with'ed by an applications program.
38 -- This is the default version
40 with GNAT.OS_Lib; use GNAT.OS_Lib;
43 with Interfaces.C; use Interfaces.C;
45 package body GNAT.Sockets.Thin is
47 Non_Blocking_Sockets : aliased Fd_Set;
48 -- When this package is initialized with Process_Blocking_IO set
49 -- to True, sockets are set in non-blocking mode to avoid blocking
50 -- the whole process when a thread wants to perform a blocking IO
51 -- operation. But the user can also set a socket in non-blocking
52 -- mode by purpose. In order to make a difference between these
53 -- two situations, we track the origin of non-blocking mode in
54 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
55 -- been set in non-blocking mode by the user.
57 Quantum : constant Duration := 0.2;
58 -- When SOSC.Thread_Blocking_IO is False, we set sockets in
59 -- non-blocking mode and we spend a period of time Quantum between
60 -- two attempts on a blocking operation.
62 Unknown_System_Error : constant C.Strings.chars_ptr :=
63 C.Strings.New_String ("Unknown system error");
65 -- Comments required for following functions ???
67 function Syscall_Accept
69 Addr : System.Address;
70 Addrlen : not null access C.int) return C.int;
71 pragma Import (C, Syscall_Accept, "accept");
73 function Syscall_Connect
75 Name : System.Address;
76 Namelen : C.int) return C.int;
77 pragma Import (C, Syscall_Connect, "connect");
83 Flags : C.int) return C.int;
84 pragma Import (C, Syscall_Recv, "recv");
86 function Syscall_Recvfrom
91 From : System.Address;
92 Fromlen : not null access C.int) return C.int;
93 pragma Import (C, Syscall_Recvfrom, "recvfrom");
95 function Syscall_Recvmsg
98 Flags : C.int) return ssize_t;
99 pragma Import (C, Syscall_Recvmsg, "recvmsg");
101 function Syscall_Sendmsg
103 Msg : System.Address;
104 Flags : C.int) return ssize_t;
105 pragma Import (C, Syscall_Sendmsg, "sendmsg");
107 function Syscall_Sendto
109 Msg : System.Address;
113 Tolen : C.int) return C.int;
114 pragma Import (C, Syscall_Sendto, "sendto");
116 function Syscall_Socket
119 Protocol : C.int) return C.int;
120 pragma Import (C, Syscall_Socket, "socket");
122 procedure Disable_SIGPIPE (S : C.int);
123 pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
125 procedure Disable_All_SIGPIPEs;
126 pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
127 -- Sets the process to ignore all SIGPIPE signals on platforms that
128 -- don't support Disable_SIGPIPE for particular streams.
130 function Non_Blocking_Socket (S : C.int) return Boolean;
131 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
139 Addr : System.Address;
140 Addrlen : not null access C.int) return C.int
143 Val : aliased C.int := 1;
146 pragma Warnings (Off, Discard);
150 R := Syscall_Accept (S, Addr, Addrlen);
151 exit when SOSC.Thread_Blocking_IO
153 or else Non_Blocking_Socket (S)
154 or else Errno /= SOSC.EWOULDBLOCK;
158 if not SOSC.Thread_Blocking_IO
159 and then R /= Failure
161 -- A socket inherits the properties ot its server especially
162 -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
163 -- tracks sockets set in non-blocking mode by user.
165 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
166 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
179 Name : System.Address;
180 Namelen : C.int) return C.int
185 Res := Syscall_Connect (S, Name, Namelen);
187 if SOSC.Thread_Blocking_IO
188 or else Res /= Failure
189 or else Non_Blocking_Socket (S)
190 or else Errno /= SOSC.EINPROGRESS
196 WSet : aliased Fd_Set;
197 Now : aliased Timeval;
200 Reset_Socket_Set (WSet'Access);
202 Insert_Socket_In_Set (WSet'Access, S);
209 Now'Unchecked_Access);
213 if Res = Failure then
221 Res := Syscall_Connect (S, Name, Namelen);
224 and then Errno = SOSC.EISCONN
226 return Thin_Common.Success;
236 function Socket_Ioctl
239 Arg : access C.int) return C.int
242 if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
244 Set_Non_Blocking_Socket (S, True);
248 return C_Ioctl (S, Req, Arg);
257 Msg : System.Address;
259 Flags : C.int) return C.int
265 Res := Syscall_Recv (S, Msg, Len, Flags);
266 exit when SOSC.Thread_Blocking_IO
267 or else Res /= Failure
268 or else Non_Blocking_Socket (S)
269 or else Errno /= SOSC.EWOULDBLOCK;
282 Msg : System.Address;
285 From : System.Address;
286 Fromlen : not null access C.int) return C.int
292 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
293 exit when SOSC.Thread_Blocking_IO
294 or else Res /= Failure
295 or else Non_Blocking_Socket (S)
296 or else Errno /= SOSC.EWOULDBLOCK;
309 Msg : System.Address;
310 Flags : C.int) return ssize_t
316 Res := Syscall_Recvmsg (S, Msg, Flags);
317 exit when SOSC.Thread_Blocking_IO
318 or else Res /= ssize_t (Failure)
319 or else Non_Blocking_Socket (S)
320 or else Errno /= SOSC.EWOULDBLOCK;
333 Msg : System.Address;
334 Flags : C.int) return ssize_t
340 Res := Syscall_Sendmsg (S, Msg, Flags);
341 exit when SOSC.Thread_Blocking_IO
342 or else Res /= ssize_t (Failure)
343 or else Non_Blocking_Socket (S)
344 or else Errno /= SOSC.EWOULDBLOCK;
357 Msg : System.Address;
361 Tolen : C.int) return C.int
367 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
368 exit when SOSC.Thread_Blocking_IO
369 or else Res /= Failure
370 or else Non_Blocking_Socket (S)
371 or else Errno /= SOSC.EWOULDBLOCK;
385 Protocol : C.int) return C.int
388 Val : aliased C.int := 1;
391 pragma Unreferenced (Discard);
394 R := Syscall_Socket (Domain, Typ, Protocol);
396 if not SOSC.Thread_Blocking_IO
397 and then R /= Failure
399 -- Do not use Socket_Ioctl as this subprogram tracks sockets set
400 -- in non-blocking mode by user.
402 Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
403 Set_Non_Blocking_Socket (R, False);
413 procedure Finalize is
418 -------------------------
419 -- Host_Error_Messages --
420 -------------------------
422 package body Host_Error_Messages is separate;
428 procedure Initialize is
430 Disable_All_SIGPIPEs;
431 Reset_Socket_Set (Non_Blocking_Sockets'Access);
434 -------------------------
435 -- Non_Blocking_Socket --
436 -------------------------
438 function Non_Blocking_Socket (S : C.int) return Boolean is
442 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
445 end Non_Blocking_Socket;
447 -----------------------------
448 -- Set_Non_Blocking_Socket --
449 -----------------------------
451 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
456 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
458 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
462 end Set_Non_Blocking_Socket;
468 package body Signalling_Fds is
470 -- In this default implementation, we use a C version of these
471 -- subprograms provided by socket.c.
473 function C_Create (Fds : not null access Fd_Pair) return C.int;
474 function C_Read (Rsig : C.int) return C.int;
475 function C_Write (Wsig : C.int) return C.int;
476 procedure C_Close (Sig : C.int);
478 pragma Import (C, C_Create, "__gnat_create_signalling_fds");
479 pragma Import (C, C_Read, "__gnat_read_signalling_fd");
480 pragma Import (C, C_Write, "__gnat_write_signalling_fd");
481 pragma Import (C, C_Close, "__gnat_close_signalling_fd");
484 (Fds : not null access Fd_Pair) return C.int renames C_Create;
485 function Read (Rsig : C.int) return C.int renames C_Read;
486 function Write (Wsig : C.int) return C.int renames C_Write;
487 procedure Close (Sig : C.int) renames C_Close;
491 --------------------------
492 -- Socket_Error_Message --
493 --------------------------
495 function Socket_Error_Message
496 (Errno : Integer) return C.Strings.chars_ptr
498 use type Interfaces.C.Strings.chars_ptr;
500 C_Msg : C.Strings.chars_ptr;
503 C_Msg := C_Strerror (C.int (Errno));
505 if C_Msg = C.Strings.Null_Ptr then
506 return Unknown_System_Error;
510 end Socket_Error_Message;
512 end GNAT.Sockets.Thin;