1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . S O C K E T S . T H I N --
9 -- Copyright (C) 2002-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 version is for VxWorks
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 -----------------------
66 -- Local Subprograms --
67 -----------------------
69 -- All these require comments ???
71 function Syscall_Accept
73 Addr : System.Address;
74 Addrlen : not null access C.int) return C.int;
75 pragma Import (C, Syscall_Accept, "accept");
77 function Syscall_Connect
79 Name : System.Address;
80 Namelen : C.int) return C.int;
81 pragma Import (C, Syscall_Connect, "connect");
83 function Syscall_Ioctl
86 Arg : access C.int) return C.int;
87 pragma Import (C, Syscall_Ioctl, "ioctl");
93 Flags : C.int) return C.int;
94 pragma Import (C, Syscall_Recv, "recv");
96 function Syscall_Recvfrom
101 From : Sockaddr_In_Access;
102 Fromlen : not null access C.int) return C.int;
103 pragma Import (C, Syscall_Recvfrom, "recvfrom");
105 function Syscall_Recvmsg
107 Msg : System.Address;
108 Flags : C.int) return C.int;
109 pragma Import (C, Syscall_Recvmsg, "recvmsg");
111 function Syscall_Sendmsg
113 Msg : System.Address;
114 Flags : C.int) return C.int;
115 pragma Import (C, Syscall_Sendmsg, "sendmsg");
117 function Syscall_Sendto
119 Msg : System.Address;
122 To : Sockaddr_In_Access;
123 Tolen : C.int) return C.int;
124 pragma Import (C, Syscall_Sendto, "sendto");
126 function Syscall_Socket
129 Protocol : C.int) return C.int;
130 pragma Import (C, Syscall_Socket, "socket");
132 function Non_Blocking_Socket (S : C.int) return Boolean;
133 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
141 Addr : System.Address;
142 Addrlen : not null access C.int) return C.int
145 Val : aliased C.int := 1;
148 pragma Unreferenced (Res);
152 R := Syscall_Accept (S, Addr, Addrlen);
153 exit when SOSC.Thread_Blocking_IO
155 or else Non_Blocking_Socket (S)
156 or else Errno /= SOSC.EWOULDBLOCK;
160 if not SOSC.Thread_Blocking_IO
161 and then R /= Failure
163 -- A socket inherits the properties of its server especially
164 -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
165 -- tracks sockets set in non-blocking mode by user.
167 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
168 Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
169 -- Is it OK to ignore result ???
181 Name : System.Address;
182 Namelen : C.int) return C.int
187 Res := Syscall_Connect (S, Name, Namelen);
189 if SOSC.Thread_Blocking_IO
190 or else Res /= Failure
191 or else Non_Blocking_Socket (S)
192 or else Errno /= SOSC.EINPROGRESS
198 WSet : aliased Fd_Set;
199 Now : aliased Timeval;
201 Reset_Socket_Set (WSet'Access);
203 Insert_Socket_In_Set (WSet'Access, S);
210 Now'Unchecked_Access);
214 if Res = Failure then
222 Res := Syscall_Connect (S, Name, Namelen);
225 and then Errno = SOSC.EISCONN
227 return Thin_Common.Success;
240 Arg : access C.int) return C.int
243 if not SOSC.Thread_Blocking_IO
244 and then Req = SOSC.FIONBIO
247 Set_Non_Blocking_Socket (S, True);
251 return Syscall_Ioctl (S, Req, Arg);
260 Msg : System.Address;
262 Flags : C.int) return C.int
268 Res := Syscall_Recv (S, Msg, Len, Flags);
269 exit when SOSC.Thread_Blocking_IO
270 or else Res /= Failure
271 or else Non_Blocking_Socket (S)
272 or else Errno /= SOSC.EWOULDBLOCK;
285 Msg : System.Address;
288 From : Sockaddr_In_Access;
289 Fromlen : not null access C.int) return C.int
295 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
296 exit when SOSC.Thread_Blocking_IO
297 or else Res /= Failure
298 or else Non_Blocking_Socket (S)
299 or else Errno /= SOSC.EWOULDBLOCK;
312 Msg : System.Address;
313 Flags : C.int) return ssize_t
319 Res := Syscall_Recvmsg (S, Msg, Flags);
320 exit when SOSC.Thread_Blocking_IO
321 or else Res /= Failure
322 or else Non_Blocking_Socket (S)
323 or else Errno /= SOSC.EWOULDBLOCK;
327 return ssize_t (Res);
336 Msg : System.Address;
337 Flags : C.int) return ssize_t
343 Res := Syscall_Sendmsg (S, Msg, Flags);
344 exit when SOSC.Thread_Blocking_IO
345 or else Res /= Failure
346 or else Non_Blocking_Socket (S)
347 or else Errno /= SOSC.EWOULDBLOCK;
351 return ssize_t (Res);
360 Msg : System.Address;
363 To : Sockaddr_In_Access;
364 Tolen : C.int) return C.int
370 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
371 exit when SOSC.Thread_Blocking_IO
372 or else Res /= Failure
373 or else Non_Blocking_Socket (S)
374 or else Errno /= SOSC.EWOULDBLOCK;
388 Protocol : C.int) return C.int
391 Val : aliased C.int := 1;
394 pragma Unreferenced (Res);
397 R := Syscall_Socket (Domain, Typ, Protocol);
399 if not SOSC.Thread_Blocking_IO
400 and then R /= Failure
402 -- Do not use C_Ioctl as this subprogram tracks sockets set
403 -- in non-blocking mode by user.
405 Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
406 -- Is it OK to ignore result ???
407 Set_Non_Blocking_Socket (R, False);
417 procedure Finalize is
422 -------------------------
423 -- Host_Error_Messages --
424 -------------------------
426 package body Host_Error_Messages is separate;
432 procedure Initialize is
434 Reset_Socket_Set (Non_Blocking_Sockets'Access);
437 -------------------------
438 -- Non_Blocking_Socket --
439 -------------------------
441 function Non_Blocking_Socket (S : C.int) return Boolean is
445 R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
448 end Non_Blocking_Socket;
450 -----------------------------
451 -- Set_Non_Blocking_Socket --
452 -----------------------------
454 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
458 Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
460 Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
464 end Set_Non_Blocking_Socket;
470 package body Signalling_Fds is separate;
472 --------------------------
473 -- Socket_Error_Message --
474 --------------------------
476 function Socket_Error_Message
477 (Errno : Integer) return C.Strings.chars_ptr
479 use type Interfaces.C.Strings.chars_ptr;
481 C_Msg : C.Strings.chars_ptr;
484 C_Msg := C_Strerror (C.int (Errno));
486 if C_Msg = C.Strings.Null_Ptr then
487 return Unknown_System_Error;
492 end Socket_Error_Message;
494 end GNAT.Sockets.Thin;