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-2004 Ada Core Technologies, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 : constant Fd_Set_Access :=
48 New_Socket_Set (No_Socket_Set);
49 -- When this package is initialized with Process_Blocking_IO set
50 -- to True, sockets are set in non-blocking mode to avoid blocking
51 -- the whole process when a thread wants to perform a blocking IO
52 -- operation. But the user can also set a socket in non-blocking
53 -- mode by purpose. In order to make a difference between these
54 -- two situations, we track the origin of non-blocking mode in
55 -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
56 -- been set in non-blocking mode by the user.
58 Quantum : constant Duration := 0.2;
59 -- When Thread_Blocking_IO is False, we set sockets in
60 -- non-blocking mode and we spend a period of time Quantum between
61 -- two attempts on a blocking operation.
63 Thread_Blocking_IO : Boolean := True;
65 Unknown_System_Error : constant C.Strings.chars_ptr :=
66 C.Strings.New_String ("Unknown system error");
68 function Syscall_Accept
70 Addr : System.Address;
71 Addrlen : access C.int) return C.int;
72 pragma Import (C, Syscall_Accept, "accept");
74 function Syscall_Connect
76 Name : System.Address;
77 Namelen : C.int) return C.int;
78 pragma Import (C, Syscall_Connect, "connect");
80 function Syscall_Ioctl
83 Arg : Int_Access) return C.int;
84 pragma Import (C, Syscall_Ioctl, "ioctl");
90 Flags : C.int) return C.int;
91 pragma Import (C, Syscall_Recv, "recv");
93 function Syscall_Recvfrom
98 From : Sockaddr_In_Access;
99 Fromlen : access C.int) return C.int;
100 pragma Import (C, Syscall_Recvfrom, "recvfrom");
102 function Syscall_Send
104 Msg : System.Address;
106 Flags : C.int) return C.int;
107 pragma Import (C, Syscall_Send, "send");
109 function Syscall_Sendto
111 Msg : System.Address;
114 To : Sockaddr_In_Access;
115 Tolen : C.int) return C.int;
116 pragma Import (C, Syscall_Sendto, "sendto");
118 function Syscall_Socket
121 Protocol : C.int) return C.int;
122 pragma Import (C, Syscall_Socket, "socket");
124 function Non_Blocking_Socket (S : C.int) return Boolean;
125 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
133 Addr : System.Address;
134 Addrlen : access C.int) return C.int
137 Val : aliased C.int := 1;
140 pragma Warnings (Off, Discard);
144 R := Syscall_Accept (S, Addr, Addrlen);
145 exit when Thread_Blocking_IO
147 or else Non_Blocking_Socket (S)
148 or else Errno /= Constants.EWOULDBLOCK;
152 if not Thread_Blocking_IO
153 and then R /= Failure
155 -- A socket inherits the properties ot its server especially
156 -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
157 -- tracks sockets set in non-blocking mode by user.
159 Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
160 Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
172 Name : System.Address;
173 Namelen : C.int) return C.int
178 Res := Syscall_Connect (S, Name, Namelen);
180 if Thread_Blocking_IO
181 or else Res /= Failure
182 or else Non_Blocking_Socket (S)
183 or else Errno /= Constants.EINPROGRESS
189 WSet : Fd_Set_Access;
190 Now : aliased Timeval;
193 WSet := New_Socket_Set (No_Socket_Set);
195 Insert_Socket_In_Set (WSet, S);
202 Now'Unchecked_Access);
206 if Res = Failure then
207 Free_Socket_Set (WSet);
214 Free_Socket_Set (WSet);
217 Res := Syscall_Connect (S, Name, Namelen);
220 and then Errno = Constants.EISCONN
235 Arg : Int_Access) return C.int
238 if not Thread_Blocking_IO
239 and then Req = Constants.FIONBIO
242 Set_Non_Blocking_Socket (S, True);
246 return Syscall_Ioctl (S, Req, Arg);
255 Msg : System.Address;
257 Flags : C.int) return C.int
263 Res := Syscall_Recv (S, Msg, Len, Flags);
264 exit when Thread_Blocking_IO
265 or else Res /= Failure
266 or else Non_Blocking_Socket (S)
267 or else Errno /= Constants.EWOULDBLOCK;
280 Msg : System.Address;
283 From : Sockaddr_In_Access;
284 Fromlen : access C.int) return C.int
290 Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
291 exit when Thread_Blocking_IO
292 or else Res /= Failure
293 or else Non_Blocking_Socket (S)
294 or else Errno /= Constants.EWOULDBLOCK;
307 Msg : System.Address;
309 Flags : C.int) return C.int
315 Res := Syscall_Send (S, Msg, Len, Flags);
316 exit when Thread_Blocking_IO
317 or else Res /= Failure
318 or else Non_Blocking_Socket (S)
319 or else Errno /= Constants.EWOULDBLOCK;
332 Msg : System.Address;
335 To : Sockaddr_In_Access;
336 Tolen : C.int) return C.int
342 Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
343 exit when Thread_Blocking_IO
344 or else Res /= Failure
345 or else Non_Blocking_Socket (S)
346 or else Errno /= Constants.EWOULDBLOCK;
360 Protocol : C.int) return C.int
363 Val : aliased C.int := 1;
366 pragma Unreferenced (Discard);
369 R := Syscall_Socket (Domain, Typ, Protocol);
371 if not Thread_Blocking_IO
372 and then R /= Failure
374 -- Do not use C_Ioctl as this subprogram tracks sockets set
375 -- in non-blocking mode by user.
377 Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
378 Set_Non_Blocking_Socket (R, False);
388 procedure Finalize is
397 procedure Initialize (Process_Blocking_IO : Boolean) is
399 Thread_Blocking_IO := not Process_Blocking_IO;
402 -------------------------
403 -- Non_Blocking_Socket --
404 -------------------------
406 function Non_Blocking_Socket (S : C.int) return Boolean is
410 R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
413 end Non_Blocking_Socket;
419 procedure Set_Address
420 (Sin : Sockaddr_In_Access;
424 Sin.Sin_Addr := Address;
432 (Sin : Sockaddr_In_Access;
436 Sin.Sin_Family := C.unsigned_short (Family);
444 (Sin : Sockaddr_In_Access;
447 pragma Unreferenced (Sin);
448 pragma Unreferenced (Len);
454 -----------------------------
455 -- Set_Non_Blocking_Socket --
456 -----------------------------
458 procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
463 Insert_Socket_In_Set (Non_Blocking_Sockets, S);
465 Remove_Socket_From_Set (Non_Blocking_Sockets, S);
469 end Set_Non_Blocking_Socket;
476 (Sin : Sockaddr_In_Access;
477 Port : C.unsigned_short)
480 Sin.Sin_Port := Port;
483 --------------------------
484 -- Socket_Error_Message --
485 --------------------------
487 function Socket_Error_Message
488 (Errno : Integer) return C.Strings.chars_ptr
490 use type Interfaces.C.Strings.chars_ptr;
492 C_Msg : C.Strings.chars_ptr;
495 C_Msg := C_Strerror (C.int (Errno));
497 if C_Msg = C.Strings.Null_Ptr then
498 return Unknown_System_Error;
503 end Socket_Error_Message;
505 end GNAT.Sockets.Thin;